Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | merge trunk |
|---|---|
| Timelines: | family | ancestors | descendants | both | novem |
| Files: | files | file ages | folders |
| SHA3-256: |
b9c6b552873773a64af33471a76705fd |
| User & Date: | dgp 2023-07-13 19:34:02.458 |
Context
|
2023-07-14
| ||
| 13:28 | merge trunk check-in: e20451ce48 user: dgp tags: novem | |
|
2023-07-13
| ||
| 19:34 | merge trunk check-in: b9c6b55287 user: dgp tags: novem | |
| 16:23 | Merge 8.7 check-in: 528716921f user: jan.nijtmans tags: trunk, main | |
|
2023-06-28
| ||
| 13:33 | merge trunk check-in: fef5e92b3f user: dgp tags: novem | |
Changes
Changes to .fossil-settings/ignore-glob.
| ︙ | ︙ | |||
44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | 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 | > > | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | libtommath/etc/* libtommath/demo/* libtommath/*.out libtommath/*.tex macosx/configure unix/autoMkindex.tcl unix/dltest.marker unix/dltest/embtest unix/dltest/*.bundle unix/dltest/*.dll unix/dltest/*.dylib unix/dltest/*.exe unix/dltest/*.o unix/dltest/*.sl unix/dltest/*.so unix/tcl.pc unix/tclIndex unix/Tcl-Info.plist unix/Tclsh-Info.plist |
| ︙ | ︙ |
Changes to .github/workflows/linux-build.yml.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
name: Linux
on:
push:
branches:
- "main"
- "core-8-branch"
tags:
- "core-**"
permissions:
contents: read
jobs:
gcc:
runs-on: ubuntu-22.04
| > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
name: Linux
on:
push:
branches:
- "main"
- "core-8-branch"
- "core-8-6-branch"
tags:
- "core-**"
permissions:
contents: read
jobs:
gcc:
runs-on: ubuntu-22.04
|
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
defaults:
run:
shell: bash
working-directory: unix
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
working-directory: generic
- name: Configure ${{ matrix.cfgopt }}
run: |
mkdir "${HOME}/install dir"
./configure ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1)
env:
CFGOPT: ${{ matrix.cfgopt }}
- name: Build
run: |
make all
- name: Build Test Harness
run: |
make tcltest
- name: Run Tests
run: |
make test
env:
ERROR_ON_FAILURES: 1
- name: Test-Drive Installation
run: |
make install
- name: Create Distribution Package
run: |
make dist
- name: Convert Documentation to HTML
run: |
make html-tcl
| > > > > > > > > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
defaults:
run:
shell: bash
working-directory: unix
steps:
- name: Checkout
uses: actions/checkout@v3
timeout-minutes: 5
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
working-directory: generic
- name: Configure ${{ matrix.cfgopt }}
run: |
mkdir "${HOME}/install dir"
./configure ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1)
env:
CFGOPT: ${{ matrix.cfgopt }}
timeout-minutes: 5
- name: Build
run: |
make all
timeout-minutes: 5
- name: Build Test Harness
run: |
make tcltest
timeout-minutes: 5
- name: Run Tests
run: |
make test
env:
ERROR_ON_FAILURES: 1
timeout-minutes: 30
- name: Test-Drive Installation
run: |
make install
timeout-minutes: 5
- name: Create Distribution Package
run: |
make dist
timeout-minutes: 5
- name: Convert Documentation to HTML
run: |
make html-tcl
timeout-minutes: 5
|
Changes to .github/workflows/mac-build.yml.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
name: macOS
on:
push:
branches:
- "main"
- "core-8-branch"
tags:
- "core-**"
permissions:
contents: read
jobs:
xcode:
runs-on: macos-11
defaults:
run:
shell: bash
working-directory: macosx
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
working-directory: generic
- name: Build
run: make all
env:
CFLAGS: -arch x86_64 -arch arm64
- name: Run Tests
run: make test styles=develop
env:
ERROR_ON_FAILURES: 1
MAC_CI: 1
clang:
runs-on: macos-11
strategy:
matrix:
cfgopt:
- ""
- "--disable-shared"
- "--enable-symbols"
- "--enable-symbols=mem"
- "--enable-symbols=all"
defaults:
run:
shell: bash
working-directory: unix
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
mkdir "$HOME/install dir"
working-directory: generic
- name: Configure ${{ matrix.cfgopt }}
# Note that macOS is always a 64 bit platform
run: ./configure --enable-dtrace --enable-framework ${CFGOPT} "--prefix=$HOME/install" || (cat config.log && exit 1)
env:
CFLAGS: -arch x86_64 -arch arm64
CFGOPT: ${{ matrix.cfgopt }}
- name: Build
run: |
make all tcltest
env:
CFLAGS: -arch x86_64 -arch arm64
- name: Run Tests
run: |
make test
env:
ERROR_ON_FAILURES: 1
MAC_CI: 1
| > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
name: macOS
on:
push:
branches:
- "main"
- "core-8-branch"
- "core-8-6-branch"
tags:
- "core-**"
permissions:
contents: read
jobs:
xcode:
runs-on: macos-11
defaults:
run:
shell: bash
working-directory: macosx
steps:
- name: Checkout
uses: actions/checkout@v3
timeout-minutes: 5
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
working-directory: generic
- name: Build
run: make all
env:
CFLAGS: -arch x86_64 -arch arm64
timeout-minutes: 15
- name: Run Tests
run: make test styles=develop
env:
ERROR_ON_FAILURES: 1
MAC_CI: 1
timeout-minutes: 15
clang:
runs-on: macos-11
strategy:
matrix:
cfgopt:
- ""
- "--disable-shared"
- "--enable-symbols"
- "--enable-symbols=mem"
- "--enable-symbols=all"
defaults:
run:
shell: bash
working-directory: unix
steps:
- name: Checkout
uses: actions/checkout@v3
timeout-minutes: 5
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
mkdir "$HOME/install dir"
working-directory: generic
- name: Configure ${{ matrix.cfgopt }}
# Note that macOS is always a 64 bit platform
run: ./configure --enable-dtrace --enable-framework ${CFGOPT} "--prefix=$HOME/install" || (cat config.log && exit 1)
env:
CFLAGS: -arch x86_64 -arch arm64
CFGOPT: ${{ matrix.cfgopt }}
timeout-minutes: 5
- name: Build
run: |
make all tcltest
env:
CFLAGS: -arch x86_64 -arch arm64
timeout-minutes: 15
- name: Run Tests
run: |
make test
env:
ERROR_ON_FAILURES: 1
MAC_CI: 1
timeout-minutes: 15
|
Changes to .github/workflows/onefiledist.yml.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
jobs:
linux:
name: Linux
runs-on: ubuntu-20.04
defaults:
run:
shell: bash
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Prepare
run: |
touch generic/tclStubInit.c generic/tclOOStubInit.c
mkdir 1dist
| > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
jobs:
linux:
name: Linux
runs-on: ubuntu-20.04
defaults:
run:
shell: bash
timeout-minutes: 10
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Prepare
run: |
touch generic/tclStubInit.c generic/tclOOStubInit.c
mkdir 1dist
|
| ︙ | ︙ | |||
46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
path: 1dist/*.tar
macos:
name: macOS
runs-on: macos-11
defaults:
run:
shell: bash
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Checkout create-dmg
uses: actions/checkout@v3
with:
repository: create-dmg/create-dmg
| > | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
path: 1dist/*.tar
macos:
name: macOS
runs-on: macos-11
defaults:
run:
shell: bash
timeout-minutes: 10
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Checkout create-dmg
uses: actions/checkout@v3
with:
repository: create-dmg/create-dmg
|
| ︙ | ︙ | |||
108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
path: 1dist/*.dmg
win:
name: Windows
runs-on: windows-2019
defaults:
run:
shell: msys2 {0}
env:
CC: gcc
CFGOPT: --disable-symbols --disable-shared
steps:
- name: Install MSYS2
uses: msys2/setup-msys2@v2
with:
| > | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 |
path: 1dist/*.dmg
win:
name: Windows
runs-on: windows-2019
defaults:
run:
shell: msys2 {0}
timeout-minutes: 10
env:
CC: gcc
CFGOPT: --disable-symbols --disable-shared
steps:
- name: Install MSYS2
uses: msys2/setup-msys2@v2
with:
|
| ︙ | ︙ |
Changes to .github/workflows/win-build.yml.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
name: Windows
on:
push:
branches:
- "main"
- "core-8-branch"
tags:
- "core-**"
permissions:
contents: read
env:
ERROR_ON_FAILURES: 1
jobs:
| > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
name: Windows
on:
push:
branches:
- "main"
- "core-8-branch"
- "core-8-6-branch"
tags:
- "core-**"
permissions:
contents: read
env:
ERROR_ON_FAILURES: 1
jobs:
|
| ︙ | ︙ | |||
26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
- "OPTS=static"
- "OPTS=symbols"
- "OPTS=symbols STATS=compdbg,memdbg"
# Using powershell means we need to explicitly stop on failure
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Init MSVC
uses: ilammy/msvc-dev-cmd@v1
- name: Build ${{ matrix.cfgopt }}
run: |
&nmake -f makefile.vc ${{ matrix.cfgopt }} all
if ($lastexitcode -ne 0) {
throw "nmake exit code: $lastexitcode"
}
- name: Build Test Harness ${{ matrix.cfgopt }}
run: |
&nmake -f makefile.vc ${{ matrix.cfgopt }} tcltest
if ($lastexitcode -ne 0) {
throw "nmake exit code: $lastexitcode"
}
- name: Run Tests ${{ matrix.cfgopt }}
run: |
&nmake -f makefile.vc ${{ matrix.cfgopt }} test
if ($lastexitcode -ne 0) {
throw "nmake exit code: $lastexitcode"
}
gcc:
runs-on: windows-2022
defaults:
run:
shell: msys2 {0}
working-directory: win
strategy:
| > > > > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
- "OPTS=static"
- "OPTS=symbols"
- "OPTS=symbols STATS=compdbg,memdbg"
# Using powershell means we need to explicitly stop on failure
steps:
- name: Checkout
uses: actions/checkout@v3
timeout-minutes: 5
- name: Init MSVC
uses: ilammy/msvc-dev-cmd@v1
timeout-minutes: 5
- name: Build ${{ matrix.cfgopt }}
run: |
&nmake -f makefile.vc ${{ matrix.cfgopt }} all
if ($lastexitcode -ne 0) {
throw "nmake exit code: $lastexitcode"
}
timeout-minutes: 5
- name: Build Test Harness ${{ matrix.cfgopt }}
run: |
&nmake -f makefile.vc ${{ matrix.cfgopt }} tcltest
if ($lastexitcode -ne 0) {
throw "nmake exit code: $lastexitcode"
}
timeout-minutes: 5
- name: Run Tests ${{ matrix.cfgopt }}
run: |
&nmake -f makefile.vc ${{ matrix.cfgopt }} test
if ($lastexitcode -ne 0) {
throw "nmake exit code: $lastexitcode"
}
timeout-minutes: 30
gcc:
runs-on: windows-2022
defaults:
run:
shell: msys2 {0}
working-directory: win
strategy:
|
| ︙ | ︙ | |||
69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
# Using powershell means we need to explicitly stop on failure
steps:
- name: Install MSYS2
uses: msys2/setup-msys2@v2
with:
msystem: MINGW64
install: git mingw-w64-x86_64-toolchain make
- name: Checkout
uses: actions/checkout@v3
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
mkdir "${HOME}/install dir"
working-directory: generic
- name: Configure ${{ matrix.cfgopt }}
run: |
./configure ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1)
env:
CFGOPT: --enable-64bit ${{ matrix.cfgopt }}
- name: Build
run: make all
- name: Build Test Harness
run: make tcltest
- name: Run Tests
run: make test
# If you add builds with Wine, be sure to define the environment variable
# CI_USING_WINE when running them so that broken tests know not to run.
| > > > > > > | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
# Using powershell means we need to explicitly stop on failure
steps:
- name: Install MSYS2
uses: msys2/setup-msys2@v2
with:
msystem: MINGW64
install: git mingw-w64-x86_64-toolchain make
timeout-minutes: 10
- name: Checkout
uses: actions/checkout@v3
timeout-minutes: 5
- name: Prepare
run: |
touch tclStubInit.c tclOOStubInit.c tclOOScript.h
mkdir "${HOME}/install dir"
working-directory: generic
- name: Configure ${{ matrix.cfgopt }}
run: |
./configure ${CFGOPT} "--prefix=$HOME/install dir" || (cat config.log && exit 1)
env:
CFGOPT: --enable-64bit ${{ matrix.cfgopt }}
timeout-minutes: 5
- name: Build
run: make all
timeout-minutes: 5
- name: Build Test Harness
run: make tcltest
timeout-minutes: 5
- name: Run Tests
run: make test
timeout-minutes: 30
# If you add builds with Wine, be sure to define the environment variable
# CI_USING_WINE when running them so that broken tests know not to run.
|
Changes to .gitignore.
| ︙ | ︙ | |||
49 50 51 52 53 54 55 56 57 58 59 60 61 62 | 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/* | > | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | libtommath/etc/* libtommath/demo/* libtommath/*.out libtommath/*.tex macosx/configure unix/autoMkindex.tcl unix/dltest.marker unix/dltest/embtest unix/tcl.pc unix/tclIndex unix/pkgs/* win/Debug* win/Release* win/*.manifest win/pkgs/* |
| ︙ | ︙ |
Changes to changes.
| ︙ | ︙ | |||
8243 8244 8245 8246 8247 8248 8249 |
2013-05-29 (bug fix)[3614102] [apply {{} {list [if 1]}}] stack woes (porter)
2013-06-03 Restored lost performance appending to long strings (elby,porter)
2013-06-05 (bug fix)[2835313] [while 1 {foo [continue]}] crash (fellows)
| | | 8243 8244 8245 8246 8247 8248 8249 8250 8251 8252 8253 8254 8255 8256 8257 |
2013-05-29 (bug fix)[3614102] [apply {{} {list [if 1]}}] stack woes (porter)
2013-06-03 Restored lost performance appending to long strings (elby,porter)
2013-06-05 (bug fix)[2835313] [while 1 {foo [continue]}] crash (fellows)
2013-06-17 (bug fix)[a876646] [:cntrl:] includes \x00 to \x1F (nijtmans)
2013-06-27 (bug fix)[983509] missing encodings for config values (nijtmans)
2013-06-27 (bug fix)[34538b] apply DST in 2099 (lang)
2013-07-02 (bug fix)[32afa6] corrected dirent64 check (griffin)
|
| ︙ | ︙ |
Changes to doc/Encoding.3.
| ︙ | ︙ | |||
543 544 545 546 547 548 549 |
.PP
.CS
.ta 1.5i
# Encoding file: iso2022-jp, escape-driven
E
init {}
final {}
| | | | | | | | | | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 |
.PP
.CS
.ta 1.5i
# Encoding file: iso2022-jp, escape-driven
E
init {}
final {}
iso8859-1 \ex1B(B
jis0201 \ex1B(J
jis0208 \ex1B$@
jis0208 \ex1B$B
jis0212 \ex1B$(D
gb2312 \ex1B$A
ksc5601 \ex1B$(C
.CE
.PP
In the file, the first column represents an option and the second column
is the associated value. \fBinit\fR is a string to emit or expect before
the first character is converted, while \fBfinal\fR is a string to emit
or expect after the last character. All other options are names of
table-based encodings; the associated value is the escape-sequence that
marks that encoding. Tcl syntax is used for the values; in the above
example, for instance,
.QW \fB{}\fR
represents the empty string and
.QW \fB\ex1B\fR
represents character 27.
.PP
When \fBTcl_GetEncoding\fR encounters an encoding \fIname\fR that has not
been loaded, it attempts to load an encoding file called \fIname\fB.enc\fR
from the \fBencoding\fR subdirectory of each directory that Tcl searches
for its script library. If the encoding file exists, but is
malformed, an error message will be left in \fIinterp\fR.
|
| ︙ | ︙ |
Changes to doc/Object.3.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 26 27 28 29 30 31 32 | Tcl_Obj * \fBTcl_DuplicateObj\fR(\fIobjPtr\fR) .sp \fBTcl_IncrRefCount\fR(\fIobjPtr\fR) .sp \fBTcl_DecrRefCount\fR(\fIobjPtr\fR) .sp int \fBTcl_IsShared\fR(\fIobjPtr\fR) .sp \fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR) .SH ARGUMENTS .AS Tcl_Obj *objPtr .AP Tcl_Obj *objPtr in | > > | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | Tcl_Obj * \fBTcl_DuplicateObj\fR(\fIobjPtr\fR) .sp \fBTcl_IncrRefCount\fR(\fIobjPtr\fR) .sp \fBTcl_DecrRefCount\fR(\fIobjPtr\fR) .sp \fBTcl_BumpObj\fR(\fIobjPtr\fR) .sp int \fBTcl_IsShared\fR(\fIobjPtr\fR) .sp \fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR) .SH ARGUMENTS .AS Tcl_Obj *objPtr .AP Tcl_Obj *objPtr in |
| ︙ | ︙ | |||
274 275 276 277 278 279 280 | .PP The string representation of \fIx\fR's value is needed and is recomputed. The string representation is now \fB124\fR and both representations are again valid. .SH "STORAGE MANAGEMENT OF VALUES" .PP | | | < | | > | | | | | | | | | < | > > | < | > > > | | | > > > > > > > | | | > > > > | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 | .PP The string representation of \fIx\fR's value is needed and is recomputed. The string representation is now \fB124\fR and both representations are again valid. .SH "STORAGE MANAGEMENT OF VALUES" .PP Tcl values are allocated on the heap and are shared as much as possible to reduce storage requirements. Reference counting is used to determine when a value is no longer needed and can safely be freed. A value just created by \fBTcl_NewObj\fR, \fBTcl_NewStringObj\fR, or any Abstract List command or function, has \fIrefCount\fR 0, meaning that the object can often be given to a function like \fBTcl_SetObjResult\fR, \fBTcl_ListObjAppendElement\fR, or \fBTcl_DictObjPut\fR (as a value) without explicit reference management, all of which are common use cases. (The latter two require that the target list or dictionary be well-formed, but that is often easy to arrange when the value is being initially constructed.) The macro \fBTcl_IncrRefCount\fR increments the reference count when a new reference to the value is created. The macro \fBTcl_DecrRefCount\fR decrements the count when a reference is no longer needed. If the value's reference count drops to zero, frees its storage. The macro \fBTcl_BumpObj\fR will check if the value has no references (i.e. in a "new" state) and free the value. A value shared by different code or data structures has \fIrefCount\fR greater than 1. Incrementing a value's reference count ensures that it will not be freed too early or have its value change accidentally. .PP As an example, the bytecode interpreter shares argument values between calling and called Tcl procedures to avoid having to copy values. It assigns the call's argument values to the procedure's formal parameter variables. In doing so, it calls \fBTcl_IncrRefCount\fR to increment the reference count of each argument since there is now a new reference to it from the formal parameter. When the called procedure returns, the interpreter calls \fBTcl_DecrRefCount\fR to decrement each argument's reference count. When a value's reference count drops less than or equal to zero, \fBTcl_DecrRefCount\fR reclaims its storage. .PP Most command procedures have not been concerned about reference counting since they use a value's value immediately and do not retain a pointer to the value after they return. However, there are some procedures that may return a new value, with a refCount of 0. In this situation, it is the caller's responsibility to free the value before the procedure returns. One way to cover this is to always call \fBTcl_IncrRefCount\fR before using the value, then call \fBTcl_DecrRefCount\fR before returning. The other way is to use \fBTcl_BumpObj\fR after the value is no longer needed or referenced. This macro will free the value if there are no other references to the value. When retaining a pointer to a value in a data structure the procedure must be careful to increment its reference count since the retained pointer is a new reference. Examples of procedures that return new values are \fBTcl_NewIntObj\fR, and commands like \fBlseq\fR, which creates an Abstract List, and an lindex on this list may return a new Obj with a refCount of 0. .PP Command procedures that directly modify values such as those for \fBlappend\fR and \fBlinsert\fR must be careful to copy a shared value before changing it. They must first check whether the value is shared by calling \fBTcl_IsShared\fR. If the value is shared they must copy the value |
| ︙ | ︙ | |||
346 347 348 349 350 351 352 353 354 355 356 357 | .CE .PP As another example, \fBincr\fR's command procedure must check whether the variable's value is shared before incrementing the integer in its internal representation. If it is shared, it needs to duplicate the value in order to avoid accidentally changing values in other data structures. .SH "SEE ALSO" Tcl_ConvertToType(3), Tcl_GetIntFromObj(3), Tcl_ListObjAppendElement(3), Tcl_ListObjIndex(3), Tcl_ListObjReplace(3), Tcl_RegisterObjType(3) .SH KEYWORDS internal representation, value, value creation, value type, reference counting, string representation, type conversion | > > > > > | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 | .CE .PP As another example, \fBincr\fR's command procedure must check whether the variable's value is shared before incrementing the integer in its internal representation. If it is shared, it needs to duplicate the value in order to avoid accidentally changing values in other data structures. .PP In cases where a value is obtained, used, and not retained, the value can be freed using \fBTcl_BumpObj\fR. This is functionally equivalent to calling \fBTcl_IncrRefCount\fR followed \fBTcl_DecrRefCount\fR. .SH "SEE ALSO" Tcl_ConvertToType(3), Tcl_GetIntFromObj(3), Tcl_ListObjAppendElement(3), Tcl_ListObjIndex(3), Tcl_ListObjReplace(3), Tcl_RegisterObjType(3) .SH KEYWORDS internal representation, value, value creation, value type, reference counting, string representation, type conversion |
Changes to doc/ObjectType.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996-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. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996-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_ObjType 3 9.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType \- manipulate Tcl value types .SH SYNOPSIS .nf \fB#include <tcl.h>\fR |
| ︙ | ︙ | |||
89 90 91 92 93 94 95 | 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. .SH "THE TCL_OBJTYPE STRUCTURE" .PP | | < | | | | | | > > > > > > > > > | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
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.
.SH "THE TCL_OBJTYPE STRUCTURE"
.PP
Extension writers can define new value types by defining four to eight
procedures and initializing a Tcl_ObjType structure to describe the
type. Extension writers may also pass a pointer to their Tcl_ObjType
structure to \fBTcl_RegisterObjType\fR if they wish to permit other
extensions to look up their Tcl_ObjType by name with the
\fBTcl_GetObjType\fR routine. The \fBTcl_ObjType\fR structure is
defined as follows:
.PP
.CS
typedef struct Tcl_ObjType {
const char *\fIname\fR;
Tcl_FreeInternalRepProc *\fIfreeIntRepProc\fR;
Tcl_DupInternalRepProc *\fIdupIntRepProc\fR;
Tcl_UpdateStringProc *\fIupdateStringProc\fR;
Tcl_SetFromAnyProc *\fIsetFromAnyProc\fR;
size_t \fIversion\fR;
/* List emulation functions - ObjType Version 1 & 2 */
Tcl_ObjTypeLengthProc *lengthProc;
/* List emulation functions - ObjType Version 2 */
Tcl_ObjTypeIndexProc *\fIindexProc\fR;
Tcl_ObjTypeSliceProc *\fIsliceProc\fR;
Tcl_ObjTypeReverseProc *\fIreverseProc\fR;
Tcl_ObjTypeGetElements *\fIgetElementsProc\fR;
Tcl_ObjTypeSetElement *\fIsetElementProc\fR;
Tcl_ObjTypeReplaceProc *\fIreplaceProc\fR;
} \fBTcl_ObjType\fR;
.CE
.SS "THE NAME FIELD"
.PP
The \fIname\fR member describes the name of the type, e.g. \fBint\fR.
When a type is registered, this is the name used by callers
of \fBTcl_GetObjType\fR to lookup the type. For unregistered
|
| ︙ | ︙ | |||
252 253 254 255 256 257 258 | .PP Note that if a subsidiary value has its reference count reduced to zero during the running of a \fIfreeIntRepProc\fR, that value may be not freed immediately, in order to limit stack usage. However, the value will be freed before the outermost current \fBTcl_DecrRefCount\fR returns. .SS "THE VERSION FIELD" .PP | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
.PP
Note that if a subsidiary value has its reference count reduced to zero
during the running of a \fIfreeIntRepProc\fR, that value may be not freed
immediately, in order to limit stack usage. However, the value will be freed
before the outermost current \fBTcl_DecrRefCount\fR returns.
.SS "THE VERSION FIELD"
.PP
The \fIversion\fR member provides for future extensibility of the
structure and should be set to \fBTCL_OBJTYPE_V0\fR for compatability
of ObjType definitions prior to version 9.0. Specifics about versions
will be described further in the sections below.
.SH "ABSTRACT LIST TYPES"
.PP
Additional fields in the Tcl_ObjType descriptor allow for control over
how custom data values can be manipulated using Tcl's List commands
without converting the value to a List type. This requires the custom
type to provide functions that will perform the given operation on the
custom data representation. Not all functions are required. In the
absence of a particular function (set to NULL), the fallback is to
allow the internal List operation to perform the operation, most
likely causing the value type to be converted to a traditional list.
.SS "SCALAR VALUE TYPES"
.PP
For a custom value type that is scalar or atomic in nature, i.e., not
a divisible collection, version \fBTCL_OBJTYPE_V1\fR is
recommended. In this case, List commands will treat the scalar value
as if it where a list of length 1, and not convert the value to a List
type.
.SS "VERSION 2: ABSTRACT LISTS"
.PP
Version 2, \fBTCL_OBJTYPE_V2\fR, allows full List support when the
functions described below are provided. This allows for script level
use of the List commands without causing the type of the Tcl_Obj value
to be converted to a list.
.SS "THE LENGTHPROC FIELD"
.PP
The \fBLengthProc\fR function correlates with the \fBllength\fR
command. The function returns the number of elements in the list. It
is used in every List operation and is required for all Abstract List
implementations.
.CS
typedef Tcl_Size
(Tcl_ObjTypeLengthProc) (Tcl_Obj *listPtr);
.CE
.PP
.SS "THE INDEXPROC FIELD"
.PP
The \fBIndexProc\fR function correlates with the \fBlindex\fR
command. The function returns a Tcl_Obj value for the element at the
specified index.
.CS
typedef int
(Tcl_ObjTypeIndexProc) (
Tcl_Interp *interp,
Tcl_Obj *listPtr,
Tcl_Size index,
Tcl_Obj** elemObj);
.CE
.SS "THE SLICEPROC FIELD"
.PP
The \fBSliceProc\fR correlates with the \fBlrange\fR command,
returning a new List or Abstract List for the portion of the original
list specifed.
.CS
typedef int
(Tcl_ObjTypeSliceProc) (
Tcl_Interp *interp,
Tcl_Obj *listPtr,
Tcl_Size fromIdx,
Tcl_Size toIdx,
Tcl_Obj **newObjPtr);
.CE
.SS "THE REVERSEPROC FIELD"
.PP
The \fBReverseProc\fR correlates with the \fBlreverse\fR command,
returning a List or Abstract List that has the same elements as the
input Abstract List, with the elements in the reverse order.
.CS
typedef int
(Tcl_ObjTypeReverseProc) (
Tcl_Interp *interp,
Tcl_Obj *listPtr,
Tcl_Obj **newObjPtr);
.CE
.SS "THE GETELEMENTS FIELD"
.PP
THe \fBGetElements\fR function returns a count and a pointer to an
array of Tcl_Obj values for the entire Abstract List. This is a
correlary to the \fBTcl_ListObjGetElements\fR C API call.
.CS
typedef int
(Tcl_ObjTypeGetElements) (
Tcl_Interp *interp,
Tcl_Obj *listPtr,
Tcl_Size *objcptr,
Tcl_Obj ***objvptr);
.CE
.SS "THE SETELEMENT FIELD"
.PP
The \fBSetElement\fR function replaces the element within the
specified list at the give index. This function correlates to the
\fBlset\fR command. typedef Tcl_Obj*
.CS
Tcl_ObjTypeSetElement) (
Tcl_Interp *interp,
Tcl_Obj *listPtr,
Tcl_Size indexCount,
Tcl_Obj *const indexArray[],
Tcl_Obj *valueObj);
.CE
.SS "REPLACEPROC FIELD"
.PP
The \fBReplaceProc\fR returns a new list after modfying the list
replacing the elements to be deleted, and adding the elements to be
inserted. This function correlates to the \fBlreplace\fR command.
.CS
typedef int
(Tcl_ObjTypeReplaceProc) (
Tcl_Interp *interp,
Tcl_Obj *listObj,
Tcl_Size first,
Tcl_Size numToDelete,
Tcl_Size numToInsert,
Tcl_Obj *const insertObjs[]);
.CE
.SH "REFERENCE COUNT MANAGEMENT"
.PP
The \fIobjPtr\fR argument to \fBTcl_AppendAllObjTypes\fR should be an unshared
value; this function will not modify the reference count of that value, but
will modify its contents. If \fIobjPtr\fR is not (interpretable as) a list,
this function will set the interpreter result and produce an error; using an
unshared empty value is strongly recommended.
|
| ︙ | ︙ |
Changes to doc/binary.n.
| ︙ | ︙ | |||
237 238 239 240 241 242 243 | .PP which returns a binary string equivalent to: .PP .CS \fB\e254\fR .CE .PP | | | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 | .PP which returns a binary string equivalent to: .PP .CS \fB\e254\fR .CE .PP (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 |
| ︙ | ︙ | |||
295 296 297 298 299 300 301 | .CS \fBbinary format\fR B5B* 11100 111000011010 .CE .PP will return a binary string equivalent to: .PP .CS | | | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 | .CS \fBbinary format\fR B5B* 11100 111000011010 .CE .PP will return a binary string equivalent to: .PP .CS \fB\exE0\exE1\exA0\fR .CE .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 sequence of characters in the set .QW 0123456789abcdefABCDEF . |
| ︙ | ︙ | |||
322 323 324 325 326 327 328 | .CS \fBbinary format\fR H3H*H2 ab DEF 987 .CE .PP will return a binary string equivalent to: .PP .CS | | | | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 | .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 .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 .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 |
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
.CS
\fBbinary format\fR c3cc* {3 -3 128 1} 260 {2 5}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
| | | 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 |
.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
.CS
\fBbinary format\fR c {2 5}
.CE
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 |
.CS
\fBbinary format\fR s3 {3 -3 258 1}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
| | | | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 |
.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
.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
.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.
To determine what the native byte order of the machine is, refer to
|
| ︙ | ︙ | |||
425 426 427 428 429 430 431 |
.CS
\fBbinary format\fR i3 {3 -3 65536 1}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
| | | | 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
.CS
\fBbinary format\fR i3 {3 -3 65536 1}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
\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
\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
script is running.
|
| ︙ | ︙ | |||
506 507 508 509 510 511 512 |
.CS
\fBbinary format\fR f2 {1.6 3.4}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
| | | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 |
.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
.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
machines which use the IEEE floating point representation (very
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 |
.CS
\fBbinary format\fR d1 {1.6}
.CE
.PP
will return a binary string equivalent to:
.PP
.CS
| | | 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 |
.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
.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
when used on machines which use the IEEE floating point representation
|
| ︙ | ︙ | |||
784 785 786 787 788 789 790 | .QW \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 | | | 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 | .QW \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 |
| ︙ | ︙ | |||
835 836 837 838 839 840 841 | .QW \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 | | | | 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 | .QW \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. .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 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 |
| ︙ | ︙ | |||
874 875 876 877 878 879 880 | .QW \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 | | | | 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 | .QW \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. .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, .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 |
| ︙ | ︙ | |||
916 917 918 919 920 921 922 | .QW \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 | | | | 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 | .QW \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. .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, .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 |
| ︙ | ︙ | |||
962 963 964 965 966 967 968 | 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 | | | 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 | 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 |
| ︙ | ︙ | |||
986 987 988 989 990 991 992 | 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 | | | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 | 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 |
| ︙ | ︙ |
Changes to doc/chan.n.
| ︙ | ︙ | |||
148 149 150 151 152 153 154 | \fB\-eofchar\fR \fIchar\fR . \fIchar\fR signals the end of the data when it is encountered in the input. If \fIchar\fR is the empty string, there is no special character that marks the end of the data. The default value is the empty string. The acceptable range is \ex01 - | | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 | \fB\-eofchar\fR \fIchar\fR . \fIchar\fR signals the end of the data when it is encountered in the input. If \fIchar\fR is the empty string, there is no special character that marks the end of the data. The default value is the empty string. The acceptable range is \ex01 - \ex7F. A value outside this range results in an error. .VS "TCL8.7 TIP656" .TP \fB\-profile\fR \fIprofile\fR . Specifies the encoding profile to be used on the channel. The encoding transforms in use for the channel's input and output will then be subject to the rules of that profile. Any failures will result in a channel error. See |
| ︙ | ︙ | |||
241 242 243 244 245 246 247 | the number of characters copied. Leverages internal buffers to avoid extra copies and to avoid buffering too much data in main memory when copying large files to slow destinations like network sockets. .RS .PP \fB\-size\fR limits the number of characters copied. .PP | | | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 | the number of characters copied. Leverages internal buffers to avoid extra copies and to avoid buffering too much data in main memory when copying large files to slow destinations like network sockets. .RS .PP \fB\-size\fR limits the number of characters copied. .PP If \fB\-command\fR is given, \fBchan copy\fR returns immediately, works in the background, and calls \fIcallback\fR when the copy completes, providing as an additional argument the number of characters written to \fIoutputChan\fR. If an error occurs during the background copy, another argument provides message for the error. \fIinputChan\fR and \fIoutputChan\fR are automatically configured for non-blocking mode if needed. Background copying only works correctly if events are being processed, e.g. via \fBvwait\fR or Tk. .PP During a background copy no other read operation may be performed on \fIinputChan\fR, and no write operation may be performed on \fIoutputChan\fR. However, write operations may by performed on |
| ︙ | ︙ |
Changes to doc/lseq.n.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | \fBlseq \fIstart \fBcount\fR \fIcount\fR ??\fBby\fR? \fIstep\fR? \fBlseq \fIcount\fR ?\fBby \fIstep\fR? .BE .SH DESCRIPTION .PP The \fBlseq\fR command creates a sequence of numeric values using the given | | | > > > | > > > > > > > | | > > | > > | | | > > > | > > > > > > > > | > | > > > | | | | | | | | | | | | | | | | | | | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
\fBlseq \fIstart \fBcount\fR \fIcount\fR ??\fBby\fR? \fIstep\fR?
\fBlseq \fIcount\fR ?\fBby \fIstep\fR?
.BE
.SH DESCRIPTION
.PP
The \fBlseq\fR command creates a sequence of numeric values using the given
parameters \fIstart\fR, \fIend\fR, and \fIstep\fR. The \fIoperation\fR
argument "\fB..\fR" or "\fBto\fR" defines the range. The "\fBcount\fR" option
is used to define a count of the number of elements in the list. A short form
use of the command, with a single count value, will create a range from 0 to
count-1.
The \fBlseq\fR command can produce both increasing and decreasing
sequences. When both \fIstart\fR and \fIend\fR are provided without a
\fIstep\fR value, then if \fIstart\fR <= \fIend\fR, the sequence will be
increasing and if \fIstart\fR > \fIend\fR it will be decreasing. If a
\fIstep\fR vale is included, it's sign should agree with the direction of the
sequence (descending -> negative and ascending -> positive), otherwise an
empty list is returned. For example:
.CS \"
% \fBlseq\fR 1 to 5 ;# increasing
\fI\(-> 1 2 3 4 5
% \fBlseq\fR 5 to 1 ;# decreasing
\fI\(-> 5 4 3 2 1
% \fBlseq\fR 6 to 1 by 2 ;# decreasing, step wrong sign, empty list
% \fBlseq\fR 1 to 5 by 0 ;# all step sizes of 0 produce an empty list
.\"
.CE
The numeric arguments, \fIstart\fR, \fIend\fR, \fIstep\fR, and \fIcount\fR,
may also be a valid expression. The expression will be evaluated and the
numeric result will be used. An expression that does not evaluate to a number
will produce an invalid argument error.
.PP
\fIStart\fR defines the initial value and \fIend\fR defines the limit, not
necessarily the last value. \fBlseq\fR produces a list with \fIcount\fR
elements, and if \fIcount\fR is not supplied, it is computed as
.CS \"
\fIcount\fR = int( (\fIend\fR - \fIstart\fR + \fIstep\fR) / \fIstep\fR )
.\"
.CE
.PP
The numeric arguments, \fIstart\fR, \fIend\fR, \fIstep\fR, and \fIcount\fR,
can also be a valid expression. the \fBlseq\fR command will evaluate the
expression (as if with \fBexpr\fR)
and use the numeric result, or return an error as with any invalid argument
value; a non-numeric expression result will result in an error.
.SH EXAMPLES
.CS
.\"
\fBlseq\fR 3
\fI\(-> 0 1 2\fR
\fBlseq\fR 3 0
\fI\(-> 3 2 1 0\fR
\fBlseq\fR 10 .. 1 by -2
\fI\(-> 10 8 6 4 2\fR
set l [\fBlseq\fR 0 -5]
\fI\(-> 0 -1 -2 -3 -4 -5\fR
foreach i [\fBlseq\fR [llength $l]] {
puts l($i)=[lindex $l $i]
}
\fI\(-> l(0)=0\fR
\fI\(-> l(1)=-1\fR
\fI\(-> l(2)=-2\fR
\fI\(-> l(3)=-3\fR
\fI\(-> l(4)=-4\fR
\fI\(-> l(5)=-5\fR
foreach i [\fBlseq\fR {[llength $l]-1} 0] {
puts l($i)=[lindex $l $i]
}
\fI\(-> l(5)=-5\fR
\fI\(-> l(4)=-4\fR
\fI\(-> l(3)=-3\fR
\fI\(-> l(2)=-2\fR
\fI\(-> l(1)=-1\fR
\fI\(-> l(0)=0\fR
set i 17
\fI\(-> 17\fR
if {$i in [\fBlseq\fR 0 50]} { # equivalent to: (0 <= $i && $i <= 50)
puts "Ok"
} else {
puts "outside :("
}
\fI\(-> Ok\fR
set sqrs [lmap i [\fBlseq\fR 1 10] { expr {$i*$i} }]
\fI\(-> 1 4 9 16 25 36 49 64 81 100\fR
.\"
.CE
.SH "SEE ALSO"
foreach(n), list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n),
lreverse(n), lsearch(n), lset(n), lsort(n)
.SH KEYWORDS
element, index, list
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:
|
Changes to generic/tcl.h.
| ︙ | ︙ | |||
569 570 571 572 573 574 575 576 577 578 579 580 581 582 | typedef void (Tcl_DeleteFileHandlerProc) (int fd); typedef void (Tcl_AlertNotifierProc) (void *clientData); typedef void (Tcl_ServiceModeHookProc) (int mode); typedef void *(Tcl_InitNotifierProc) (void); typedef void (Tcl_FinalizeNotifierProc) (void *clientData); typedef void (Tcl_MainLoopProc) (void); #ifndef TCL_NO_DEPRECATED # define Tcl_PackageInitProc Tcl_LibraryInitProc # define Tcl_PackageUnloadProc Tcl_LibraryUnloadProc #endif /* *---------------------------------------------------------------------------- | > > > > > > > > > > > > > > > > > > > > | 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 |
typedef void (Tcl_DeleteFileHandlerProc) (int fd);
typedef void (Tcl_AlertNotifierProc) (void *clientData);
typedef void (Tcl_ServiceModeHookProc) (int mode);
typedef void *(Tcl_InitNotifierProc) (void);
typedef void (Tcl_FinalizeNotifierProc) (void *clientData);
typedef void (Tcl_MainLoopProc) (void);
/* Abstract List functions */
typedef Tcl_Size (Tcl_ObjTypeLengthProc) (struct Tcl_Obj *listPtr);
typedef int (Tcl_ObjTypeIndexProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr,
Tcl_Size index, struct Tcl_Obj** elemObj);
typedef int (Tcl_ObjTypeSliceProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr,
Tcl_Size fromIdx, Tcl_Size toIdx,
struct Tcl_Obj **newObjPtr);
typedef int (Tcl_ObjTypeReverseProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr,
struct Tcl_Obj **newObjPtr);
typedef int (Tcl_ObjTypeGetElements) (Tcl_Interp *interp, struct Tcl_Obj *listPtr,
Tcl_Size *objcptr, struct Tcl_Obj ***objvptr);
typedef struct Tcl_Obj* (Tcl_ObjTypeSetElement) (Tcl_Interp *interp, struct Tcl_Obj *listPtr,
Tcl_Size indexCount,
struct Tcl_Obj *const indexArray[],
struct Tcl_Obj *valueObj);
typedef int (Tcl_ObjTypeReplaceProc) (Tcl_Interp *interp, struct Tcl_Obj *listObj,
Tcl_Size first, Tcl_Size numToDelete,
Tcl_Size numToInsert,
struct Tcl_Obj *const insertObjs[]);
#ifndef TCL_NO_DEPRECATED
# define Tcl_PackageInitProc Tcl_LibraryInitProc
# define Tcl_PackageUnloadProc Tcl_LibraryUnloadProc
#endif
/*
*----------------------------------------------------------------------------
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 604 605 |
Tcl_UpdateStringProc *updateStringProc;
/* Called to update the string rep from the
* type's internal representation. */
Tcl_SetFromAnyProc *setFromAnyProc;
/* Called to convert the object's internal rep
* to this type. Frees the internal rep of the
* old type. Returns TCL_ERROR on failure. */
size_t version;
} Tcl_ObjType;
| > > > > > > > > > > > > > > > > > > > | < < > | > > > > > > | 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 |
Tcl_UpdateStringProc *updateStringProc;
/* Called to update the string rep from the
* type's internal representation. */
Tcl_SetFromAnyProc *setFromAnyProc;
/* Called to convert the object's internal rep
* to this type. Frees the internal rep of the
* old type. Returns TCL_ERROR on failure. */
#if TCL_MAJOR_VERSION > 8
size_t version;
/* List emulation functions - ObjType Version 1 */
Tcl_ObjTypeLengthProc *lengthProc; /* Return the [llength] of the
** AbstractList */
Tcl_ObjTypeIndexProc *indexProc; /* Return a value (Tcl_Obj) for
** [lindex $al $index] */
Tcl_ObjTypeSliceProc *sliceProc; /* Return an AbstractList for
** [lrange $al $start $end] */
Tcl_ObjTypeReverseProc *reverseProc; /* Return an AbstractList for
** [lreverse $al] */
Tcl_ObjTypeGetElements *getElementsProc; /* Return an objv[] of all elements in
** the list */
Tcl_ObjTypeSetElement *setElementProc; /* Replace the element at the indicie
** with the given valueObj. */
Tcl_ObjTypeReplaceProc *replaceProc; /* Replace subset with subset */
#endif
} Tcl_ObjType;
#if TCL_MAJOR_VERSION > 8
# define TCL_OBJTYPE_V0 0, \
0,0,0,0,0,0,0 /* Pre-Tcl 9 */
# define TCL_OBJTYPE_V1(a) 1, \
a,0,0,0,0,0,0 /* Tcl 9 Version 1 */
# define TCL_OBJTYPE_V2(a,b,c,d,e,f,g) 2, \
a,b,c,d,e,f,g /* Tcl 9 - AbstractLists */
#else
# define TCL_OBJTYPE_V0 /* just empty */
#endif
/*
* The following structure stores an internal representation (internalrep) for
* a Tcl value. An internalrep is associated with an Tcl_ObjType when both
* are stored in the same Tcl_Obj. The routines of the Tcl_ObjType govern
* the handling of the internalrep.
*/
|
| ︙ | ︙ | |||
655 656 657 658 659 660 661 |
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_ObjInternalRep internalRep; /* The internal representation: */
} Tcl_Obj;
| < | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 |
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_ObjInternalRep internalRep; /* The internal representation: */
} Tcl_Obj;
/*
*----------------------------------------------------------------------------
* The following definitions support Tcl's namespace facility. Note: the first
* five fields must match exactly the fields in a Namespace structure (see
* tclInt.h).
*/
|
| ︙ | ︙ | |||
2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 |
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
# undef Tcl_IncrRefCount
# define Tcl_IncrRefCount(objPtr) \
++(objPtr)->refCount
/*
* Use do/while0 idiom for optimum correctness without compiler warnings.
* https://wiki.c2.com/?TrivialDoWhileLoop
*/
# undef Tcl_DecrRefCount
# define Tcl_DecrRefCount(objPtr) \
do { \
Tcl_Obj *_objPtr = (objPtr); \
if (_objPtr->refCount-- <= 1) { \
TclFreeObj(_objPtr); \
} \
} while(0)
# undef Tcl_IsShared
# 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
* debugging versions of the object creation functions.
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 |
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__)
/*
* Free the Obj by effectively doing:
*
* Tcl_IncrRefCount(objPtr);
* Tcl_DecrRefCount(objPtr);
*
* This will free the obj if there are no references to the obj.
*/
# define Tcl_BumpObj(objPtr) \
TclBumpObj(objPtr, __FILE__, __LINE__)
static inline void TclBumpObj(Tcl_Obj* objPtr, const char* fn, int line)
{
if (objPtr) {
if ((objPtr)->refCount == 0) {
Tcl_DbDecrRefCount(objPtr, fn, line);
}
}
}
#else
# undef Tcl_IncrRefCount
# define Tcl_IncrRefCount(objPtr) \
++(objPtr)->refCount
/*
* Use do/while0 idiom for optimum correctness without compiler warnings.
* https://wiki.c2.com/?TrivialDoWhileLoop
*/
# undef Tcl_DecrRefCount
# define Tcl_DecrRefCount(objPtr) \
do { \
Tcl_Obj *_objPtr = (objPtr); \
if (_objPtr->refCount-- <= 1) { \
TclFreeObj(_objPtr); \
} \
} while(0)
# undef Tcl_IsShared
# define Tcl_IsShared(objPtr) \
((objPtr)->refCount > 1)
/*
* Declare that obj will no longer be used or referenced.
* This will release the obj if there is no referece count,
* otherwise let it be.
*/
# define Tcl_BumpObj(objPtr) \
TclBumpObj(objPtr);
static inline void TclBumpObj(Tcl_Obj* objPtr)
{
if (objPtr) {
if ((objPtr)->refCount == 0) {
Tcl_DecrRefCount(objPtr);
}
}
}
#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
* debugging versions of the object creation functions.
*/
|
| ︙ | ︙ |
Changes to generic/tclArithSeries.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclArithSeries.c -- * * This file contains the ArithSeries concrete abstract list * implementation. It implements the inner workings of the lseq command. * * Copyright © 2022 Brian S. Griffin. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
/*
* tclArithSeries.c --
*
* This file contains the ArithSeries concrete abstract list
* implementation. It implements the inner workings of the lseq command.
*
* Copyright © 2022 Brian S. Griffin.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tcl.h"
#include "tclInt.h"
#include <assert.h>
#include <math.h>
/*
* The structure below defines the arithmetic series Tcl object type by
* means of procedures that can be invoked by generic object code.
*
* The arithmetic series object is a special case of Tcl list representing
* an interval of an arithmetic series in constant space.
*
* The arithmetic series is internally represented with three integers,
* *start*, *end*, and *step*, Where the length is calculated with
* the following algorithm:
*
* if RANGE == 0 THEN
* ERROR
* if RANGE > 0
* LEN is (((END-START)-1)/STEP) + 1
* else if RANGE < 0
* LEN is (((END-START)-1)/STEP) - 1
*
* And where the equivalent's list I-th element is calculated
* as:
*
* LIST[i] = START + (STEP * i)
*
* Zero elements ranges, like in the case of START=10 END=10 STEP=1
* are valid and will be equivalent to the empty list.
*/
/*
* The structure used for the ArithSeries internal representation.
* Note that the len can in theory be always computed by start,end,step
* but it's faster to cache it inside the internal representation.
*/
typedef struct {
Tcl_Size len;
Tcl_Obj **elements;
int isDouble;
Tcl_WideInt start;
Tcl_WideInt end;
Tcl_WideInt step;
} ArithSeries;
typedef struct {
Tcl_Size len;
Tcl_Obj **elements;
int isDouble;
double start;
double end;
double step;
int precision;
} ArithSeriesDbl;
/* -------------------------- ArithSeries object ---------------------------- */
static int TclArithSeriesObjIndex(TCL_UNUSED(Tcl_Interp *), Tcl_Obj *arithSeriesObj,
Tcl_Size index, Tcl_Obj **elemObj);
static Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj);
static int TclArithSeriesObjRange(Tcl_Interp *interp, Tcl_Obj *arithSeriesObj,
Tcl_Size fromIdx, Tcl_Size toIdx, Tcl_Obj **newObjPtr);
static int TclArithSeriesObjReverse(Tcl_Interp *interp, Tcl_Obj *arithSeriesObj, Tcl_Obj **newObjPtr);
static int TclArithSeriesGetElements(Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr);
static void DupArithSeriesInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr);
static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr);
static int SetArithSeriesFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static const Tcl_ObjType arithSeriesType = {
"arithseries", /* name */
FreeArithSeriesInternalRep, /* freeIntRepProc */
DupArithSeriesInternalRep, /* dupIntRepProc */
UpdateStringOfArithSeries, /* updateStringProc */
SetArithSeriesFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V2(
ArithSeriesObjLength,
TclArithSeriesObjIndex,
TclArithSeriesObjRange,
TclArithSeriesObjReverse,
TclArithSeriesGetElements,
NULL, // SetElement
NULL) // Replace
};
/*
* Helper functions
*
* - ArithRound -- Round doubles to the number of significant fractional
* digits
* - ArithSeriesIndexDbl -- base list indexing operation for doubles
|
| ︙ | ︙ | |||
64 65 66 67 68 69 70 |
}
}
static inline ArithSeries*
ArithSeriesGetInternalRep(Tcl_Obj *objPtr)
{
const Tcl_ObjInternalRep *irPtr;
| | > > > > > > > < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 |
}
}
static inline ArithSeries*
ArithSeriesGetInternalRep(Tcl_Obj *objPtr)
{
const Tcl_ObjInternalRep *irPtr;
irPtr = TclFetchInternalRep((objPtr), &arithSeriesType);
return irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL;
}
/*
* Compute number of significant factional digits
*/
static inline int
Precision(double d)
{
char tmp[TCL_DOUBLE_SPACE+2], *off;
tmp[0] = 0;
Tcl_PrintDouble(NULL,d,tmp);
off = strchr(tmp, '.');
return (off ? strlen(off+1) : 0);
}
/*
* Find longest number of digits after the decimal point.
*/
static inline int
maxPrecision(double start, double end, double step)
{
int dp = Precision(step);
int i = Precision(start);
dp = i>dp ? i : dp;
i = Precision(end);
dp = i>dp ? i : dp;
return dp;
}
static int TclArithSeriesObjStep(Tcl_Obj *arithSeriesObj, Tcl_Obj **stepObj);
/*
*----------------------------------------------------------------------
*
* ArithSeriesLen --
*
* Compute the length of the equivalent list where
|
| ︙ | ︙ | |||
174 175 176 177 178 179 180 |
return 0;
}
len = 1 + ((end-start)/step);
return (len < 0) ? -1 : len;
}
static Tcl_WideInt
| | < | > > > > > > | | > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 |
return 0;
}
len = 1 + ((end-start)/step);
return (len < 0) ? -1 : len;
}
static Tcl_WideInt
ArithSeriesLenDbl(double start, double end, double step, int precision)
{
double istart, iend, istep, ilen;
if (step == 0) {
return 0;
}
istart = start * pow(10,precision);
iend = end * pow(10,precision);
istep = step * pow(10,precision);
ilen = ((iend-istart+istep)/istep);
return floor(ilen);
}
/*
*----------------------------------------------------------------------
*
* DupArithSeriesInternalRep --
*
* Initialize the internal representation of a arithseries Tcl_Obj to a
* copy of the internal representation of an existing arithseries object.
*
* Results:
* None.
*
* Side effects:
* We set "copyPtr"s internal rep to a pointer to a
* newly allocated ArithSeries structure.
*----------------------------------------------------------------------
*/
static void
DupArithSeriesInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
ArithSeries *srcArithSeriesRepPtr =
(ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1;
/*
* Allocate a new ArithSeries structure. */
if (srcArithSeriesRepPtr->isDouble) {
ArithSeriesDbl *srcArithSeriesDblRepPtr =
(ArithSeriesDbl *)srcArithSeriesRepPtr;
ArithSeriesDbl *copyArithSeriesDblRepPtr =
(ArithSeriesDbl *) Tcl_Alloc(sizeof(ArithSeriesDbl));
*copyArithSeriesDblRepPtr = *srcArithSeriesDblRepPtr;
copyArithSeriesDblRepPtr->elements = NULL;
copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesDblRepPtr;
} else {
ArithSeries *copyArithSeriesRepPtr =
(ArithSeries *) Tcl_Alloc(sizeof(ArithSeries));
*copyArithSeriesRepPtr = *srcArithSeriesRepPtr;
copyArithSeriesRepPtr->elements = NULL;
copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr;
}
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
copyPtr->typePtr = &arithSeriesType;
}
/*
*----------------------------------------------------------------------
*
* FreeArithSeriesInternalRep --
*
* Free any allocated memory in the ArithSeries Rep
*
* Results:
* None.
*
* Side effects:
*
*----------------------------------------------------------------------
*/
static void
FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr) /* Free any allocated memory */
{
ArithSeries *arithSeriesRepPtr = (ArithSeries*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1;
if (arithSeriesRepPtr) {
if (arithSeriesRepPtr->elements) {
Tcl_WideInt i, len = arithSeriesRepPtr->len;
for (i=0; i<len; i++) {
Tcl_DecrRefCount(arithSeriesRepPtr->elements[i]);
}
Tcl_Free((char*)arithSeriesRepPtr->elements);
arithSeriesRepPtr->elements = NULL;
}
Tcl_Free((char*)arithSeriesRepPtr);
}
}
/*
*----------------------------------------------------------------------
*
* NewArithSeriesInt --
*
* Creates a new ArithSeries object. The returned object has
|
| ︙ | ︙ | |||
229 230 231 232 233 234 235 |
arithSeriesRepPtr->start = start;
arithSeriesRepPtr->end = end;
arithSeriesRepPtr->step = step;
arithSeriesRepPtr->len = length;
arithSeriesRepPtr->elements = NULL;
arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
| | | 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 |
arithSeriesRepPtr->start = start;
arithSeriesRepPtr->end = end;
arithSeriesRepPtr->step = step;
arithSeriesRepPtr->len = length;
arithSeriesRepPtr->elements = NULL;
arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
arithSeriesObj->typePtr = &arithSeriesType;
if (length > 0)
Tcl_InvalidateStringRep(arithSeriesObj);
return arithSeriesObj;
}
/*
|
| ︙ | ︙ | |||
284 285 286 287 288 289 290 |
arithSeriesRepPtr->end = end;
arithSeriesRepPtr->step = step;
arithSeriesRepPtr->len = length;
arithSeriesRepPtr->elements = NULL;
arithSeriesRepPtr->precision = maxPrecision(start,end,step);
arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
| | | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 |
arithSeriesRepPtr->end = end;
arithSeriesRepPtr->step = step;
arithSeriesRepPtr->len = length;
arithSeriesRepPtr->elements = NULL;
arithSeriesRepPtr->precision = maxPrecision(start,end,step);
arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
arithSeriesObj->typePtr = &arithSeriesType;
if (length > 0) {
Tcl_InvalidateStringRep(arithSeriesObj);
}
return arithSeriesObj;
}
|
| ︙ | ︙ | |||
416 417 418 419 420 421 422 |
step = (start < end) ? 1 : -1;
dstep = step;
}
}
assert(dstep!=0);
if (!lenObj) {
if (useDoubles) {
| > | | 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 |
step = (start < end) ? 1 : -1;
dstep = step;
}
}
assert(dstep!=0);
if (!lenObj) {
if (useDoubles) {
int precision = maxPrecision(dstart,dend,dstep);
len = ArithSeriesLenDbl(dstart, dend, dstep, precision);
} else {
len = ArithSeriesLenInt(start, end, step);
}
}
}
if (!endObj) {
|
| ︙ | ︙ | |||
452 453 454 455 456 457 458 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > | < > | | | > | < < < < | | | | | | | | | > > > | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclArithSeriesObjIndex --
*
* Returns the element with the specified index in the list
* represented by the specified Arithmetic Sequence object.
* If the index is out of range, TCL_ERROR is returned,
* otherwise TCL_OK is returned and the integer value of the
* element is stored in *element.
*
* Results:
*
* TCL_OK on success, TCL_ERROR on index out of range.
*
* Side Effects:
*
* On success, the integer pointed by *element is modified.
*
*----------------------------------------------------------------------
*/
int
TclArithSeriesObjIndex(
TCL_UNUSED(Tcl_Interp *),/* Used for error reporting if not NULL. */
Tcl_Obj *arithSeriesObj, /* List obj */
Tcl_Size index, /* index to element of interest */
Tcl_Obj **elemObj) /* Return value */
{
ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
if (index < 0 || arithSeriesRepPtr->len <= index) {
*elemObj = Tcl_NewObj();
} else {
/* List[i] = Start + (Step * index) */
if (arithSeriesRepPtr->isDouble) {
*elemObj = Tcl_NewDoubleObj(ArithSeriesIndexDbl(arithSeriesRepPtr, index));
} else {
*elemObj = Tcl_NewWideIntObj(ArithSeriesIndexInt(arithSeriesRepPtr, index));
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ArithSeriesObjLength
*
|
| ︙ | ︙ | |||
553 554 555 556 557 558 559 |
*/
Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj)
{
ArithSeries *arithSeriesRepPtr = (ArithSeries*)
arithSeriesObj->internalRep.twoPtrValue.ptr1;
return arithSeriesRepPtr->len;
}
| | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < < | < < | < < < < < < < < < | < < < < < < < < | < < < < < < < < < | < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < | < > | | < < < < < < < < < < | < < < | | < < < | < < | < | < < < | < < > | 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 |
*/
Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj)
{
ArithSeries *arithSeriesRepPtr = (ArithSeries*)
arithSeriesObj->internalRep.twoPtrValue.ptr1;
return arithSeriesRepPtr->len;
}
/*
*----------------------------------------------------------------------
*
* TclArithSeriesObjStep --
*
* Return a Tcl_Obj with the step value from the give ArithSeries Obj.
* refcount = 0.
*
* Results:
*
* A Tcl_Obj pointer to the created ArithSeries object.
* A NULL pointer of the range is invalid.
*
* Side Effects:
*
* None.
*----------------------------------------------------------------------
*/
int
TclArithSeriesObjStep(
Tcl_Obj *arithSeriesObj,
Tcl_Obj **stepObj)
{
ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
if (arithSeriesRepPtr->isDouble) {
*stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step);
} else {
*stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SetArithSeriesFromAny --
*
|
| ︙ | ︙ | |||
772 773 774 775 776 777 778 | * Side effects: * ?The possible conversion of the object referenced by listPtr? * ?to a list object.? * *---------------------------------------------------------------------- */ | < > | > > > > > > > | < < | | | < < < | < < < | < | | < < | | | 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 |
* Side effects:
* ?The possible conversion of the object referenced by listPtr?
* ?to a list object.?
*
*----------------------------------------------------------------------
*/
int
TclArithSeriesObjRange(
Tcl_Interp *interp, /* For error message(s) */
Tcl_Obj *arithSeriesObj, /* List object to take a range from. */
Tcl_Size fromIdx, /* Index of first element to include. */
Tcl_Size toIdx, /* Index of last element to include. */
Tcl_Obj **newObjPtr) /* return value */
{
ArithSeries *arithSeriesRepPtr;
Tcl_Obj *startObj, *endObj, *stepObj;
(void)interp; /* silence compiler */
arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = 0;
}
if (toIdx >= arithSeriesRepPtr->len) {
toIdx = arithSeriesRepPtr->len-1;
}
if (fromIdx > toIdx ||
fromIdx >= arithSeriesRepPtr->len) {
TclNewObj(*newObjPtr);
return TCL_OK;
}
if (fromIdx < 0) {
fromIdx = 0;
}
if (toIdx < 0) {
toIdx = 0;
}
if (toIdx > arithSeriesRepPtr->len-1) {
toIdx = arithSeriesRepPtr->len-1;
}
TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj);
Tcl_IncrRefCount(startObj);
TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx, &endObj);
Tcl_IncrRefCount(endObj);
TclArithSeriesObjStep(arithSeriesObj, &stepObj);
Tcl_IncrRefCount(stepObj);
if (Tcl_IsShared(arithSeriesObj) ||
((arithSeriesObj->refCount > 1))) {
int status = TclNewArithSeriesObj(NULL, newObjPtr,
arithSeriesRepPtr->isDouble, startObj, endObj, stepObj, NULL);
Tcl_DecrRefCount(startObj);
Tcl_DecrRefCount(endObj);
Tcl_DecrRefCount(stepObj);
return status;
}
/*
* In-place is possible.
*/
/*
|
| ︙ | ︙ | |||
855 856 857 858 859 860 861 | Tcl_GetDoubleFromObj(NULL, startObj, &start); Tcl_GetDoubleFromObj(NULL, endObj, &end); Tcl_GetDoubleFromObj(NULL, stepObj, &step); arithSeriesDblRepPtr->start = start; arithSeriesDblRepPtr->end = end; arithSeriesDblRepPtr->step = step; arithSeriesDblRepPtr->precision = maxPrecision(start, end, step); | | > | > | 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 |
Tcl_GetDoubleFromObj(NULL, startObj, &start);
Tcl_GetDoubleFromObj(NULL, endObj, &end);
Tcl_GetDoubleFromObj(NULL, stepObj, &step);
arithSeriesDblRepPtr->start = start;
arithSeriesDblRepPtr->end = end;
arithSeriesDblRepPtr->step = step;
arithSeriesDblRepPtr->precision = maxPrecision(start, end, step);
arithSeriesDblRepPtr->len =
ArithSeriesLenDbl(start, end, step, arithSeriesDblRepPtr->precision);
arithSeriesDblRepPtr->elements = NULL;
} else {
Tcl_WideInt start, end, step;
Tcl_GetWideIntFromObj(NULL, startObj, &start);
Tcl_GetWideIntFromObj(NULL, endObj, &end);
Tcl_GetWideIntFromObj(NULL, stepObj, &step);
arithSeriesRepPtr->start = start;
arithSeriesRepPtr->end = end;
arithSeriesRepPtr->step = step;
arithSeriesRepPtr->len = ArithSeriesLenInt(start, end, step);
arithSeriesRepPtr->elements = NULL;
}
Tcl_DecrRefCount(startObj);
Tcl_DecrRefCount(endObj);
Tcl_DecrRefCount(stepObj);
*newObjPtr = arithSeriesObj;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclArithSeriesGetElements --
*
|
| ︙ | ︙ | |||
916 917 918 919 920 921 922 |
Tcl_Obj *objPtr, /* ArithSeries object for which an element
* array is to be returned. */
Tcl_Size *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. */
{
| | > | | | 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 |
Tcl_Obj *objPtr, /* ArithSeries object for which an element
* array is to be returned. */
Tcl_Size *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. */
{
if (TclHasInternalRep(objPtr,&arithSeriesType)) {
ArithSeries *arithSeriesRepPtr;
Tcl_Obj **objv;
int i, objc;
arithSeriesRepPtr = ArithSeriesGetInternalRep(objPtr);
objc = arithSeriesRepPtr->len;
if (objc > 0) {
if (arithSeriesRepPtr->elements) {
/* If this exists, it has already been populated */
objv = arithSeriesRepPtr->elements;
} else {
/* Construct the elements array */
objv = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * objc);
if (objv == NULL) {
if (interp) {
Tcl_SetObjResult(
interp,
Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
}
arithSeriesRepPtr->elements = objv;
for (i = 0; i < objc; i++) {
int status = TclArithSeriesObjIndex(interp, objPtr, i, &objv[i]);
if (status) {
return TCL_ERROR;
}
Tcl_IncrRefCount(objv[i]);
}
}
} else {
objv = NULL;
|
| ︙ | ︙ | |||
970 971 972 973 974 975 976 | } /* *---------------------------------------------------------------------- * * TclArithSeriesObjReverse -- * | | | > < | | < | < | > > > > > > > | | | | | | 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 |
}
/*
*----------------------------------------------------------------------
*
* TclArithSeriesObjReverse --
*
* Reverse the order of the ArithSeries value. The arithSeriesObj is
* assumed to be a valid ArithSeries. The new Obj has the Start and End
* values appropriately swapped and the Step value sign is changed.
*
* Results:
* The result will be an ArithSeries in the reverse order.
*
* Side effects:
* The ogiginal obj will be modified and returned if it is not Shared.
*
*----------------------------------------------------------------------
*/
int
TclArithSeriesObjReverse(
Tcl_Interp *interp, /* For error message(s) */
Tcl_Obj *arithSeriesObj, /* List object to reverse. */
Tcl_Obj **newObjPtr)
{
ArithSeries *arithSeriesRepPtr;
Tcl_Obj *startObj, *endObj, *stepObj;
Tcl_Obj *resultObj;
Tcl_WideInt start, end, step, len;
double dstart, dend, dstep;
int isDouble;
(void)interp;
if (newObjPtr == NULL) {
return TCL_ERROR;
}
arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
isDouble = arithSeriesRepPtr->isDouble;
len = arithSeriesRepPtr->len;
TclArithSeriesObjIndex(NULL, arithSeriesObj, (len-1), &startObj);
Tcl_IncrRefCount(startObj);
TclArithSeriesObjIndex(NULL, arithSeriesObj, 0, &endObj);
Tcl_IncrRefCount(endObj);
TclArithSeriesObjStep(arithSeriesObj, &stepObj);
Tcl_IncrRefCount(stepObj);
if (isDouble) {
Tcl_GetDoubleFromObj(NULL, startObj, &dstart);
Tcl_GetDoubleFromObj(NULL, endObj, &dend);
Tcl_GetDoubleFromObj(NULL, stepObj, &dstep);
dstep = -dstep;
TclSetDoubleObj(stepObj, dstep);
} else {
Tcl_GetWideIntFromObj(NULL, startObj, &start);
Tcl_GetWideIntFromObj(NULL, endObj, &end);
Tcl_GetWideIntFromObj(NULL, stepObj, &step);
step = -step;
TclSetIntObj(stepObj, step);
}
if (Tcl_IsShared(arithSeriesObj) ||
((arithSeriesObj->refCount > 1))) {
Tcl_Obj *lenObj;
TclNewIntObj(lenObj, len);
if (TclNewArithSeriesObj(NULL, &resultObj, isDouble,
startObj, endObj, stepObj, lenObj) != TCL_OK) {
resultObj = NULL;
}
Tcl_DecrRefCount(lenObj);
} else {
/*
* In-place is possible.
|
| ︙ | ︙ | |||
1066 1067 1068 1069 1070 1071 1072 |
resultObj = arithSeriesObj;
}
Tcl_DecrRefCount(startObj);
Tcl_DecrRefCount(endObj);
Tcl_DecrRefCount(stepObj);
| > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 |
resultObj = arithSeriesObj;
}
Tcl_DecrRefCount(startObj);
Tcl_DecrRefCount(endObj);
Tcl_DecrRefCount(stepObj);
*newObjPtr = resultObj;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfArithSeries --
*
* Update the string representation for an arithseries 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 list-to-string conversion. This string will be empty if the
* list has no elements. The list internal representation
* should not be NULL and we assume it is not NULL.
*
* Notes:
* At the cost of overallocation it's possible to estimate
* the length of the string representation and make this procedure
* much faster. Because the programmer shouldn't expect the
* string conversion of a big arithmetic sequence to be fast
* this version takes more care of space than time.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr)
{
ArithSeries *arithSeriesRepPtr = (ArithSeries*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1;
char *p;
Tcl_Obj *eleObj;
Tcl_Size i, bytlen = 0;
/*
* Pass 1: estimate space.
*/
if (!arithSeriesRepPtr->isDouble) {
for (i = 0; i < arithSeriesRepPtr->len; i++) {
double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i);
size_t slen = d>0 ? log10(d)+1 : d<0 ? log10((0-d))+2 : 1;
bytlen += slen;
}
} else {
for (i = 0; i < arithSeriesRepPtr->len; i++) {
double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i);
char tmp[TCL_DOUBLE_SPACE+2];
tmp[0] = 0;
Tcl_PrintDouble(NULL,d,tmp);
if ((bytlen + strlen(tmp)) > TCL_SIZE_MAX) {
break; // overflow
}
bytlen += strlen(tmp);
}
}
bytlen += arithSeriesRepPtr->len; // Space for each separator
/*
* Pass 2: generate the string repr.
*/
p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, bytlen);
for (i = 0; i < arithSeriesRepPtr->len; i++) {
if (TclArithSeriesObjIndex(NULL, arithSeriesObjPtr, i, &eleObj) == TCL_OK) {
Tcl_Size slen;
char *str = Tcl_GetStringFromObj(eleObj, &slen);
strcpy(p, str);
p[slen] = ' ';
p += slen+1;
Tcl_DecrRefCount(eleObj);
} // else TODO: report error here?
}
if (bytlen > 0) arithSeriesObjPtr->bytes[bytlen-1] = '\0';
arithSeriesObjPtr->length = bytlen-1;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Deleted generic/tclArithSeries.h.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to generic/tclBasic.c.
| ︙ | ︙ | |||
6148 6149 6150 6151 6152 6153 6154 | * both listPtr and objPtr. * * TODO: Create a test to demo this need, or eliminate it. * FIXME OPT: preserve just the internal rep? */ Tcl_IncrRefCount(objPtr); | | | 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 |
* both listPtr and objPtr.
*
* TODO: Create a test to demo this need, or eliminate it.
* FIXME OPT: preserve just the internal rep?
*/
Tcl_IncrRefCount(objPtr);
listPtr = TclDuplicatePureObj(interp, objPtr, &tclListType);
if (!listPtr) {
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
Tcl_IncrRefCount(listPtr);
if (word != INT_MIN) {
|
| ︙ | ︙ | |||
7046 7047 7048 7049 7050 7051 7052 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
| | | 7046 7047 7048 7049 7050 7051 7052 7053 7054 7055 7056 7057 7058 7059 7060 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
}
#endif
|
| ︙ | ︙ | |||
7086 7087 7088 7089 7090 7091 7092 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
| | | 7086 7087 7088 7089 7090 7091 7092 7093 7094 7095 7096 7097 7098 7099 7100 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
}
#endif
|
| ︙ | ︙ | |||
7232 7233 7234 7235 7236 7237 7238 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
| | | 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
}
#endif
|
| ︙ | ︙ | |||
7286 7287 7288 7289 7290 7291 7292 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
| | | 7286 7287 7288 7289 7290 7291 7292 7293 7294 7295 7296 7297 7298 7299 7300 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
d = irPtr->doubleValue;
Tcl_ResetResult(interp);
code = TCL_OK;
}
}
|
| ︙ | ︙ | |||
7350 7351 7352 7353 7354 7355 7356 |
if (objc != 3) {
MathFuncWrongNumArgs(interp, 3, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
| | | | 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 |
if (objc != 3) {
MathFuncWrongNumArgs(interp, 3, objc, objv);
return TCL_ERROR;
}
code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
d1 = irPtr->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_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
d2 = irPtr->doubleValue;
Tcl_ResetResult(interp);
code = TCL_OK;
}
}
|
| ︙ | ︙ | |||
7526 7527 7528 7529 7530 7531 7532 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
| | | 7526 7527 7528 7529 7530 7531 7532 7533 7534 7535 7536 7537 7538 7539 7540 |
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
if (TclHasInternalRep(objv[1], &tclDoubleType)) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
#endif
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
|
| ︙ | ︙ |
Changes to generic/tclBinary.c.
| ︙ | ︙ | |||
1997 1998 1999 2000 2001 2002 2003 |
/*
* Double-precision floating point values. Tcl_GetDoubleFromObj
* returns TCL_ERROR for NaN, but we can check by comparing the
* object's type pointer.
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
| | | | 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 |
/*
* Double-precision floating point values. Tcl_GetDoubleFromObj
* 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_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType);
if (irPtr == NULL) {
return TCL_ERROR;
}
dvalue = irPtr->doubleValue;
}
CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
*cursorPtr += sizeof(double);
return TCL_OK;
case 'f':
case 'r':
case 'R':
/*
* Single-precision floating point values. Tcl_GetDoubleFromObj
* 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_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType);
if (irPtr == NULL) {
return TCL_ERROR;
}
dvalue = irPtr->doubleValue;
}
|
| ︙ | ︙ |
Changes to generic/tclClock.c.
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
}
/*
* fields.seconds could be an unsigned number that overflowed. Make sure
* that it isn't.
*/
| | | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 |
}
/*
* fields.seconds could be an unsigned number that overflowed. Make sure
* that it isn't.
*/
if (TclHasInternalRep(objv[1], &tclBignumType)) {
Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]);
return TCL_ERROR;
}
/*
* Convert UTC time to local.
*/
|
| ︙ | ︙ |
Changes to generic/tclCmdAH.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | #include "tclInt.h" #include "tclIO.h" #include "tclTomMath.h" #ifdef _WIN32 # include "tclWinInt.h" #endif | < | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | #include "tclInt.h" #include "tclIO.h" #include "tclTomMath.h" #ifdef _WIN32 # include "tclWinInt.h" #endif /* * The state structure used by [foreach]. Note that the actual structure has * all its working arrays appended afterwards so they can be allocated and * freed in a single step. */ |
| ︙ | ︙ | |||
548 549 550 551 552 553 554 |
return TCL_ERROR;
}
result = Tcl_ExternalToUtfDStringEx(interp, encoding, bytesPtr, length, flags,
&ds, failVarObj ? &errorLocation : NULL);
/* NOTE: ds must be freed beyond this point even on error */
switch (result) {
case TCL_OK:
| | | | | | | 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 |
return TCL_ERROR;
}
result = Tcl_ExternalToUtfDStringEx(interp, encoding, bytesPtr, length, flags,
&ds, failVarObj ? &errorLocation : NULL);
/* NOTE: ds must be freed beyond this point even on error */
switch (result) {
case TCL_OK:
errorLocation = TCL_INDEX_NONE;
break;
case TCL_ERROR:
/* Error in parameters. Should not happen. interp will have error */
Tcl_DStringFree(&ds);
return TCL_ERROR;
default:
/*
* One of the TCL_CONVERT_* errors. If we were not interested in the
* error location, interp result would already have been filled in
* and we can just return the error. Otherwise, we have to return
* what could be decoded and the returned error location.
*/
if (failVarObj == NULL) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
break;
}
/*
* TCL_OK or a TCL_CONVERT_* error where the caller wants back as much
* data as was converted.
*/
if (failVarObj) {
|
| ︙ | ︙ | |||
650 651 652 653 654 655 656 |
switch (result) {
case TCL_OK:
errorLocation = TCL_INDEX_NONE;
break;
case TCL_ERROR:
/* Error in parameters. Should not happen. interp will have error */
| | | | | 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 |
switch (result) {
case TCL_OK:
errorLocation = TCL_INDEX_NONE;
break;
case TCL_ERROR:
/* Error in parameters. Should not happen. interp will have error */
Tcl_DStringFree(&ds);
return TCL_ERROR;
default:
/*
* One of the TCL_CONVERT_* errors. If we were not interested in the
* error location, interp result would already have been filled in
* and we can just return the error. Otherwise, we have to return
* what could be decoded and the returned error location.
*/
if (failVarObj == NULL) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
break;
}
/*
* TCL_OK or a TCL_CONVERT_* error where the caller wants back as much
* data as was converted.
*/
if (failVarObj) {
Tcl_Obj *failIndex;
|
| ︙ | ︙ | |||
1196 1197 1198 1199 1200 1201 1202 |
}
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 (Tcl_GetAccessTimeFromStat(&buf) == 0) {
| | | | | | 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 |
}
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 (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]
|
| ︙ | ︙ | |||
1278 1279 1280 1281 1282 1283 1284 |
}
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 (Tcl_GetModificationTimeFromStat(&buf) == 0) {
| | | | | | 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 |
}
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 (Tcl_GetModificationTimeFromStat(&buf) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not get modification 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]
*/
|
| ︙ | ︙ | |||
2321 2322 2323 2324 2325 2326 2327 |
Tcl_StatBuf *statPtr) /* Pointer to buffer containing stat data to
* store in varName. */
{
Tcl_Obj *field, *value, *result;
unsigned short mode;
if (varName == NULL) {
| | | | | | | | | | | | | | | | | | | | | 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 |
Tcl_StatBuf *statPtr) /* Pointer to buffer containing stat data to
* store in varName. */
{
Tcl_Obj *field, *value, *result;
unsigned short mode;
if (varName == NULL) {
TclNewObj(result);
Tcl_IncrRefCount(result);
#define DOBJPUT(key, objValue) \
Tcl_DictObjPut(NULL, result, \
Tcl_NewStringObj((key), -1), \
(objValue));
DOBJPUT("dev", Tcl_NewWideIntObj((long)statPtr->st_dev));
DOBJPUT("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
DOBJPUT("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink));
DOBJPUT("uid", Tcl_NewWideIntObj((long)statPtr->st_uid));
DOBJPUT("gid", Tcl_NewWideIntObj((long)statPtr->st_gid));
DOBJPUT("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
DOBJPUT("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
DOBJPUT("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
#endif
DOBJPUT("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr)));
DOBJPUT("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr)));
DOBJPUT("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr)));
mode = (unsigned short) statPtr->st_mode;
DOBJPUT("mode", Tcl_NewWideIntObj(mode));
DOBJPUT("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
#undef DOBJPUT
Tcl_SetObjResult(interp, result);
Tcl_DecrRefCount(result);
return TCL_OK;
}
/*
* Might be a better idea to call Tcl_SetVar2Ex() instead, except we want
* to have an object (i.e. possibly cached) array variable name but a
* string element name, so no API exists. Messy.
*/
|
| ︙ | ︙ | |||
2784 2785 2786 2787 2788 2789 2790 |
/*
* Break up the value lists and variable lists into elements.
*/
for (i=0 ; i<numLists ; i++) {
/* List */
/* Variables */
| | < | 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 |
/*
* Break up the value lists and variable lists into elements.
*/
for (i=0 ; i<numLists ; i++) {
/* List */
/* Variables */
statePtr->vCopyList[i] = Tcl_DuplicateObj(objv[1+i*2]);
if (!statePtr->vCopyList[i]) {
result = TCL_ERROR;
goto done;
}
result = TclListObjLengthM(interp, statePtr->vCopyList[i],
&statePtr->varcList[i]);
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
2810 2811 2812 2813 2814 2815 2816 | result = TCL_ERROR; goto done; } TclListObjGetElementsM(NULL, statePtr->vCopyList[i], &statePtr->varcList[i], &statePtr->varvList[i]); /* Values */ | | | | < | | 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 |
result = TCL_ERROR;
goto done;
}
TclListObjGetElementsM(NULL, statePtr->vCopyList[i],
&statePtr->varcList[i], &statePtr->varvList[i]);
/* Values */
if (TclObjTypeHasProc(objv[2+i*2],indexProc)) {
/* Special case for AbstractList */
statePtr->aCopyList[i] = Tcl_DuplicateObj(objv[2+i*2]);
if (statePtr->aCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
/* Don't compute values here, wait until the last moment */
statePtr->argcList[i] = TclObjTypeLength(statePtr->aCopyList[i]);
} else {
statePtr->aCopyList[i] = TclDuplicatePureObj(
interp, objv[2+i*2], &tclListType);
if (!statePtr->aCopyList[i]) {
result = TCL_ERROR;
goto done;
}
result = TclListObjGetElementsM(interp, statePtr->aCopyList[i],
&statePtr->argcList[i], &statePtr->argvList[i]);
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
2960 2961 2962 2963 2964 2965 2966 |
struct ForeachState *statePtr)
{
int i;
Tcl_Size v, k;
Tcl_Obj *valuePtr, *varValuePtr;
for (i=0 ; i<statePtr->numLists ; i++) {
| > > | | | < | | | | 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 |
struct ForeachState *statePtr)
{
int i;
Tcl_Size v, k;
Tcl_Obj *valuePtr, *varValuePtr;
for (i=0 ; i<statePtr->numLists ; i++) {
int isAbstractList =
TclObjTypeHasProc(statePtr->aCopyList[i],indexProc) != NULL;
for (v=0 ; v<statePtr->varcList[i] ; v++) {
k = statePtr->index[i]++;
if (k < statePtr->argcList[i]) {
if (isAbstractList) {
if (TclObjTypeIndex(interp, statePtr->aCopyList[i], k, &valuePtr) != TCL_OK) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (setting %s loop variable \"%s\")",
(statePtr->resultList != NULL ? "lmap" : "foreach"),
TclGetString(statePtr->varvList[i][v])));
return TCL_ERROR;
}
} else {
valuePtr = statePtr->argvList[i][k];
}
} else {
TclNewObj(valuePtr); /* Empty string */
|
| ︙ | ︙ |
Changes to generic/tclCmdIL.c.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | * * 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 "tclRegexp.h" | < | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | * * 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 "tclRegexp.h" #include "tclTomMath.h" #include <math.h> #include <assert.h> /* * During execution of the "lsort" command, structures of the following type * are used to arrange the objects being sorted into a collection of linked |
| ︙ | ︙ | |||
2199 2200 2201 2202 2203 2204 2205 |
Tcl_JoinObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Size length, listLen;
| | | | | | | | > > > | > > > | | | < < < < | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < | < | 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 |
Tcl_JoinObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Size length, listLen;
int isAbstractList = 0;
Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
return TCL_ERROR;
}
/*
* Make sure the list argument is a list object and get its length and a
* pointer to its array of element pointers.
*/
if (TclObjTypeHasProc(objv[1], getElementsProc)) {
listLen = TclObjTypeLength(objv[1]);
isAbstractList = (listLen ? 1 : 0);
if (listLen > 1 &&
TclObjTypeGetElements(interp, objv[1], &listLen, &elemPtrs)
!= TCL_OK) {
return TCL_ERROR;
}
} else if (TclListObjGetElementsM(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 */
if (!isAbstractList) {
Tcl_SetObjResult(interp, elemPtrs[0]);
} else {
Tcl_Obj *elemObj;
if (TclObjTypeIndex(interp, objv[1], 0, &elemObj)
!= TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, elemObj);
}
return TCL_OK;
}
joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
Tcl_IncrRefCount(joinObjPtr);
(void) Tcl_GetStringFromObj(joinObjPtr, &length);
if (length == 0) {
resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
} else {
Tcl_Size 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;
}
|
| ︙ | ︙ | |||
2331 2332 2333 2334 2335 2336 2337 |
int code;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?");
return TCL_ERROR;
}
| | | 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 |
int code;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?");
return TCL_ERROR;
}
listCopyPtr = TclDuplicatePureObj(interp, objv[1], &tclListType);
if (!listCopyPtr) {
return TCL_ERROR;
}
Tcl_IncrRefCount(listCopyPtr); /* Important! fs */
code = TclListObjGetElementsM(
interp, listCopyPtr, &listObjc, &listObjv);
|
| ︙ | ︙ | |||
2501 2502 2503 2504 2505 2506 2507 |
/*
* If the list object is unshared we can modify it directly. Otherwise we
* create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
| | | 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 |
/*
* If the list object is unshared we can modify it directly. Otherwise we
* create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType);
if (!listPtr) {
return TCL_ERROR;
}
copied = 1;
}
if ((objc == 4) && (index == len)) {
|
| ︙ | ︙ | |||
2701 2702 2703 2704 2705 2706 2707 |
/*
* Second, remove the element.
* TclLsetFlat adds a ref count which is handled.
*/
if (objc == 2) {
if (Tcl_IsShared(listPtr)) {
| | | 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 |
/*
* Second, remove the element.
* TclLsetFlat adds a ref count which is handled.
*/
if (objc == 2) {
if (Tcl_IsShared(listPtr)) {
listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType);
if (!listPtr) {
return TCL_ERROR;
}
copied = 1;
}
result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL);
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
2784 2785 2786 2787 2788 2789 2790 |
result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
&last);
if (result != TCL_OK) {
return result;
}
| | | | | | | 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 |
result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1,
&last);
if (result != TCL_OK) {
return result;
}
if (TclObjTypeHasProc(objv[1], sliceProc)) {
Tcl_Obj *resultObj;
int status = TclObjTypeSlice(interp, objv[1], first, last, &resultObj);
if (status == TCL_OK) {
Tcl_SetObjResult(interp, resultObj);
} else {
return TCL_ERROR;
}
} else {
Tcl_Obj *resultObj = TclListObjRange(interp, objv[1], first, last);
if (resultObj == NULL) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
2888 2889 2890 2891 2892 2893 2894 |
}
/*
* Make our working copy, then do the actual removes piecemeal.
*/
if (Tcl_IsShared(listObj)) {
| | | 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 |
}
/*
* Make our working copy, then do the actual removes piecemeal.
*/
if (Tcl_IsShared(listObj)) {
listObj = TclDuplicatePureObj(interp, listObj, &tclListType);
if (!listObj) {
status = TCL_ERROR;
goto done;
}
copied = 1;
}
num = 0;
|
| ︙ | ︙ | |||
3144 3145 3146 3147 3148 3149 3150 |
/*
* If the list object is unshared we can modify it directly, otherwise we
* create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
| | | 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 |
/*
* If the list object is unshared we can modify it directly, otherwise we
* create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType);
if (!listPtr) {
return TCL_ERROR;
}
}
/*
* Note that we call Tcl_ListObjReplace even when numToDelete == 0 and
|
| ︙ | ︙ | |||
3205 3206 3207 3208 3209 3210 3211 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
/*
| | | | | | > | < < | < | 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 |
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
/*
* Handle AbstractList special case - do not shimmer into a list, if it
* supports a private Reverse function, just to reverse it.
*/
if (TclObjTypeHasProc(objv[1], reverseProc)) {
Tcl_Obj *resultObj;
if (TclObjTypeReverse(interp, objv[1], &resultObj) == TCL_OK) {
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
} /* end Abstract List */
if (TclListObjLengthM(interp, objv[1], &elemc) != TCL_OK) {
return TCL_ERROR;
}
/*
* If the list is empty, just return it. [Bug 1876793]
*/
|
| ︙ | ︙ | |||
3311 3312 3313 3314 3315 3316 3317 |
Tcl_Size groupOffset, lower, upper;
int allocatedIndexVector = 0;
int isIncreasing;
Tcl_WideInt patWide, objWide, wide, groupSize;
int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
SortInfo sortInfo;
| | | 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 |
Tcl_Size groupOffset, lower, upper;
int allocatedIndexVector = 0;
int isIncreasing;
Tcl_WideInt patWide, objWide, wide, groupSize;
int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
SortInfo sortInfo;
Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr = NULL;
SortStrCmpFn_t strCmpFn = TclUtfCmp;
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",
|
| ︙ | ︙ | |||
3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 |
/*
* With -stride, lower, upper and i are kept as multiples of groupSize.
*/
lower = start - groupSize;
upper = listc;
while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) {
i = (lower + upper)/2;
i -= i % groupSize;
if (sortInfo.indexc != 0) {
itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
result = sortInfo.resultCode;
goto done;
}
} else {
| > > > > > | 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 |
/*
* With -stride, lower, upper and i are kept as multiples of groupSize.
*/
lower = start - groupSize;
upper = listc;
itemPtr = NULL;
while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) {
i = (lower + upper)/2;
i -= i % groupSize;
Tcl_BumpObj(itemPtr);
itemPtr = NULL;
if (sortInfo.indexc != 0) {
itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
result = sortInfo.resultCode;
goto done;
}
} else {
|
| ︙ | ︙ | |||
3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 |
*/
if (allMatches) {
listPtr = Tcl_NewListObj(0, NULL);
}
for (i = start; i < listc; i += groupSize) {
match = 0;
if (sortInfo.indexc != 0) {
itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
}
result = sortInfo.resultCode;
| > > > | 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 |
*/
if (allMatches) {
listPtr = Tcl_NewListObj(0, NULL);
}
for (i = start; i < listc; i += groupSize) {
match = 0;
Tcl_BumpObj(itemPtr);
itemPtr = NULL;
if (sortInfo.indexc != 0) {
itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
}
result = sortInfo.resultCode;
|
| ︙ | ︙ | |||
3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 |
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else {
Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewWideIntObj(i));
}
}
}
/*
* Return everything or a single value.
*/
if (allMatches) {
Tcl_SetObjResult(interp, listPtr);
} else if (!inlineReturn) {
| > > > | 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 |
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else {
Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewWideIntObj(i));
}
}
}
Tcl_BumpObj(itemPtr);
itemPtr = NULL;
/*
* Return everything or a single value.
*/
if (allMatches) {
Tcl_SetObjResult(interp, listPtr);
} else if (!inlineReturn) {
|
| ︙ | ︙ | |||
4038 4039 4040 4041 4042 4043 4044 |
Tcl_DecrRefCount(startPtr);
}
if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
}
return result;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 |
Tcl_DecrRefCount(startPtr);
}
if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* SequenceIdentifyArgument --
* (for [lseq] command)
*
|
| ︙ | ︙ | |||
4264 4265 4266 4267 4268 4269 4270 |
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Obj *elementCount = NULL;
Tcl_Obj *start = NULL, *end = NULL, *step = NULL;
Tcl_WideInt values[5];
Tcl_Obj *numValues[5];
Tcl_Obj *numberObj;
| | | 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 |
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Obj *elementCount = NULL;
Tcl_Obj *start = NULL, *end = NULL, *step = NULL;
Tcl_WideInt values[5];
Tcl_Obj *numValues[5];
Tcl_Obj *numberObj;
int status = TCL_ERROR, keyword, useDoubles = 0;
Tcl_Obj *arithSeriesPtr;
SequenceOperators opmode;
SequenceDecoded decoded;
int i, arg_key = 0, value_i = 0;
// Default constants
Tcl_Obj *zero = Tcl_NewIntObj(0);
Tcl_Obj *one = Tcl_NewIntObj(1);
|
| ︙ | ︙ | |||
4334 4335 4336 4337 4338 4339 4340 |
*/
switch (arg_key) {
/* No argument */
case 0:
Tcl_WrongNumArgs(interp, 1, objv,
"n ??op? n ??by? n??");
| < | | | | | | < | | < < | < | | < < < < < | 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 |
*/
switch (arg_key) {
/* No argument */
case 0:
Tcl_WrongNumArgs(interp, 1, objv,
"n ??op? n ??by? n??");
goto done;
break;
/* lseq n */
case 1:
start = zero;
elementCount = numValues[0];
end = NULL;
step = one;
break;
/* lseq n n */
case 11:
start = numValues[0];
end = numValues[1];
break;
/* lseq n n n */
case 111:
start = numValues[0];
end = numValues[1];
step = numValues[2];
break;
/* lseq n 'to' n */
/* lseq n 'count' n */
/* lseq n 'by' n */
case 121:
opmode = (SequenceOperators)values[1];
switch (opmode) {
case LSEQ_DOTS:
case LSEQ_TO:
start = numValues[0];
end = numValues[2];
break;
case LSEQ_BY:
start = zero;
elementCount = numValues[0];
step = numValues[2];
break;
case LSEQ_COUNT:
start = numValues[0];
elementCount = numValues[2];
step = one;
break;
default:
goto done;
}
break;
/* lseq n 'to' n n */
/* lseq n 'count' n n */
case 1211:
opmode = (SequenceOperators)values[1];
switch (opmode) {
case LSEQ_DOTS:
case LSEQ_TO:
start = numValues[0];
end = numValues[2];
step = numValues[3];
break;
case LSEQ_COUNT:
start = numValues[0];
elementCount = numValues[2];
step = numValues[3];
break;
case LSEQ_BY:
/* Error case */
goto done;
break;
default:
goto done;
break;
}
break;
/* lseq n n 'by' n */
case 1121:
start = numValues[0];
end = numValues[1];
opmode = (SequenceOperators)values[2];
switch (opmode) {
case LSEQ_BY:
step = numValues[3];
break;
case LSEQ_DOTS:
case LSEQ_TO:
case LSEQ_COUNT:
default:
goto done;
break;
}
break;
/* lseq n 'to' n 'by' n */
/* lseq n 'count' n 'by' n */
case 12121:
start = numValues[0];
opmode = (SequenceOperators)values[3];
switch (opmode) {
case LSEQ_BY:
step = numValues[4];
break;
default:
goto done;
break;
}
opmode = (SequenceOperators)values[1];
switch (opmode) {
case LSEQ_DOTS:
case LSEQ_TO:
start = numValues[0];
end = numValues[2];
break;
case LSEQ_COUNT:
start = numValues[0];
elementCount = numValues[2];
break;
default:
goto done;
break;
}
break;
/* Error cases: incomplete arguments */
case 12:
opmode = (SequenceOperators)values[1]; goto KeywordError; break;
case 112:
opmode = (SequenceOperators)values[2]; goto KeywordError; break;
case 1212:
opmode = (SequenceOperators)values[3]; goto KeywordError; break;
KeywordError:
switch (opmode) {
case LSEQ_DOTS:
case LSEQ_TO:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"missing \"to\" value."));
break;
case LSEQ_COUNT:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"missing \"count\" value."));
break;
case LSEQ_BY:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"missing \"by\" value."));
break;
}
goto done;
break;
/* All other argument errors */
default:
Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??");
goto done;
break;
}
/*
* Success! Now lets create the series object.
*/
|
| ︙ | ︙ | |||
4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 |
// Free constants
Tcl_DecrRefCount(zero);
Tcl_DecrRefCount(one);
return status;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LsortObjCmd --
*
* This procedure is invoked to process the "lsort" Tcl command. See the
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 |
// Free constants
Tcl_DecrRefCount(zero);
Tcl_DecrRefCount(one);
return status;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LsetObjCmd --
*
* This procedure is invoked to process the "lset" Tcl command. See the
* user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsetObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
Tcl_Obj *listPtr; /* Pointer to the list being altered. */
Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */
/*
* Check parameter count.
*/
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"listVar ?index? ?index ...? value");
return TCL_ERROR;
}
/*
* Look up the list variable's value.
*/
listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
if (listPtr == NULL) {
return TCL_ERROR;
}
/*
* Substitute the value in the value. Return either the value or else an
* unshared copy of it.
*/
if (objc == 4) {
finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]);
} else {
if (TclObjTypeHasProc(listPtr, setElementProc)) {
finalValuePtr = TclObjTypeSetElement(interp, listPtr,
objc-3, objv+2, objv[objc-1]);
if (finalValuePtr) {
Tcl_IncrRefCount(finalValuePtr);
}
} else {
finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2,
objv[objc-1]);
}
}
/*
* If substitution has failed, bail out.
*/
if (finalValuePtr == NULL) {
return TCL_ERROR;
}
/*
* Finally, update the variable so that traces fire.
*/
listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr,
TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(finalValuePtr);
if (listPtr == NULL) {
return TCL_ERROR;
}
/*
* Return the new value of the variable as the interpreter result.
*/
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LsortObjCmd --
*
* This procedure is invoked to process the "lsort" Tcl command. See the
|
| ︙ | ︙ | |||
4768 4769 4770 4771 4772 4773 4774 | /* * When sorting using a command, we are reentrant and therefore might * have the representation of the list being sorted shimmered out from * underneath our feet. Take a copy (cheap) to prevent this. [Bug * 1675116] */ | | | 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 |
/*
* When sorting using a command, we are reentrant and therefore might
* have the representation of the list being sorted shimmered out from
* underneath our feet. Take a copy (cheap) to prevent this. [Bug
* 1675116]
*/
listObj = TclDuplicatePureObj(interp ,listObj, &tclListType);
if (listObj == NULL) {
sortInfo.resultCode = TCL_ERROR;
goto done;
}
/*
* The existing command is a list. We want to flatten it, append two
|
| ︙ | ︙ | |||
4793 4794 4795 4796 4797 4798 4799 |
sortInfo.resultCode = TCL_ERROR;
goto done;
}
Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
sortInfo.compareCmdPtr = newCommandPtr;
}
| | | | | 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 |
sortInfo.resultCode = TCL_ERROR;
goto done;
}
Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
sortInfo.compareCmdPtr = newCommandPtr;
}
if (TclObjTypeHasProc(objv[1], getElementsProc)) {
sortInfo.resultCode =
TclObjTypeGetElements(interp, listObj, &length, &listObjPtrs);
} else {
sortInfo.resultCode = TclListObjGetElementsM(interp, listObj,
&length, &listObjPtrs);
}
if (sortInfo.resultCode != TCL_OK || length <= 0) {
goto done;
}
|
| ︙ | ︙ | |||
5124 5125 5126 5127 5128 5129 5130 |
if (first <= last) {
numToDelete = last - first + 1;
} else {
numToDelete = 0;
}
if (Tcl_IsShared(listPtr)) {
| | | 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 |
if (first <= last) {
numToDelete = last - first + 1;
} else {
numToDelete = 0;
}
if (Tcl_IsShared(listPtr)) {
listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType);
if (!listPtr) {
return TCL_ERROR;
}
createdNewObj = 1;
} else {
createdNewObj = 0;
}
|
| ︙ | ︙ | |||
5544 5545 5546 5547 5548 5549 5550 |
* Iterate over the indices, traversing through the nested sublists as we
* go.
*/
for (i=0 ; i<infoPtr->indexc ; i++) {
Tcl_Size listLen;
int index;
| | | 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 |
* Iterate over the indices, traversing through the nested sublists as we
* go.
*/
for (i=0 ; i<infoPtr->indexc ; i++) {
Tcl_Size listLen;
int index;
Tcl_Obj *currentObj, *lastObj=NULL;
if (TclListObjLengthM(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
index = TclIndexDecode(infoPtr->indexv[i], listLen - 1);
|
| ︙ | ︙ | |||
5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 |
}
Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
"INDEXFAILED", NULL);
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
objPtr = currentObj;
}
return objPtr;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* End:
*/
| > > | 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 |
}
Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
"INDEXFAILED", NULL);
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
objPtr = currentObj;
Tcl_BumpObj(lastObj);
lastObj = currentObj;
}
return objPtr;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* End:
*/
|
Changes to generic/tclCmdMZ.c.
| ︙ | ︙ | |||
1608 1609 1610 1611 1612 1613 1614 |
break;
case STR_IS_ASCII:
chcomp = UniCharIsAscii;
break;
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
| | | 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 |
break;
case STR_IS_ASCII:
chcomp = UniCharIsAscii;
break;
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
if (!TclHasInternalRep(objPtr, &tclBooleanType)
&& (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) {
if (strict) {
result = 0;
} else {
string1 = Tcl_GetStringFromObj(objPtr, &length1);
result = length1 == 0;
}
|
| ︙ | ︙ | |||
1677 1678 1679 1680 1681 1682 1683 |
}
break;
}
case STR_IS_DIGIT:
chcomp = Tcl_UniCharIsDigit;
break;
case STR_IS_DOUBLE: {
| | | | | 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 |
}
break;
}
case STR_IS_DIGIT:
chcomp = Tcl_UniCharIsDigit;
break;
case STR_IS_DOUBLE: {
if (TclHasInternalRep(objPtr, &tclDoubleType) ||
TclHasInternalRep(objPtr, &tclIntType) ||
TclHasInternalRep(objPtr, &tclBignumType)) {
break;
}
string1 = Tcl_GetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
|
| ︙ | ︙ | |||
1708 1709 1710 1711 1712 1713 1714 |
break;
}
case STR_IS_GRAPH:
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT:
case STR_IS_ENTIER:
| | | | 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 |
break;
}
case STR_IS_GRAPH:
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT:
case STR_IS_ENTIER:
if (TclHasInternalRep(objPtr, &tclIntType) ||
TclHasInternalRep(objPtr, &tclBignumType)) {
break;
}
string1 = Tcl_GetStringFromObj(objPtr, &length1);
if (length1 == 0) {
if (strict) {
result = 0;
}
|
| ︙ | ︙ |
Changes to generic/tclCompExpr.c.
| ︙ | ︙ | |||
2107 2108 2109 2110 2111 2112 2113 | /* * We have a number followed directly by bareword characters * (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] */ | | | 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 |
/*
* We have a number followed directly by bareword characters
* (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 (TclHasInternalRep(literal, &tclDoubleType)) {
const char *p = start;
while (p < end) {
if (!TclIsBareword(*p++)) {
/*
* The number has non-bareword characters, so we
* must treat it as a number.
|
| ︙ | ︙ |
Changes to generic/tclDecls.h.
| ︙ | ︙ | |||
4059 4060 4061 4062 4063 4064 4065 | #else #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetByteArrayFromObj(objPtr, (sizePtr)) : \ tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (Tcl_Size *)(void *)(sizePtr))) #endif #else | < < < < > | < < | > > > > > > > > > > | 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 |
#else
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
(sizeof(*(sizePtr)) <= sizeof(int) ? \
tclStubsPtr->tclGetByteArrayFromObj(objPtr, (sizePtr)) : \
tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (Tcl_Size *)(void *)(sizePtr)))
#endif
#else
#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \
((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \
(flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr)))
#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \
((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \
Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
#define Tcl_GetBoolean(interp, src, boolPtr) \
((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \
Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)))
#if defined(TCL_NO_DEPRECATED)
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
(Tcl_GetBytesFromObj)(NULL, objPtr, (Tcl_Size *)(void *)(sizePtr))
#else
#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \
(sizeof(*(sizePtr)) <= sizeof(int) ? \
TclGetBytesFromObj(NULL, objPtr, (sizePtr)) : \
(Tcl_GetBytesFromObj)(NULL, objPtr, (Tcl_Size *)(void *)(sizePtr)))
#define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \
(sizeof(*(sizePtr)) <= sizeof(int) ? \
TclGetUnicodeFromObj(objPtr, (sizePtr)) : \
(Tcl_GetUnicodeFromObj)(objPtr, (Tcl_Size *)(void *)(sizePtr)))
#define Tcl_GetStringFromObj(objPtr, sizePtr) \
(sizeof(*(sizePtr)) <= sizeof(int) ? \
TclGetStringFromObj(objPtr, (sizePtr)) : \
(Tcl_GetStringFromObj)(objPtr, (Tcl_Size *)(void *)(sizePtr)))
#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \
(sizeof(*(sizePtr)) <= sizeof(int) ? \
TclGetBytesFromObj(interp, objPtr, (sizePtr)) : \
(Tcl_GetBytesFromObj)(interp, objPtr, (Tcl_Size *)(void *)(sizePtr)))
#endif
#endif
#ifdef TCL_MEM_DEBUG
# undef Tcl_Alloc
# define Tcl_Alloc(x) \
(Tcl_DbCkalloc((x), __FILE__, __LINE__))
# undef Tcl_Free
|
| ︙ | ︙ |
Changes to generic/tclDictObj.c.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 64 65 66 67 68 69 70 |
Tcl_Obj *keyPtr);
static Tcl_NRPostProc FinalizeDictUpdate;
static Tcl_NRPostProc FinalizeDictWith;
static Tcl_ObjCmdProc DictForNRCmd;
static Tcl_ObjCmdProc DictMapNRCmd;
static Tcl_NRPostProc DictForLoopCallback;
static Tcl_NRPostProc DictMapLoopCallback;
/*
* Table of dict subcommand names and implementations.
*/
static const EnsembleImplMap implementationMap[] = {
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
| > > | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
Tcl_Obj *keyPtr);
static Tcl_NRPostProc FinalizeDictUpdate;
static Tcl_NRPostProc FinalizeDictWith;
static Tcl_ObjCmdProc DictForNRCmd;
static Tcl_ObjCmdProc DictMapNRCmd;
static Tcl_NRPostProc DictForLoopCallback;
static Tcl_NRPostProc DictMapLoopCallback;
static Tcl_ObjTypeLengthProc DictAsListLength;
static Tcl_ObjTypeIndexProc DictAsListIndex;
/*
* Table of dict subcommand names and implementations.
*/
static const EnsembleImplMap implementationMap[] = {
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
|
| ︙ | ︙ | |||
139 140 141 142 143 144 145 |
/*
* The structure below defines the dictionary object type by means of
* functions that can be invoked by generic object code.
*/
const Tcl_ObjType tclDictType = {
"dict",
| | | | | | > > > > > > > > > > | 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
/*
* The structure below defines the dictionary object type by means of
* functions that can be invoked by generic object code.
*/
const Tcl_ObjType tclDictType = {
"dict",
FreeDictInternalRep, /* freeIntRepProc */
DupDictInternalRep, /* dupIntRepProc */
UpdateStringOfDict, /* updateStringProc */
SetDictFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V2( /* Extended type for AbstractLists */
DictAsListLength, /* return "list" length of dict value w/o
* shimmering */
DictAsListIndex, /* return key or value at "list" index
* location. (keysare at even indicies,
* values at odd indicies) */
NULL,
NULL,
NULL,
NULL,
NULL)
};
#define DictSetInternalRep(objPtr, dictRepPtr) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (dictRepPtr); \
ir.twoPtrValue.ptr2 = NULL; \
|
| ︙ | ︙ | |||
599 600 601 602 603 604 605 |
/*
* 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.
*/
| | | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 |
/*
* 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 (TclHasInternalRep(objPtr, &tclListType)) {
Tcl_Size objc, i;
Tcl_Obj **objv;
/* Cannot fail, we already know the Tcl_ObjType is "list". */
TclListObjGetElementsM(NULL, objPtr, &objc, &objv);
if (objc & 1) {
goto missingValue;
|
| ︙ | ︙ | |||
3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 |
Tcl_Command
TclInitDictCmd(
Tcl_Interp *interp)
{
return TclMakeEnsemble(interp, "dict", implementationMap);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 |
Tcl_Command
TclInitDictCmd(
Tcl_Interp *interp)
{
return TclMakeEnsemble(interp, "dict", implementationMap);
}
/*
*----------------------------------------------------------------------
*
* DictAsListLength --
*
* Compute the length of a list as if the dict value were converted to a
* list.
*
* Note: the list length may not match the dict size * 2. This occurs when
* there are duplicate keys in the original string representation.
*
* Side Effects --
*
* The intent is to have no side effects.
*/
static Tcl_Size
DictAsListLength(
Tcl_Obj *objPtr)
{
Tcl_Size estCount, length, llen;
const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length);
Tcl_Obj *elemPtr;
/*
* Allocate enough space to hold a (Tcl_Obj *) for each
* (possible) list element.
*/
estCount = TclMaxListLength(nextElem, length, &limit);
estCount += (estCount == 0); /* Smallest list struct holds 1
* element. */
elemPtr = Tcl_NewObj();
llen = 0;
while (nextElem < limit) {
const char *elemStart;
char *check;
Tcl_Size elemSize;
int literal;
if (TCL_OK != TclFindElement(NULL, nextElem, limit - nextElem,
&elemStart, &nextElem, &elemSize, &literal)) {
Tcl_DecrRefCount(elemPtr);
return 0;
}
if (elemStart == limit) {
break;
}
TclInvalidateStringRep(elemPtr);
check = Tcl_InitStringRep(elemPtr, literal ? elemStart : NULL,
elemSize);
if (elemSize && check == NULL) {
Tcl_DecrRefCount(elemPtr);
return 0;
}
if (!literal) {
Tcl_InitStringRep(elemPtr, NULL,
TclCopyAndCollapse(elemSize, elemStart, check));
}
llen++;
}
Tcl_DecrRefCount(elemPtr);
return llen;
}
/*
*----------------------------------------------------------------------
*
* DictAsListIndex --
*
* Return the key or value at the given "list" index, i.e., as if the string
* value where treated as a list. The intent is to support this list
* operation w/o causing the Obj value to shimmer into a List.
*
* Side Effects --
*
* The intent is to have no side effects.
*
*/
static int
DictAsListIndex(
Tcl_Interp *interp,
struct Tcl_Obj *objPtr,
Tcl_Size index,
Tcl_Obj** elemObjPtr)
{
Tcl_Size /*estCount,*/ length, llen;
const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length);
Tcl_Obj *elemPtr;
/*
* Compute limit of the list string
*/
TclMaxListLength(nextElem, length, &limit);
elemPtr = Tcl_NewObj();
llen = 0;
/*
* parse out each element until reaching the "index"th element.
* Sure this is slow, but shimmering is slower.
*/
while (nextElem < limit) {
const char *elemStart;
char *check;
Tcl_Size elemSize;
int literal;
if (TCL_OK != TclFindElement(NULL, nextElem, limit - nextElem,
&elemStart, &nextElem, &elemSize, &literal)) {
Tcl_DecrRefCount(elemPtr);
return 0;
}
if (elemStart == limit) {
break;
}
TclInvalidateStringRep(elemPtr);
check = Tcl_InitStringRep(elemPtr, literal ? elemStart : NULL,
elemSize);
if (elemSize && check == NULL) {
Tcl_DecrRefCount(elemPtr);
if (interp) {
// Need error message here
}
return TCL_ERROR;
}
if (!literal) {
Tcl_InitStringRep(elemPtr, NULL,
TclCopyAndCollapse(elemSize, elemStart, check));
}
if (llen == index) {
*elemObjPtr = elemPtr;
return TCL_OK;
}
llen++;
}
/*
* Index is beyond end of list - return empty
*/
Tcl_InitStringRep(elemPtr, NULL, 0);
*elemObjPtr = elemPtr;
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclEncoding.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclEncoding.c -- * * Contains the implementation of the encoding conversion package. * * Copyright © 1996-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. */ #include "tclInt.h" typedef size_t (LengthProc)(const char *src); /* * The following data structure represents an encoding, which describes how to * convert between various character sets and UTF-8. */ | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclEncoding.c -- * * Contains the implementation of the encoding conversion package. * * Copyright © 1996-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. */ #include "tclInt.h" #include <assert.h> typedef size_t (LengthProc)(const char *src); /* * The following data structure represents an encoding, which describes how to * convert between various character sets and UTF-8. */ |
| ︙ | ︙ | |||
567 568 569 570 571 572 573 |
TclInitEncodingSubsystem(void)
{
Tcl_EncodingType type;
TableEncodingData *dataPtr;
unsigned size;
unsigned short i;
union {
| | | | 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 |
TclInitEncodingSubsystem(void)
{
Tcl_EncodingType type;
TableEncodingData *dataPtr;
unsigned size;
unsigned short i;
union {
char c;
short s;
} isLe;
int leFlags;
if (encodingsInitialized) {
return;
}
|
| ︙ | ︙ | |||
3472 3473 3474 3475 3476 3477 3478 |
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
byte = *((unsigned char *) src);
if (prefixBytes[byte]) {
| < | > | < < | < | > | 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 |
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
byte = *((unsigned char *) src);
if (prefixBytes[byte]) {
if (src >= srcEnd-1) {
/* Prefix byte but nothing after it */
if (!(flags & TCL_ENCODING_END)) {
/* More data to come */
result = TCL_CONVERT_MULTIBYTE;
break;
} else if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_SYNTAX;
break;
} else if (PROFILE_REPLACE(flags)) {
ch = UNICODE_REPLACE_CHAR;
} else {
ch = (Tcl_UniChar)byte;
}
} else {
ch = toUnicode[byte][*((unsigned char *)++src)];
}
} else {
ch = pageZero[byte];
}
if ((ch == 0) && (byte != 0)) {
/* Prefix+suffix pair is invalid */
if (PROFILE_STRICT(flags)) {
result = TCL_CONVERT_SYNTAX;
break;
}
if (prefixBytes[byte]) {
src--;
}
|
| ︙ | ︙ | |||
3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 |
*dst++ = (char) ch;
} else {
dst += Tcl_UniCharToUtf(ch, dst);
}
src++;
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
| > | 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 |
*dst++ = (char) ch;
} else {
dst += Tcl_UniCharToUtf(ch, dst);
}
src++;
}
assert(src <= srcEnd);
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
|
| ︙ | ︙ | |||
4054 4055 4056 4057 4058 4059 4060 |
* checked all the sequences, then it's a syntax error, otherwise
* we need more bytes to determine a match.
*/
if ((checked == dataPtr->numSubTables + 2)
|| (flags & TCL_ENCODING_END)) {
if (!PROFILE_STRICT(flags)) {
| < | | < < | 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 |
* checked all the sequences, then it's a syntax error, otherwise
* we need more bytes to determine a match.
*/
if ((checked == dataPtr->numSubTables + 2)
|| (flags & TCL_ENCODING_END)) {
if (!PROFILE_STRICT(flags)) {
/* Unknown escape sequence */
dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst);
src += longest;
continue;
}
result = TCL_CONVERT_SYNTAX;
} else {
result = TCL_CONVERT_MULTIBYTE;
}
|
| ︙ | ︙ |
Changes to generic/tclEnsemble.c.
| ︙ | ︙ | |||
603 604 605 606 607 608 609 |
Tcl_DecrRefCount(patchedDict);
}
goto freeMapAndError;
}
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = TclDuplicatePureObj(
| | | | 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 |
Tcl_DecrRefCount(patchedDict);
}
goto freeMapAndError;
}
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = TclDuplicatePureObj(
interp, listObj, &tclListType);
if (!newList) {
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
}
goto freeMapAndError;
}
Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr);
if (nsPtr->parentPtr) {
Tcl_AppendStringsToObj(newCmd, "::", NULL);
}
Tcl_AppendObjToObj(newCmd, listv[0]);
Tcl_ListObjReplace(NULL, newList, 0, 1, 1,
&newCmd);
if (patchedDict == NULL) {
patchedDict = TclDuplicatePureObj(
interp, objv[1], &tclListType);
if (!patchedDict) {
goto freeMapAndError;
}
}
Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
newList);
}
|
| ︙ | ︙ | |||
1922 1923 1924 1925 1926 1927 1928 |
Tcl_Obj **copyObjv;
Tcl_Size copyObjc, prefixObjc;
TclListObjLengthM(NULL, prefixObj, &prefixObjc);
if (objc == 2) {
copyPtr = TclDuplicatePureObj(
| | | 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 |
Tcl_Obj **copyObjv;
Tcl_Size copyObjc, prefixObjc;
TclListObjLengthM(NULL, prefixObj, &prefixObjc);
if (objc == 2) {
copyPtr = TclDuplicatePureObj(
interp, prefixObj, &tclListType);
if (!copyPtr) {
return TCL_ERROR;
}
} else {
copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL);
Tcl_ListObjAppendList(NULL, copyPtr, prefixObj);
Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
|
| ︙ | ︙ | |||
2326 2327 2328 2329 2330 2331 2332 |
Tcl_Obj **paramv, *unknownCmd, *ensObj;
/*
* Create the "unknown" command callback to determine what to do.
*/
unknownCmd = TclDuplicatePureObj(
| | | 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 |
Tcl_Obj **paramv, *unknownCmd, *ensObj;
/*
* Create the "unknown" command callback to determine what to do.
*/
unknownCmd = TclDuplicatePureObj(
interp, ensemblePtr->unknownHandler, &tclListType);
if (!unknownCmd) {
return TCL_ERROR;
}
TclNewObj(ensObj);
Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
for (i = 1 ; i < objc ; i++) {
|
| ︙ | ︙ |
Changes to generic/tclEvent.c.
| ︙ | ︙ | |||
229 230 231 232 233 234 235 | /* * Note we copy the handler command prefix each pass through, so we do * support one handler setting another handler. */ Tcl_Obj *copyObj = TclDuplicatePureObj( | | | 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 |
/*
* Note we copy the handler command prefix each pass through, so we do
* support one handler setting another handler.
*/
Tcl_Obj *copyObj = TclDuplicatePureObj(
interp, assocPtr->cmdPrefix, &tclListType);
if (!copyObj) {
return;
}
errPtr = assocPtr->firstBgPtr;
TclListObjGetElementsM(NULL, copyObj, &prefixObjc, &prefixObjv);
|
| ︙ | ︙ |
Changes to generic/tclExecute.c.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" #include "tclTomMath.h" | < | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" #include "tclTomMath.h" #include <math.h> #include <assert.h> /* * Hack to determine whether we may expect IEEE floating point. The hack is * formally incorrect in that non-IEEE platforms might have the same precision * and range, but VAX, IBM, and Cray do not; are there any other floating |
| ︙ | ︙ | |||
447 448 449 450 451 452 453 | * Tcl_GetNumberFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * void **ptrPtr, int *tPtr); */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ | | | | 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 |
* Tcl_GetNumberFromObj(). The ANSI C "prototype" is:
*
* MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
* void **ptrPtr, int *tPtr);
*/
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
((TclHasInternalRep((objPtr), &tclIntType)) \
? (*(tPtr) = TCL_NUMBER_INT, \
*(ptrPtr) = (void *) \
(&((objPtr)->internalRep.wideValue)), TCL_OK) : \
TclHasInternalRep((objPtr), &tclDoubleType) \
? (((isnan((objPtr)->internalRep.doubleValue)) \
? (*(tPtr) = TCL_NUMBER_NAN) \
: (*(tPtr) = TCL_NUMBER_DOUBLE)), \
*(ptrPtr) = (void *) \
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \
? TCL_ERROR : \
|
| ︙ | ︙ | |||
670 671 672 673 674 675 676 |
* Custom object type only used in this file; values of its type should never
* be seen by user scripts.
*/
static const Tcl_ObjType dictIteratorType = {
"dictIterator",
ReleaseDictIterator,
| | > | 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 |
* Custom object type only used in this file; values of its type should never
* be seen by user scripts.
*/
static const Tcl_ObjType dictIteratorType = {
"dictIterator",
ReleaseDictIterator,
NULL, NULL, NULL,
TCL_OBJTYPE_V0
};
/*
*----------------------------------------------------------------------
*
* ReleaseDictIterator --
*
|
| ︙ | ︙ | |||
2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 |
NEXT_INST_F(5, 0, 0);
}
break;
case INST_STR_CONCAT1:
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;
}
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
break;
case INST_CONCAT_STK:
/*
* Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj,
| > > > | 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 |
NEXT_INST_F(5, 0, 0);
}
break;
case INST_STR_CONCAT1:
opnd = TclGetUInt1AtPtr(pc+1);
DECACHE_STACK_INFO();
objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1),
TCL_STRING_IN_PLACE);
if (objResultPtr == NULL) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
CACHE_STACK_INFO();
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
break;
case INST_CONCAT_STK:
/*
* Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj,
|
| ︙ | ︙ | |||
3371 3372 3373 3374 3375 3376 3377 |
objResultPtr = varPtr->value.objPtr;
if (TclListObjLengthM(interp, objResultPtr, &len) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (Tcl_IsShared(objResultPtr)) {
Tcl_Obj *newValue = TclDuplicatePureObj(
| | | 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 |
objResultPtr = varPtr->value.objPtr;
if (TclListObjLengthM(interp, objResultPtr, &len) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (Tcl_IsShared(objResultPtr)) {
Tcl_Obj *newValue = TclDuplicatePureObj(
interp, objResultPtr, &tclListType);
if (!newValue) {
TRACE_ERROR(interp);
goto gotError;
}
TclDecrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr = newValue;
|
| ︙ | ︙ | |||
3435 3436 3437 3438 3439 3440 3441 |
valueToAssign = valuePtr;
} else if (TclListObjLengthM(interp, objResultPtr, &len)!=TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
} else {
if (Tcl_IsShared(objResultPtr)) {
valueToAssign = TclDuplicatePureObj(
| | | 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 |
valueToAssign = valuePtr;
} else if (TclListObjLengthM(interp, objResultPtr, &len)!=TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
} else {
if (Tcl_IsShared(objResultPtr)) {
valueToAssign = TclDuplicatePureObj(
interp, objResultPtr, &tclListType);
if (!valueToAssign) {
goto errorInLappendListPtr;
}
createdNewObj = 1;
} else {
valueToAssign = objResultPtr;
}
|
| ︙ | ︙ | |||
4664 4665 4666 4667 4668 4669 4670 |
NEXT_INST_F(1, 1, 1);
case INST_LIST_INDEX: /* lindex with objc == 3 */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
| < | | > | | < > | | 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 |
NEXT_INST_F(1, 1, 1);
case INST_LIST_INDEX: /* lindex with objc == 3 */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
/* special case for AbstractList */
if (TclObjTypeHasProc(valuePtr,indexProc)) {
DECACHE_STACK_INFO();
length = TclObjTypeLength(valuePtr);
if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
if (TclObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
CACHE_STACK_INFO();
Tcl_IncrRefCount(objResultPtr); // reference held here
goto lindexDone;
}
/*
* Extract the desired list element.
*/
{
Tcl_Size value2Length;
Tcl_Obj *indexListPtr = value2Ptr;
if ((TclListObjGetElementsM(interp, valuePtr, &objc, &objv) == TCL_OK)
&& (
!TclHasInternalRep(value2Ptr, &tclListType)
||
((Tcl_ListObjLength(interp,value2Ptr,&value2Length),
value2Length == 1
? (indexListPtr = TclListObjGetElement(value2Ptr, 0), 1)
: 0
))
)
|
| ︙ | ︙ | |||
4750 4751 4752 4753 4754 4755 4756 |
* Pop the list and get the index.
*/
valuePtr = OBJ_AT_TOS;
opnd = TclGetInt4AtPtr(pc+1);
TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd));
| > > > > > | | | < < > > | < > > < < < < | | 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 |
* Pop the list and get the index.
*/
valuePtr = OBJ_AT_TOS;
opnd = TclGetInt4AtPtr(pc+1);
TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd));
/*
* Get the contents of the list, making sure that it really is a list
* in the process.
*/
/* special case for AbstractList */
if (TclObjTypeHasProc(valuePtr,indexProc)) {
length = TclObjTypeLength(valuePtr);
/* Decode end-offset index values. */
index = TclIndexDecode(opnd, length-1);
if (index >= 0 && index < length) {
/* Compute value @ index */
DECACHE_STACK_INFO();
if (TclObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
CACHE_STACK_INFO();
} else {
TclNewObj(objResultPtr);
}
pcAdjustment = 5;
goto lindexFastPath2;
}
/* List case */
if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
/* Decode end-offset index values. */
|
| ︙ | ︙ | |||
4850 4851 4852 4853 4854 4855 4856 | valuePtr = POP_OBJECT(); Tcl_DecrRefCount(valuePtr); /* This one should be done here */ /* * Compute the new variable value. */ | > > > > > > | > > | | 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 |
valuePtr = POP_OBJECT();
Tcl_DecrRefCount(valuePtr); /* This one should be done here */
/*
* Compute the new variable value.
*/
DECACHE_STACK_INFO();
if (TclObjTypeHasProc(valuePtr, setElementProc)) {
objResultPtr = TclObjTypeSetElement(interp,
valuePtr, numIndices,
&OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS);
} else {
objResultPtr = TclLsetFlat(interp, valuePtr, numIndices,
&OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS);
}
if (!objResultPtr) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
/*
* Set result.
*/
CACHE_STACK_INFO();
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_V(5, numIndices+1, -1);
case INST_LSET_LIST: /* 'lset' with 4 args */
/*
* Get the old value of variable, and remove the stack ref. This is
* safe because the variable still references the object; the ref
|
| ︙ | ︙ | |||
4972 4973 4974 4975 4976 4977 4978 |
*/
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = TCL_INDEX_START;
}
fromIdx = TclIndexDecode(fromIdx, objc - 1);
| > | > | > > > > | | > | > > > > > | > | | | 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 |
*/
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = TCL_INDEX_START;
}
fromIdx = TclIndexDecode(fromIdx, objc - 1);
DECACHE_STACK_INFO();
if (TclObjTypeHasProc(valuePtr, sliceProc)) {
if (TclObjTypeSlice(interp, valuePtr, fromIdx, toIdx, &objResultPtr) != TCL_OK) {
objResultPtr = NULL;
}
} else {
objResultPtr = TclListObjRange(interp, valuePtr, fromIdx, toIdx);
}
if (objResultPtr == NULL) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
CACHE_STACK_INFO();
TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
case INST_LIST_IN:
case INST_LIST_NOT_IN: /* Basic list containment operators. */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
if (TclListObjLengthM(interp, value2Ptr, &length) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
match = 0;
if (length > 0) {
Tcl_Size i = 0;
Tcl_Obj *o;
int isAbstractList = TclObjTypeHasProc(value2Ptr,indexProc) != NULL;
/*
* An empty list doesn't match anything.
*/
do {
if (isAbstractList) {
DECACHE_STACK_INFO();
if (TclObjTypeIndex(interp, value2Ptr, i, &o) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
CACHE_STACK_INFO();
} else {
Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
}
if (o != NULL) {
s2 = Tcl_GetStringFromObj(o, &s2len);
} else {
s2 = "";
s2len = 0;
}
if (s1len == s2len) {
match = (memcmp(s1, s2, s1len) == 0);
}
/* Could be an ephemeral abstract obj */
Tcl_BumpObj(o);
i++;
} while (i < length && match == 0);
}
if (*pc == INST_LIST_NOT_IN) {
match = !match;
}
|
| ︙ | ︙ | |||
6364 6365 6366 6367 6368 6369 6370 |
/*
* End of numeric operator instructions.
* -----------------------------------------------------------------
*/
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
| | | 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 |
/*
* End of numeric operator instructions.
* -----------------------------------------------------------------
*/
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
if (TclHasInternalRep(valuePtr, &tclBooleanType)) {
objResultPtr = TCONST(1);
} else {
int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
objResultPtr = TCONST(res);
}
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr);
NEXT_INST_F(1, 0, 1);
|
| ︙ | ︙ | |||
6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 |
iterMax = 0;
listTmpDepth = numLists-1;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
if (TclListObjLengthM(interp, listPtr, &listLen) != TCL_OK) {
TRACE_APPEND(("ERROR converting list %" TCL_Z_MODIFIER "d, \"%s\": %s",
i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
if (Tcl_IsShared(listPtr)) {
objPtr = TclDuplicatePureObj(
| > > > | | 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 |
iterMax = 0;
listTmpDepth = numLists-1;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
DECACHE_STACK_INFO();
if (TclListObjLengthM(interp, listPtr, &listLen) != TCL_OK) {
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR converting list %" TCL_Z_MODIFIER "d, \"%s\": %s",
i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
CACHE_STACK_INFO();
if (Tcl_IsShared(listPtr)) {
objPtr = TclDuplicatePureObj(
interp, listPtr, &tclListType);
if (!objPtr) {
goto gotError;
}
Tcl_IncrRefCount(objPtr);
Tcl_DecrRefCount(listPtr);
OBJ_AT_DEPTH(listTmpDepth) = objPtr;
}
|
| ︙ | ︙ | |||
6476 6477 6478 6479 6480 6481 6482 | /* * Jump directly to the INST_FOREACH_STEP instruction; the C code just * falls through. */ pc += 5 - infoPtr->loopCtTemp; | | | 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 |
/*
* Jump directly to the INST_FOREACH_STEP instruction; the C code just
* falls through.
*/
pc += 5 - infoPtr->loopCtTemp;
case INST_FOREACH_STEP: /* TODO: address abstract list indexing here! */
/*
* "Step" a foreach loop (i.e., begin its next iteration) by assigning
* the next value list element to each loop var.
*/
tmpPtr = OBJ_AT_TOS;
infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
|
| ︙ | ︙ | |||
6509 6510 6511 6512 6513 6514 6515 6516 6517 |
tmpPtr->internalRep.twoPtrValue.ptr1 =(void *)(iterNum + 1);
listTmpDepth = numLists + 1;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
| > > > > > > > | | > > > > > | > > > > > > > > > > > > > > | 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 |
tmpPtr->internalRep.twoPtrValue.ptr1 =(void *)(iterNum + 1);
listTmpDepth = numLists + 1;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
int hasAbstractList;
listPtr = OBJ_AT_DEPTH(listTmpDepth);
hasAbstractList = TclObjTypeHasProc(listPtr, indexProc) != 0;
DECACHE_STACK_INFO();
if (hasAbstractList) {
status = Tcl_ListObjLength(interp, listPtr, &listLen);
elements = NULL;
} else {
status = TclListObjGetElementsM(
interp, listPtr, &listLen, &elements);
}
if (status != TCL_OK) {
CACHE_STACK_INFO();
goto gotError;
}
CACHE_STACK_INFO();
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
if (valIndex >= listLen) {
TclNewObj(valuePtr);
} else {
DECACHE_STACK_INFO();
if (elements) {
valuePtr = elements[valIndex];
} else {
status = Tcl_ListObjIndex(
interp, listPtr, valIndex, &valuePtr);
if (status != TCL_OK) {
/* Could happen for abstract lists */
CACHE_STACK_INFO();
goto gotError;
}
if (valuePtr == NULL) {
/* Permitted for Tcl_LOI to return NULL */
TclNewObj(valuePtr);
}
}
CACHE_STACK_INFO();
}
varIndex = varListPtr->varIndexes[j];
varPtr = LOCAL(varIndex);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
|
| ︙ | ︙ | |||
8394 8395 8396 8397 8398 8399 8400 |
WIDE_RESULT(wResult);
}
}
overflowExpon:
if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK)
| | | 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 |
WIDE_RESULT(wResult);
}
}
overflowExpon:
if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK)
|| (value2Ptr->typePtr != &tclIntType)
|| (Tcl_WideUInt)w2 >= (1<<28)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
err = mp_init(&bigResult);
|
| ︙ | ︙ | |||
8954 8955 8956 8957 8958 8959 8960 |
if (opCode >= LAST_INST_OPCODE) {
fprintf(stderr, "\nBad opcode %u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n",
opCode, relativePc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
if (checkStack &&
(stackTop > stackUpperBound)) {
| | | 9009 9010 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 |
if (opCode >= LAST_INST_OPCODE) {
fprintf(stderr, "\nBad opcode %u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n",
opCode, relativePc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
if (checkStack &&
(stackTop > stackUpperBound)) {
Tcl_Size numChars;
const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL);
fprintf(stderr, "\nBad stack top %" TCL_Z_MODIFIER "u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %" TCL_Z_MODIFIER "u)",
stackTop, relativePc, stackUpperBound);
if (cmd != NULL) {
Tcl_Obj *message;
|
| ︙ | ︙ | |||
9494 9495 9496 9497 9498 9499 9500 |
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;
| | > > | 9549 9550 9551 9552 9553 9554 9555 9556 9557 9558 9559 9560 9561 9562 9563 9564 9565 |
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;
Tcl_Size i;
size_t ui;
char *litTableStats;
LiteralEntry *entryPtr;
Tcl_Obj *objPtr;
#define Percent(a,b) ((a) * 100.0 / (b))
TclNewObj(objPtr);
|
| ︙ | ︙ | |||
9630 9631 9632 9633 9634 9635 9636 |
refCountSum = 0;
numSharedMultX = 0;
numSharedOnce = 0;
objBytesIfUnshared = 0.0;
strBytesIfUnshared = 0.0;
strBytesSharedMultX = 0.0;
strBytesSharedOnce = 0.0;
| | | 9687 9688 9689 9690 9691 9692 9693 9694 9695 9696 9697 9698 9699 9700 9701 |
refCountSum = 0;
numSharedMultX = 0;
numSharedOnce = 0;
objBytesIfUnshared = 0.0;
strBytesIfUnshared = 0.0;
strBytesSharedMultX = 0.0;
strBytesSharedOnce = 0.0;
for (ui = 0; ui < globalTablePtr->numBuckets; ui++) {
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {
if (TclHasInternalRep(entryPtr->objPtr, &tclByteCodeType)) {
numByteCodeLits++;
}
(void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
refCountSum += entryPtr->refCount;
|
| ︙ | ︙ | |||
9748 9749 9750 9751 9752 9753 9754 |
while (i-- > 0) {
if (statsPtr->literalCount[i] > 0) {
maxSizeDecade = i;
break;
}
}
sum = 0;
| | | | | 9805 9806 9807 9808 9809 9810 9811 9812 9813 9814 9815 9816 9817 9818 9819 9820 9821 |
while (i-- > 0) {
if (statsPtr->literalCount[i] > 0) {
maxSizeDecade = i;
break;
}
}
sum = 0;
for (ui = 0; ui <= maxSizeDecade; ui++) {
decadeHigh = (1 << (ui+1)) - 1;
sum += statsPtr->literalCount[ui];
Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numLiteralsCreated));
}
litTableStats = TclLiteralStats(globalTablePtr);
Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n",
litTableStats);
|
| ︙ | ︙ | |||
9781 9782 9783 9784 9785 9786 9787 |
if (statsPtr->srcCount[i] > 0) {
break; /* maxSizeDecade to consume 'i' value
* below... */
}
}
maxSizeDecade = i;
sum = 0;
| | | | | 9838 9839 9840 9841 9842 9843 9844 9845 9846 9847 9848 9849 9850 9851 9852 9853 9854 |
if (statsPtr->srcCount[i] > 0) {
break; /* maxSizeDecade to consume 'i' value
* below... */
}
}
maxSizeDecade = i;
sum = 0;
for (ui = minSizeDecade; ui <= maxSizeDecade; ui++) {
decadeHigh = (1 << (ui+1)) - 1;
sum += statsPtr->srcCount[ui];
Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n");
Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n");
minSizeDecade = maxSizeDecade = 0;
|
| ︙ | ︙ | |||
9805 9806 9807 9808 9809 9810 9811 |
if (statsPtr->byteCodeCount[i] > 0) {
break; /* maxSizeDecade to consume 'i' value
* below... */
}
}
maxSizeDecade = i;
sum = 0;
| | | | | 9862 9863 9864 9865 9866 9867 9868 9869 9870 9871 9872 9873 9874 9875 9876 9877 9878 |
if (statsPtr->byteCodeCount[i] > 0) {
break; /* maxSizeDecade to consume 'i' value
* below... */
}
}
maxSizeDecade = i;
sum = 0;
for (ui = minSizeDecade; ui <= maxSizeDecade; i++) {
decadeHigh = (1 << (ui+1)) - 1;
sum += statsPtr->byteCodeCount[ui];
Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n");
Tcl_AppendPrintfToObj(objPtr, "\t Up to ms\t\tPercentage\n");
minSizeDecade = maxSizeDecade = 0;
|
| ︙ | ︙ | |||
9829 9830 9831 9832 9833 9834 9835 |
if (statsPtr->lifetimeCount[i] > 0) {
break; /* maxSizeDecade to consume 'i' value
* below... */
}
}
maxSizeDecade = i;
sum = 0;
| | | | | 9886 9887 9888 9889 9890 9891 9892 9893 9894 9895 9896 9897 9898 9899 9900 9901 9902 |
if (statsPtr->lifetimeCount[i] > 0) {
break; /* maxSizeDecade to consume 'i' value
* below... */
}
}
maxSizeDecade = i;
sum = 0;
for (ui = minSizeDecade; ui <= maxSizeDecade; ui++) {
decadeHigh = (1 << (ui+1)) - 1;
sum += statsPtr->lifetimeCount[ui];
Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n",
decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed));
}
/*
* Instruction counts.
*/
|
| ︙ | ︙ |
Changes to generic/tclIOGT.c.
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
{
Tcl_Obj *resObj; /* See below, switch (transmit). */
Tcl_Size resLen = 0;
unsigned char *resBuf;
Tcl_InterpState state = NULL;
int res = TCL_OK;
Tcl_Obj *command = TclDuplicatePureObj(
| | | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 |
{
Tcl_Obj *resObj; /* See below, switch (transmit). */
Tcl_Size resLen = 0;
unsigned char *resBuf;
Tcl_InterpState state = NULL;
int res = TCL_OK;
Tcl_Obj *command = TclDuplicatePureObj(
interp, dataPtr->command, &tclListType);
if (!command) {
return TCL_ERROR;
}
Tcl_Interp *eval = dataPtr->interp;
Tcl_Preserve(eval);
|
| ︙ | ︙ |
Changes to generic/tclIORChan.c.
| ︙ | ︙ | |||
2257 2258 2259 2260 2261 2262 2263 |
rcPtr->writeTimer = 0;
#if TCL_THREADS
rcPtr->thread = Tcl_GetCurrentThread();
#endif
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
| | | 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 |
rcPtr->writeTimer = 0;
#if TCL_THREADS
rcPtr->thread = Tcl_GetCurrentThread();
#endif
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
rcPtr->cmd = TclDuplicatePureObj(interp, cmdpfxObj, &tclListType);
if (!rcPtr->cmd) {
return NULL;
}
Tcl_IncrRefCount(rcPtr->cmd);
rcPtr->methods = Tcl_NewListObj(METH_WRITE + 1, NULL);
while (mn <= (int)METH_WRITE) {
Tcl_ListObjAppendElement(NULL, rcPtr->methods,
|
| ︙ | ︙ | |||
2397 2398 2399 2400 2401 2402 2403 |
}
/*
* Insert method into the callback command, after the command prefix,
* before the channel id.
*/
| | | 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 |
}
/*
* Insert method into the callback command, after the command prefix,
* before the channel id.
*/
cmd = TclDuplicatePureObj(NULL, rcPtr->cmd, &tclListType);
if (!cmd) {
return TCL_ERROR;
}
Tcl_ListObjIndex(NULL, rcPtr->methods, method, &methObj);
Tcl_ListObjAppendElement(NULL, cmd, methObj);
Tcl_ListObjAppendElement(NULL, cmd, rcPtr->name);
|
| ︙ | ︙ |
Changes to generic/tclIOUtil.c.
| ︙ | ︙ | |||
1683 1684 1685 1686 1687 1688 1689 |
Tcl_Obj *pathPtr, /* Pathname of the file to process.
* Tilde-substitution is performed on this
* pathname. */
const char *encodingName) /* Either the name of an encoding or NULL to
use the utf-8 encoding. */
{
Tcl_Size length;
| | | 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 |
Tcl_Obj *pathPtr, /* Pathname of the file to process.
* Tilde-substitution is performed on this
* pathname. */
const char *encodingName) /* Either the name of an encoding or NULL to
use the utf-8 encoding. */
{
Tcl_Size length;
int result = TCL_ERROR;
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile;
Interp *iPtr;
const char *string;
Tcl_Channel chan;
Tcl_Obj *objPtr;
|
| ︙ | ︙ |
Changes to generic/tclIndexObj.c.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | const Tcl_ArgvInfo *argTable); /* * The structure below defines the index Tcl object type by means of functions * that can be invoked by generic object code. */ | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
const Tcl_ArgvInfo *argTable);
/*
* The structure below defines the index Tcl object type by means of functions
* that can be invoked by generic object code.
*/
const Tcl_ObjType tclIndexType = {
"index", /* name */
FreeIndex, /* freeIntRepProc */
DupIndex, /* dupIntRepProc */
UpdateStringOfIndex, /* updateStringProc */
NULL, /* setFromAnyProc */
TCL_OBJTYPE_V0
};
|
| ︙ | ︙ | |||
209 210 211 212 213 214 215 |
return TclIndexInvalidError(interp, "struct offset", offset);
}
/*
* See if there is a valid cached result from a previous lookup.
*/
if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) {
| | | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 |
return TclIndexInvalidError(interp, "struct offset", offset);
}
/*
* See if there is a valid cached result from a previous lookup.
*/
if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) {
irPtr = TclFetchInternalRep(objPtr, &tclIndexType);
if (irPtr) {
indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
if ((indexRep->tablePtr == tablePtr)
&& (indexRep->offset == offset)
&& (indexRep->index != TCL_INDEX_NONE)) {
index = indexRep->index;
goto uncachedDone;
|
| ︙ | ︙ | |||
278 279 280 281 282 283 284 |
/*
* 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 (objPtr && (index != TCL_INDEX_NONE) && !(flags & TCL_INDEX_TEMP_TABLE)) {
| | | | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 |
/*
* 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 (objPtr && (index != TCL_INDEX_NONE) && !(flags & TCL_INDEX_TEMP_TABLE)) {
irPtr = TclFetchInternalRep(objPtr, &tclIndexType);
if (irPtr) {
indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
} else {
Tcl_ObjInternalRep ir;
indexRep = (IndexRep*)Tcl_Alloc(sizeof(IndexRep));
ir.twoPtrValue.ptr1 = indexRep;
Tcl_StoreInternalRep(objPtr, &tclIndexType, &ir);
}
indexRep->tablePtr = (void *) tablePtr;
indexRep->offset = offset;
indexRep->index = index;
}
uncachedDone:
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 |
*----------------------------------------------------------------------
*/
static void
UpdateStringOfIndex(
Tcl_Obj *objPtr)
{
| | | 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 |
*----------------------------------------------------------------------
*/
static void
UpdateStringOfIndex(
Tcl_Obj *objPtr)
{
IndexRep *indexRep = (IndexRep *)TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1;
const char *indexStr = EXPAND_OF(indexRep);
Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr));
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
413 414 415 416 417 418 419 |
DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
Tcl_ObjInternalRep ir;
IndexRep *dupIndexRep = (IndexRep *)Tcl_Alloc(sizeof(IndexRep));
| | | | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 |
DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
Tcl_ObjInternalRep ir;
IndexRep *dupIndexRep = (IndexRep *)Tcl_Alloc(sizeof(IndexRep));
memcpy(dupIndexRep, TclFetchInternalRep(srcPtr, &tclIndexType)->twoPtrValue.ptr1,
sizeof(IndexRep));
ir.twoPtrValue.ptr1 = dupIndexRep;
Tcl_StoreInternalRep(dupPtr, &tclIndexType, &ir);
}
/*
*----------------------------------------------------------------------
*
* FreeIndex --
*
|
| ︙ | ︙ | |||
441 442 443 444 445 446 447 |
*----------------------------------------------------------------------
*/
static void
FreeIndex(
Tcl_Obj *objPtr)
{
| | | 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
*----------------------------------------------------------------------
*/
static void
FreeIndex(
Tcl_Obj *objPtr)
{
Tcl_Free(TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* TclInitPrefixCmd --
|
| ︙ | ︙ | |||
861 862 863 864 865 866 867 |
for (i=0 ; i<toPrint ; i++) {
/*
* Add the element, quoting it if necessary.
*/
const Tcl_ObjInternalRep *irPtr;
| | | 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 |
for (i=0 ; i<toPrint ; i++) {
/*
* Add the element, quoting it if necessary.
*/
const Tcl_ObjInternalRep *irPtr;
if ((irPtr = TclFetchInternalRep(origObjv[i], &tclIndexType))) {
IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
} else {
elementStr = Tcl_GetStringFromObj(origObjv[i], &elemLen);
}
|
| ︙ | ︙ | |||
908 909 910 911 912 913 914 | /* * 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_ObjInternalRep *irPtr; | | | 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 |
/*
* 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_ObjInternalRep *irPtr;
if ((irPtr = TclFetchInternalRep(objv[i], &tclIndexType))) {
IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
} else {
/*
* Quote the argument if it contains spaces (Bug 942757).
*/
|
| ︙ | ︙ | |||
1357 1358 1359 1360 1361 1362 1363 |
Tcl_Obj *value,
int *codePtr) /* Argument objects. */
{
static const char *const returnCodes[] = {
"ok", "error", "return", "break", "continue", NULL
};
| | | 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 |
Tcl_Obj *value,
int *codePtr) /* Argument objects. */
{
static const char *const returnCodes[] = {
"ok", "error", "return", "break", "continue", NULL
};
if (!TclHasInternalRep(value, &tclIndexType)
&& TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) {
return TCL_OK;
}
if (Tcl_GetIndexFromObjStruct(NULL, value, returnCodes,
sizeof(char *), NULL, TCL_EXACT, codePtr) == TCL_OK) {
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
1079 1080 1081 1082 1083 1084 1085 | * - passed to Tcl_CreateObjTrace to set up * "leavestep" traces. */ #define TCL_TRACE_ENTER_EXEC 1 #define TCL_TRACE_LEAVE_EXEC 2 | > > > > > > > > > > | | > | | > | > > | > | | > > > > | > > | > > > > > > > > > | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 |
* - passed to Tcl_CreateObjTrace to set up
* "leavestep" traces.
*/
#define TCL_TRACE_ENTER_EXEC 1
#define TCL_TRACE_LEAVE_EXEC 2
#if TCL_MAJOR_VERSION > 8
/*
* Versions 0, 1, and 2 are currently supported concurrently for now
*/
#define TclObjTypeHasProc(objPtr, proc) \
(((objPtr)->typePtr \
&& ( (objPtr)->typePtr->version == 1 \
|| (objPtr)->typePtr->version == 2)) \
? ((objPtr)->typePtr)->proc \
: NULL)
MODULE_SCOPE Tcl_Size TclLengthOne(Tcl_Obj *);
/*
* Abstract List
*
* This structure provides the functions used in List operations to emulate a
* List for AbstractList types.
*/
static inline Tcl_Size
TclObjTypeLength(Tcl_Obj *objPtr)
{
Tcl_ObjTypeLengthProc *proc = TclObjTypeHasProc(objPtr, lengthProc);
return proc(objPtr);
}
static inline int
TclObjTypeIndex(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size index,
Tcl_Obj **elemObjPtr)
{
Tcl_ObjTypeIndexProc *proc = TclObjTypeHasProc(objPtr, indexProc);
return proc(interp, objPtr, index, elemObjPtr);
}
static inline int
TclObjTypeSlice(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size fromIdx,
Tcl_Size toIdx,
Tcl_Obj **newObjPtr)
{
Tcl_ObjTypeSliceProc *proc = TclObjTypeHasProc(objPtr, sliceProc);
return proc(interp, objPtr, fromIdx, toIdx, newObjPtr);
}
static inline int
TclObjTypeReverse(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Obj **newObjPtr)
{
Tcl_ObjTypeReverseProc *proc = TclObjTypeHasProc(objPtr, reverseProc);
return proc(interp, objPtr, newObjPtr);
}
static inline int
TclObjTypeGetElements(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size *objCPtr,
Tcl_Obj ***objVPtr)
{
Tcl_ObjTypeGetElements *proc = TclObjTypeHasProc(objPtr, getElementsProc);
return proc(interp, objPtr, objCPtr, objVPtr);
}
static inline Tcl_Obj*
TclObjTypeSetElement(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size indexCount,
Tcl_Obj *const indexArray[],
Tcl_Obj *valueObj)
{
Tcl_ObjTypeSetElement *proc = TclObjTypeHasProc(objPtr, setElementProc);
return proc(interp, objPtr, indexCount, indexArray, valueObj);
}
static inline int
TclObjTypeReplace(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
Tcl_Size first,
Tcl_Size numToDelete,
Tcl_Size numToInsert,
Tcl_Obj *const insertObjs[])
{
Tcl_ObjTypeReplaceProc *proc = TclObjTypeHasProc(objPtr, replaceProc);
return proc(interp, objPtr, first, numToDelete, numToInsert, insertObjs);
}
#endif /* TCL_MAJOR_VERSION > 8 */
/*
* The structure below defines an entry in the assocData hash table which is
* associated with an interpreter. The entry contains a pointer to a function
* to call when the interpreter is deleted, and a pointer to a user-defined
* piece of data.
*/
|
| ︙ | ︙ | |||
2606 2607 2608 2609 2610 2611 2612 | /* * Converts the Tcl_Obj to a list if it isn't one and stores the element * count and base address of this list's elements in objcPtr_ and objvPtr_. * Return TCL_OK on success or TCL_ERROR if the Tcl_Obj cannot be * converted to a list. */ #define TclListObjGetElementsM(interp_, listObj_, objcPtr_, objvPtr_) \ | | | | | | | | | | | | | | 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 |
/*
* Converts the Tcl_Obj to a list if it isn't one and stores the element
* count and base address of this list's elements in objcPtr_ and objvPtr_.
* Return TCL_OK on success or TCL_ERROR if the Tcl_Obj cannot be
* converted to a list.
*/
#define TclListObjGetElementsM(interp_, listObj_, objcPtr_, objvPtr_) \
(((listObj_)->typePtr == &tclListType) \
? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \
TCL_OK) \
: Tcl_ListObjGetElements( \
(interp_), (listObj_), (objcPtr_), (objvPtr_)))
/*
* Converts the Tcl_Obj to a list if it isn't one and stores the element
* count in lenPtr_. Returns TCL_OK on success or TCL_ERROR if the
* Tcl_Obj cannot be converted to a list.
*/
#define TclListObjLengthM(interp_, listObj_, lenPtr_) \
(((listObj_)->typePtr == &tclListType) \
? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \
: Tcl_ListObjLength((interp_), (listObj_), (lenPtr_)))
#define TclListObjIsCanonical(listObj_) \
(((listObj_)->typePtr == &tclListType) ? ListObjIsCanonical((listObj_)) : 0)
/*
* Modes for collecting (or not) in the implementations of TclNRForeachCmd,
* TclNRLmapCmd and their compilations.
*/
#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.
*
* WARNING: these macros eval their args more than once.
*/
#if TCL_MAJOR_VERSION > 8
#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
(((objPtr)->typePtr == &tclIntType \
|| (objPtr)->typePtr == &tclBooleanType) \
? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
: Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
#else
#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
: ((objPtr)->typePtr == &tclBooleanType) \
? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
: Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
#endif
#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetLongFromObj(interp, objPtr, longPtr) \
(((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
#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) \
: Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
((((objPtr)->typePtr == &tclIntType) && ((objPtr)->internalRep.wideValue >= 0) \
&& ((objPtr)->internalRep.wideValue <= endValue)) \
? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
/*
* 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);
*/
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(wideIntPtr) = \
((objPtr)->internalRep.wideValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
/*
* Flag values for TclTraceDictPath().
*
|
| ︙ | ︙ | |||
2966 2967 2968 2969 2970 2971 2972 | MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr; MODULE_SCOPE void *tclTimeClientData; /* * Variables denoting the Tcl object types defined in the core. */ | | | | | | | | 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 | MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr; MODULE_SCOPE void *tclTimeClientData; /* * Variables denoting the Tcl object types defined in the core. */ MODULE_SCOPE const Tcl_ObjType tclBignumType; MODULE_SCOPE const Tcl_ObjType tclBooleanType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; MODULE_SCOPE const Tcl_ObjType tclIntType; MODULE_SCOPE const Tcl_ObjType tclIndexType; 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 tclEnsembleCmdType; MODULE_SCOPE const Tcl_ObjType tclRegexpType; MODULE_SCOPE Tcl_ObjType tclCmdNameType; |
| ︙ | ︙ | |||
3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 | MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE void TclUndoRefCount(Tcl_Obj *objPtr); 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, Tcl_Size len); MODULE_SCOPE void TclpAlertNotifier(void *clientData); MODULE_SCOPE void *TclpNotifierData(void); MODULE_SCOPE void TclpServiceModeHook(int mode); MODULE_SCOPE void TclpSetTimer(const Tcl_Time *timePtr); MODULE_SCOPE int TclpWaitForEvent(const Tcl_Time *timePtr); | > > > | 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 |
MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp,
int code, int level, Tcl_Obj *returnOpts);
MODULE_SCOPE void TclUndoRefCount(Tcl_Obj *objPtr);
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 int TclNewArithSeriesObj(Tcl_Interp *interp, Tcl_Obj **arithSeriesPtr,
int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj,
Tcl_Obj *stepObj, Tcl_Obj *lenObj);
MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep,
Tcl_Size len);
MODULE_SCOPE void TclpAlertNotifier(void *clientData);
MODULE_SCOPE void *TclpNotifierData(void);
MODULE_SCOPE void TclpServiceModeHook(int mode);
MODULE_SCOPE void TclpSetTimer(const Tcl_Time *timePtr);
MODULE_SCOPE int TclpWaitForEvent(const Tcl_Time *timePtr);
|
| ︙ | ︙ | |||
4880 4881 4882 4883 4884 4885 4886 | */ MODULE_SCOPE Tcl_LibraryInitProc TclplatformtestInit; MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init; MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; | | | 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 | */ MODULE_SCOPE Tcl_LibraryInitProc TclplatformtestInit; MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init; MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init; /* *---------------------------------------------------------------- * Macro used by the Tcl core to check whether a pattern has any characters * special to [string match]. The ANSI C "prototype" for this macro is: * |
| ︙ | ︙ | |||
4912 4913 4914 4915 4916 4917 4918 |
*/
#define TclSetIntObj(objPtr, i) \
do { \
Tcl_ObjInternalRep ir; \
ir.wideValue = (Tcl_WideInt) i; \
TclInvalidateStringRep(objPtr); \
| | | | 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 |
*/
#define TclSetIntObj(objPtr, i) \
do { \
Tcl_ObjInternalRep ir; \
ir.wideValue = (Tcl_WideInt) i; \
TclInvalidateStringRep(objPtr); \
Tcl_StoreInternalRep(objPtr, &tclIntType, &ir); \
} while (0)
#define TclSetDoubleObj(objPtr, d) \
do { \
Tcl_ObjInternalRep ir; \
ir.doubleValue = (double) d; \
TclInvalidateStringRep(objPtr); \
Tcl_StoreInternalRep(objPtr, &tclDoubleType, &ir); \
} 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:
|
| ︙ | ︙ | |||
4945 4946 4947 4948 4949 4950 4951 |
#define TclNewIntObj(objPtr, w) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
(objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
| | | | | 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 |
#define TclNewIntObj(objPtr, w) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
(objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
(objPtr)->typePtr = &tclIntType; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#define TclNewUIntObj(objPtr, uw) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
Tcl_WideUInt uw_ = (uw); \
if (uw_ > WIDE_MAX) { \
mp_int bignumValue_; \
if (mp_init_u64(&bignumValue_, uw_) != MP_OKAY) { \
Tcl_Panic("%s: memory overflow", "TclNewUIntObj"); \
} \
TclSetBignumInternalRep((objPtr), &bignumValue_); \
} else { \
(objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_); \
(objPtr)->typePtr = &tclIntType; \
} \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#define TclNewIndexObj(objPtr, w) \
TclNewIntObj(objPtr, w)
#define TclNewDoubleObj(objPtr, d) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
(objPtr)->internalRep.doubleValue = (double)(d); \
(objPtr)->typePtr = &tclDoubleType; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#define TclNewStringObj(objPtr, s, len) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
|
| ︙ | ︙ |
Changes to generic/tclLink.c.
| ︙ | ︙ | |||
535 536 537 538 539 540 541 |
Tcl_Obj *objPtr,
double *dblPtr)
{
if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) {
return 0;
} else {
#ifdef ACCEPT_NAN
| | | 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 |
Tcl_Obj *objPtr,
double *dblPtr)
{
if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) {
return 0;
} else {
#ifdef ACCEPT_NAN
Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclDoubleType);
if (irPtr != NULL) {
*dblPtr = irPtr->doubleValue;
return 0;
}
#endif /* ACCEPT_NAN */
return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK;
|
| ︙ | ︙ |
Changes to generic/tclListObj.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include <assert.h> #include "tclInt.h" #include "tclTomMath.h" | < | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include <assert.h> #include "tclInt.h" #include "tclTomMath.h" /* * TODO - memmove is fast. Measure at what size we should prefer memmove * (for unshared objects only) in lieu of range operations. On the other * hand, more cache dirtied? */ |
| ︙ | ︙ | |||
65 66 67 68 69 70 71 | #define LIST_INDEX_ASSERT(idx_) ((void) 0) #define LIST_COUNT_ASSERT(count_) ((void) 0) #endif /* Checks for when caller should have already converted to internal list type */ #define LIST_ASSERT_TYPE(listObj_) \ | | | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 |
#define LIST_INDEX_ASSERT(idx_) ((void) 0)
#define LIST_COUNT_ASSERT(count_) ((void) 0)
#endif
/* Checks for when caller should have already converted to internal list type */
#define LIST_ASSERT_TYPE(listObj_) \
LIST_ASSERT(TclHasInternalRep((listObj_), &tclListType))
/*
* If ENABLE_LIST_INVARIANTS is enabled (-DENABLE_LIST_INVARIANTS from the
* command line), the entire list internal representation is checked for
* inconsistencies. This has a non-trivial cost so has to be separately
* enabled and not part of assertions checking. However, the test suite does
* invoke ListRepValidate directly even without ENABLE_LIST_INVARIANTS.
|
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
#define LISTREP_SPACE_FLAGS \
(LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK \
| LISTREP_SPACE_ONLY_BACK)
/*
* Prototypes for non-inline static functions defined later in this file:
*/
| | | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
#define LISTREP_SPACE_FLAGS \
(LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK \
| LISTREP_SPACE_ONLY_BACK)
/*
* Prototypes for non-inline static functions defined later in this file:
*/
static int MemoryAllocationError(Tcl_Interp *, size_t size);
static int ListLimitExceededError(Tcl_Interp *);
static ListStore *ListStoreNew(Tcl_Size objc, Tcl_Obj *const objv[], int flags);
static int ListRepInit(Tcl_Size objc, Tcl_Obj *const objv[], int flags, ListRep *);
static int ListRepInitAttempt(Tcl_Interp *,
Tcl_Size objc,
Tcl_Obj *const objv[],
ListRep *);
|
| ︙ | ︙ | |||
147 148 149 150 151 152 153 | /* * The structure below defines the list Tcl object type by means of functions * that can be invoked by generic object code. * * The internal representation of a list object is ListRep defined in tcl.h. */ | | | | < < | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
/*
* The structure below defines the list Tcl object type by means of functions
* that can be invoked by generic object code.
*
* The internal representation of a list object is ListRep defined in tcl.h.
*/
const Tcl_ObjType tclListType = {
"list", /* name */
FreeListInternalRep, /* freeIntRepProc */
DupListInternalRep, /* dupIntRepProc */
UpdateStringOfList, /* updateStringProc */
SetListFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V1(ListLength)
};
/* Macros to manipulate the List internal rep */
#define ListRepIncrRefs(repPtr_) \
do { \
(repPtr_)->storePtr->refCount++; \
if ((repPtr_)->spanPtr) \
|
| ︙ | ︙ | |||
201 202 203 204 205 206 207 |
* passed ListRep) and frees it first. Additionally invalidates the string
* representation. Generally used when modifying a Tcl_Obj value.
*/
#define ListObjStompRep(objPtr_, repPtr_) \
do { \
(objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \
(objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \
| | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 |
* passed ListRep) and frees it first. Additionally invalidates the string
* representation. Generally used when modifying a Tcl_Obj value.
*/
#define ListObjStompRep(objPtr_, repPtr_) \
do { \
(objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \
(objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \
(objPtr_)->typePtr = &tclListType; \
} while (0)
#define ListObjOverwriteRep(objPtr_, repPtr_) \
do { \
ListRepIncrRefs(repPtr_); \
ListObjStompRep(objPtr_, repPtr_); \
} while (0)
|
| ︙ | ︙ | |||
344 345 346 347 348 349 350 |
*
*------------------------------------------------------------------------
*/
static inline void
ListRepFreeUnreferenced(const ListRep *repPtr)
{
if (! ListRepIsShared(repPtr) && repPtr->spanPtr) {
| | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 |
*
*------------------------------------------------------------------------
*/
static inline void
ListRepFreeUnreferenced(const ListRep *repPtr)
{
if (! ListRepIsShared(repPtr) && repPtr->spanPtr) {
/* T:listrep-1.5.1 */
ListRepUnsharedFreeUnreferenced(repPtr);
}
}
/*
*------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
370 371 372 373 374 375 376 |
*/
static inline void
ObjArrayIncrRefs(
Tcl_Obj * const *objv, /* Pointer to the array */
Tcl_Size startIdx, /* Starting index of subarray within objv */
Tcl_Size count) /* Number of elements in the subarray */
{
| | | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 |
*/
static inline void
ObjArrayIncrRefs(
Tcl_Obj * const *objv, /* Pointer to the array */
Tcl_Size startIdx, /* Starting index of subarray within objv */
Tcl_Size count) /* Number of elements in the subarray */
{
Tcl_Obj *const *end;
LIST_INDEX_ASSERT(startIdx);
LIST_COUNT_ASSERT(count);
objv += startIdx;
end = objv + count;
while (objv < end) {
Tcl_IncrRefCount(*objv);
++objv;
|
| ︙ | ︙ | |||
462 463 464 465 466 467 468 |
* Error message and code are stored in the interpreter if not NULL.
*
*------------------------------------------------------------------------
*/
static int
MemoryAllocationError(
Tcl_Interp *interp, /* Interpreter for error message. May be NULL */
| | | | | 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 |
* Error message and code are stored in the interpreter if not NULL.
*
*------------------------------------------------------------------------
*/
static int
MemoryAllocationError(
Tcl_Interp *interp, /* Interpreter for error message. May be NULL */
size_t size) /* Size of attempted allocation that failed */
{
if (interp != NULL) {
Tcl_SetObjResult(
interp,
Tcl_ObjPrintf(
"list construction failed: unable to alloc %" TCL_Z_MODIFIER
"u bytes",
size));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return TCL_ERROR;
}
/*
*------------------------------------------------------------------------
|
| ︙ | ︙ | |||
641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 |
condition = #cond_; \
goto failure; \
} \
} while (0)
/* Separate each condition so line number gives exact reason for failure */
INVARIANT(storePtr != NULL);
INVARIANT(storePtr->numAllocated <= LIST_MAX);
INVARIANT(storePtr->firstUsed < storePtr->numAllocated);
INVARIANT(storePtr->numUsed <= storePtr->numAllocated);
INVARIANT(storePtr->firstUsed <= (storePtr->numAllocated - storePtr->numUsed));
if (! ListRepIsShared(repPtr)) {
/*
* If this is the only reference and there is no span, then store
* occupancy must begin at 0
| > > > | 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 |
condition = #cond_; \
goto failure; \
} \
} while (0)
/* Separate each condition so line number gives exact reason for failure */
INVARIANT(storePtr != NULL);
INVARIANT(storePtr->numAllocated >= 0);
INVARIANT(storePtr->numAllocated <= LIST_MAX);
INVARIANT(storePtr->firstUsed >= 0);
INVARIANT(storePtr->firstUsed < storePtr->numAllocated);
INVARIANT(storePtr->numUsed >= 0);
INVARIANT(storePtr->numUsed <= storePtr->numAllocated);
INVARIANT(storePtr->firstUsed <= (storePtr->numAllocated - storePtr->numUsed));
if (! ListRepIsShared(repPtr)) {
/*
* If this is the only reference and there is no span, then store
* occupancy must begin at 0
|
| ︙ | ︙ | |||
753 754 755 756 757 758 759 |
} else {
/* Exact allocation */
capacity = objc;
storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity));
}
if (storePtr == NULL) {
if (flags & LISTREP_PANIC_ON_FAIL) {
| | | | | 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 |
} else {
/* Exact allocation */
capacity = objc;
storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity));
}
if (storePtr == NULL) {
if (flags & LISTREP_PANIC_ON_FAIL) {
Tcl_Panic("list creation failed: unable to alloc %" TCL_SIZE_MODIFIER
"d bytes",
LIST_SIZE(objc));
}
return NULL;
}
storePtr->refCount = 0;
storePtr->flags = 0;
storePtr->numAllocated = capacity;
|
| ︙ | ︙ | |||
832 833 834 835 836 837 838 |
&capacity);
/* Only the capacity has changed, fix it in the header */
if (storePtr) {
storePtr->numAllocated = capacity;
}
return storePtr;
}
| | | 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 |
&capacity);
/* Only the capacity has changed, fix it in the header */
if (storePtr) {
storePtr->numAllocated = capacity;
}
return storePtr;
}
/*
*----------------------------------------------------------------------
*
* ListRepInit --
*
* Initializes a ListRep to hold a list internal representation
* with space for objc elements.
|
| ︙ | ︙ | |||
1009 1010 1011 1012 1013 1014 1015 |
return;
}
/* Collect garbage at front */
count = spanPtr->spanStart - storePtr->firstUsed;
LIST_COUNT_ASSERT(count);
if (count > 0) {
| | | | 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 |
return;
}
/* Collect garbage at front */
count = spanPtr->spanStart - storePtr->firstUsed;
LIST_COUNT_ASSERT(count);
if (count > 0) {
/* T:listrep-1.5.1,6.{1:8} */
ObjArrayDecrRefs(storePtr->slots, storePtr->firstUsed, count);
storePtr->firstUsed = spanPtr->spanStart;
LIST_ASSERT(storePtr->numUsed >= count);
storePtr->numUsed -= count;
}
/* Collect garbage at back */
count = (storePtr->firstUsed + storePtr->numUsed)
- (spanPtr->spanStart + spanPtr->spanLength);
LIST_COUNT_ASSERT(count);
if (count > 0) {
/* T:listrep-6.{1:8} */
ObjArrayDecrRefs(
storePtr->slots, spanPtr->spanStart + spanPtr->spanLength, count);
LIST_ASSERT(storePtr->numUsed >= count);
storePtr->numUsed -= count;
}
LIST_ASSERT(ListRepStart(repPtr) == storePtr->firstUsed);
|
| ︙ | ︙ | |||
1082 1083 1084 1085 1086 1087 1088 |
Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
ListRep listRep;
Tcl_Obj *listObj;
TclNewObj(listObj);
| | | 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 |
Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
ListRep listRep;
Tcl_Obj *listObj;
TclNewObj(listObj);
if (objc <= 0) {
return listObj;
}
ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
ListObjReplaceRepAndInvalidate(listObj, &listRep);
return listObj;
|
| ︙ | ︙ | |||
1138 1139 1140 1141 1142 1143 1144 |
* debugging. */
{
Tcl_Obj *listObj;
ListRep listRep;
TclDbNewObj(listObj, file, line);
| | | 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 |
* debugging. */
{
Tcl_Obj *listObj;
ListRep listRep;
TclDbNewObj(listObj, file, line);
if (objc <= 0) {
return listObj;
}
ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
ListObjReplaceRepAndInvalidate(listObj, &listRep);
return listObj;
|
| ︙ | ︙ | |||
1247 1248 1249 1250 1251 1252 1253 |
static int
TclListObjGetRep(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listObj, /* List object for which an element array is
* to be returned. */
ListRep *repPtr) /* Location to store descriptor */
{
| | | 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 |
static int
TclListObjGetRep(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listObj, /* List object for which an element array is
* to be returned. */
ListRep *repPtr) /* Location to store descriptor */
{
if (!TclHasInternalRep(listObj, &tclListType)) {
int result;
result = SetListFromAny(interp, listObj);
if (result != TCL_OK) {
/* Init to keep gcc happy wrt uninitialized fields at call site */
repPtr->storePtr = NULL;
repPtr->spanPtr = NULL;
return result;
|
| ︙ | ︙ | |||
1300 1301 1302 1303 1304 1305 1306 |
/*
* Set the object's type to "list" and initialize the internal rep.
* However, if there are no elements to put in the list, just give the
* object an empty string rep and a NULL type. NOTE ListRepInit must
* not be called with objc == 0!
*/
| | | 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 |
/*
* Set the object's type to "list" and initialize the internal rep.
* However, if there are no elements to put in the list, just give the
* object an empty string rep and a NULL type. NOTE ListRepInit must
* not be called with objc == 0!
*/
if (objc > 0) {
ListRep listRep;
/* TODO - perhaps ask for extra space? */
ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
ListObjReplaceRepAndInvalidate(objPtr, &listRep);
} else {
TclFreeInternalRep(objPtr);
TclInvalidateStringRep(objPtr);
|
| ︙ | ︙ | |||
1359 1360 1361 1362 1363 1364 1365 |
Tcl_Size numAfterRangeEnd;
LISTREP_CHECK(srcRepPtr);
/* Take the opportunity to garbage collect */
/* TODO - we probably do not need the preserveSrcRep here unlike later */
if (!preserveSrcRep) {
| | | 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 |
Tcl_Size numAfterRangeEnd;
LISTREP_CHECK(srcRepPtr);
/* Take the opportunity to garbage collect */
/* TODO - we probably do not need the preserveSrcRep here unlike later */
if (!preserveSrcRep) {
/* T:listrep-1.{4,5,8,9},2.{4:7},3.{15:18},4.{7,8} */
ListRepFreeUnreferenced(srcRepPtr);
} /* else T:listrep-2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */
if (rangeStart < 0) {
rangeStart = 0;
}
if (rangeEnd >= numSrcElems) {
|
| ︙ | ︙ | |||
1396 1397 1398 1399 1400 1401 1402 |
*
* Note: Even if nothing below cause any changes, we still want the
* string-canonizing effect of [lrange 0 end] so the Tcl_Obj should not
* be returned as is even if the range encompasses the whole list.
*/
if (rangeStart == 0 && rangeEnd == (numSrcElems-1)) {
/* Option 0 - entire list. This may be used to canonicalize */
| | | | | | | | | | | | | | 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 |
*
* Note: Even if nothing below cause any changes, we still want the
* string-canonizing effect of [lrange 0 end] so the Tcl_Obj should not
* be returned as is even if the range encompasses the whole list.
*/
if (rangeStart == 0 && rangeEnd == (numSrcElems-1)) {
/* Option 0 - entire list. This may be used to canonicalize */
/* T:listrep-1.10.1,2.8.1 */
*rangeRepPtr = *srcRepPtr; /* Not ref counts not incremented */
} else if (rangeStart == 0 && (!preserveSrcRep)
&& (!ListRepIsShared(srcRepPtr) && srcRepPtr->spanPtr == NULL)) {
/* Option 1 - Special case unshared, exclude end elements, no span */
LIST_ASSERT(srcRepPtr->storePtr->firstUsed == 0); /* If no span */
ListRepElements(srcRepPtr, numSrcElems, srcElems);
numAfterRangeEnd = numSrcElems - (rangeEnd + 1);
/* Assert: Because numSrcElems > rangeEnd earlier */
if (numAfterRangeEnd != 0) {
/* T:listrep-1.{8,9} */
ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd);
}
/* srcRepPtr->storePtr->firstUsed,numAllocated unchanged */
srcRepPtr->storePtr->numUsed = rangeLen;
srcRepPtr->storePtr->flags = 0;
rangeRepPtr->storePtr = srcRepPtr->storePtr; /* Note no incr ref */
rangeRepPtr->spanPtr = NULL;
} else if (ListSpanMerited(rangeLen,
srcRepPtr->storePtr->numUsed,
srcRepPtr->storePtr->numAllocated)) {
/* Option 2 - because span would be most efficient */
Tcl_Size spanStart = ListRepStart(srcRepPtr) + rangeStart;
if (!preserveSrcRep && srcRepPtr->spanPtr
&& srcRepPtr->spanPtr->refCount <= 1) {
/* If span is not shared reuse it */
/* T:listrep-2.7.3,3.{16,18} */
srcRepPtr->spanPtr->spanStart = spanStart;
srcRepPtr->spanPtr->spanLength = rangeLen;
*rangeRepPtr = *srcRepPtr;
} else {
/* Span not present or is shared. */
/* T:listrep-1.5,2.{5,7},4.{7,8} */
rangeRepPtr->storePtr = srcRepPtr->storePtr;
rangeRepPtr->spanPtr = ListSpanNew(spanStart, rangeLen);
}
/*
* We have potentially created a new internal representation that
* references the same storage as srcRep but not yet incremented its
* reference count. So do NOT call freezombies if preserveSrcRep
* is mandated.
*/
if (!preserveSrcRep) {
/* T:listrep-1.{5.1,5.2,5.4},2.{5,7},3.{16,18},4.{7,8} */
ListRepFreeUnreferenced(rangeRepPtr);
}
} else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) {
/* Option 3 - span or modification in place not allowed/desired */
/* T:listrep-2.{4,6} */
ListRepElements(srcRepPtr, numSrcElems, srcElems);
/* TODO - allocate extra space? */
ListRepInit(rangeLen,
&srcElems[rangeStart],
LISTREP_PANIC_ON_FAIL,
rangeRepPtr);
} else {
|
| ︙ | ︙ | |||
1471 1472 1473 1474 1475 1476 1477 |
LIST_ASSERT(ListRepStart(srcRepPtr) == srcRepPtr->storePtr->firstUsed);
LIST_ASSERT(ListRepLength(srcRepPtr) == srcRepPtr->storePtr->numUsed);
ListRepElements(srcRepPtr, numSrcElems, srcElems);
/* Free leading elements outside range */
if (rangeStart != 0) {
| | | | | 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 |
LIST_ASSERT(ListRepStart(srcRepPtr) == srcRepPtr->storePtr->firstUsed);
LIST_ASSERT(ListRepLength(srcRepPtr) == srcRepPtr->storePtr->numUsed);
ListRepElements(srcRepPtr, numSrcElems, srcElems);
/* Free leading elements outside range */
if (rangeStart != 0) {
/* T:listrep-1.4,3.15 */
ObjArrayDecrRefs(srcElems, 0, rangeStart);
}
/* Ditto for trailing */
numAfterRangeEnd = numSrcElems - (rangeEnd + 1);
/* Assert: Because numSrcElems > rangeEnd earlier */
if (numAfterRangeEnd != 0) {
/* T:listrep-3.17 */
ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd);
}
memmove(&srcRepPtr->storePtr->slots[0],
&srcRepPtr->storePtr
->slots[srcRepPtr->storePtr->firstUsed + rangeStart],
rangeLen * sizeof(Tcl_Obj *));
srcRepPtr->storePtr->firstUsed = 0;
srcRepPtr->storePtr->numUsed = rangeLen;
srcRepPtr->storePtr->flags = 0;
if (srcRepPtr->spanPtr) {
/* In case the source has a span, update it for consistency */
/* T:listrep-3.{15,17} */
srcRepPtr->spanPtr->spanStart = srcRepPtr->storePtr->firstUsed;
srcRepPtr->spanPtr->spanLength = srcRepPtr->storePtr->numUsed;
}
rangeRepPtr->storePtr = srcRepPtr->storePtr;
rangeRepPtr->spanPtr = NULL;
}
|
| ︙ | ︙ | |||
1545 1546 1547 1548 1549 1550 1551 |
return NULL;
isShared = Tcl_IsShared(listObj);
ListRepRange(&listRep, rangeStart, rangeEnd, isShared, &resultRep);
if (isShared) {
| | | 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 |
return NULL;
isShared = Tcl_IsShared(listObj);
ListRepRange(&listRep, rangeStart, rangeEnd, isShared, &resultRep);
if (isShared) {
/* T:listrep-1.10.1,2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */
TclNewObj(listObj);
} /* T:listrep-1.{4.3,5.1,5.2} */
ListObjReplaceRepAndInvalidate(listObj, &resultRep);
return listObj;
}
/*
|
| ︙ | ︙ | |||
1618 1619 1620 1621 1622 1623 1624 |
Tcl_Size *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. */
{
ListRep listRep;
| | | < | | > | 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 |
Tcl_Size *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. */
{
ListRep listRep;
if (TclObjTypeHasProc(objPtr, getElementsProc)) {
return TclObjTypeGetElements(interp, objPtr, objcPtr, objvPtr);
}
if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) {
return TCL_ERROR;
}
ListRepElements(&listRep, *objcPtr, *objvPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1762 1763 1764 1765 1766 1767 1768 |
LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen);
/* Current store big enough */
numTailFree = ListRepNumFreeTail(&listRep);
LIST_ASSERT((numTailFree + listRep.storePtr->firstUsed)
>= elemCount); /* Total free */
if (numTailFree < elemCount) {
/* Not enough room at back. Move some to front */
| | | | | | 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 |
LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen);
/* Current store big enough */
numTailFree = ListRepNumFreeTail(&listRep);
LIST_ASSERT((numTailFree + listRep.storePtr->firstUsed)
>= elemCount); /* Total free */
if (numTailFree < elemCount) {
/* Not enough room at back. Move some to front */
/* T:listrep-3.5 */
Tcl_Size shiftCount = elemCount - numTailFree;
/* Divide remaining space between front and back */
shiftCount += (listRep.storePtr->numAllocated - finalLen) / 2;
LIST_ASSERT(shiftCount <= listRep.storePtr->firstUsed);
if (shiftCount) {
/* T:listrep-3.5 */
ListRepUnsharedShiftDown(&listRep, shiftCount);
}
} /* else T:listrep-3.{4,6} */
ObjArrayCopy(&listRep.storePtr->slots[ListRepStart(&listRep)
+ ListRepLength(&listRep)],
elemCount,
elemObjv);
listRep.storePtr->numUsed = finalLen;
if (listRep.spanPtr) {
/* T:listrep-3.{4,5,6} */
LIST_ASSERT(listRep.spanPtr->spanStart
== listRep.storePtr->firstUsed);
listRep.spanPtr->spanLength = finalLen;
} /* else T:listrep-3.6.3 */
LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed);
LIST_ASSERT(ListRepLength(&listRep) == finalLen);
LISTREP_CHECK(&listRep);
|
| ︙ | ︙ | |||
1808 1809 1810 1811 1812 1813 1814 |
&listRep)
!= TCL_OK) {
return MemoryAllocationError(interp, finalLen);
}
LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen);
if (toLen) {
| | | | 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 |
&listRep)
!= TCL_OK) {
return MemoryAllocationError(interp, finalLen);
}
LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen);
if (toLen) {
/* T:listrep-2.{2,9},4.5 */
ObjArrayCopy(ListRepSlotPtr(&listRep, 0), toLen, toObjv);
}
ObjArrayCopy(ListRepSlotPtr(&listRep, toLen), elemCount, elemObjv);
listRep.storePtr->numUsed = finalLen;
if (listRep.spanPtr) {
/* T:listrep-4.5 */
LIST_ASSERT(listRep.spanPtr->spanStart == listRep.storePtr->firstUsed);
listRep.spanPtr->spanLength = finalLen;
}
LISTREP_CHECK(&listRep);
ListObjReplaceRepAndInvalidate(toObj, &listRep);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 |
Tcl_Size numElems;
/* Empty string => empty list. Avoid unnecessary shimmering */
if (listObj->bytes == &tclEmptyString) {
*objPtrPtr = NULL;
return TCL_OK;
}
if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs)
!= TCL_OK) {
return TCL_ERROR;
}
| > > > > > | | 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 |
Tcl_Size numElems;
/* Empty string => empty list. Avoid unnecessary shimmering */
if (listObj->bytes == &tclEmptyString) {
*objPtrPtr = NULL;
return TCL_OK;
}
int hasAbstractList = TclObjTypeHasProc(listObj,indexProc) != 0;
if (hasAbstractList) {
return TclObjTypeIndex(interp, listObj, index, objPtrPtr);
}
if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs)
!= TCL_OK) {
return TCL_ERROR;
}
if ((index < 0) || (index >= numElems)) {
*objPtrPtr = NULL;
} else {
*objPtrPtr = elemObjs[index];
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
1960 1961 1962 1963 1964 1965 1966 |
/* Empty string => empty list. Avoid unnecessary shimmering */
if (listObj->bytes == &tclEmptyString) {
*lenPtr = 0;
return TCL_OK;
}
| < | | | 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 |
/* Empty string => empty list. Avoid unnecessary shimmering */
if (listObj->bytes == &tclEmptyString) {
*lenPtr = 0;
return TCL_OK;
}
if (TclObjTypeHasProc(listObj, lengthProc)) {
*lenPtr = TclObjTypeLength(listObj);
return TCL_OK;
}
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 |
Tcl_Size tailShift;
Tcl_Obj **listObjs;
int favor;
if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK)
return TCL_ERROR; /* Cannot be converted to a list */
/* Make limits sane */
origListLen = ListRepLength(&listRep);
if (first < 0) {
first = 0;
}
if (first > origListLen) {
first = origListLen; /* So we'll insert after last element. */
}
if (numToDelete < 0) {
numToDelete = 0;
} else if (first > LIST_MAX - numToDelete /* Handle integer overflow */
| > > > > > | | 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 |
Tcl_Size tailShift;
Tcl_Obj **listObjs;
int favor;
if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
if (TclObjTypeHasProc(listObj, replaceProc)) {
return TclObjTypeReplace(interp, listObj, first,
numToDelete, numToInsert, insertObjs);
}
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK)
return TCL_ERROR; /* Cannot be converted to a list */
/* Make limits sane */
origListLen = ListRepLength(&listRep);
if (first < 0) {
first = 0;
}
if (first > origListLen) {
first = origListLen; /* So we'll insert after last element. */
}
if (numToDelete < 0) {
numToDelete = 0;
} else if (first > LIST_MAX - numToDelete /* Handle integer overflow */
|| origListLen < first + numToDelete) {
numToDelete = origListLen - first;
}
if (numToInsert > LIST_MAX - (origListLen - numToDelete)) {
return ListLimitExceededError(interp);
}
|
| ︙ | ︙ | |||
2100 2101 2102 2103 2104 2105 2106 |
/* Note: do not do TclInvalidateStringRep as yet in case there are errors */
/* Check Case (1) - Treat pure deletes from front or back as range ops */
if (numToInsert == 0) {
if (numToDelete == 0) {
/*
| | | | | | | | | 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 |
/* Note: do not do TclInvalidateStringRep as yet in case there are errors */
/* Check Case (1) - Treat pure deletes from front or back as range ops */
if (numToInsert == 0) {
if (numToDelete == 0) {
/*
* Should force canonical even for no-op. Remember Tcl_Obj unshared
* so OK to invalidate string rep
*/
/* T:listrep-1.10,2.8 */
TclInvalidateStringRep(listObj);
return TCL_OK;
}
if (first == 0) {
/* Delete from front, so return tail. */
/* T:listrep-1.{4,5},2.{4,5},3.{15,16},4.7 */
ListRep tailRep;
ListRepRange(&listRep, numToDelete, origListLen-1, 0, &tailRep);
ListObjReplaceRepAndInvalidate(listObj, &tailRep);
return TCL_OK;
} else if ((first+numToDelete) >= origListLen) {
/* Delete from tail, so return head */
/* T:listrep-1.{8,9},2.{6,7},3.{17,18},4.8 */
ListRep headRep;
ListRepRange(&listRep, 0, first-1, 0, &headRep);
ListObjReplaceRepAndInvalidate(listObj, &headRep);
return TCL_OK;
}
/* Deletion from middle. Fall through to general case */
}
/* Garbage collect before checking the pure insert optimization */
ListRepFreeUnreferenced(&listRep);
/*
* Check Case (2) - pure inserts under certain conditions:
*/
if (numToDelete == 0) {
/* Case (2a) - Append to list. */
if (first == origListLen) {
/* T:listrep-1.11,2.9,3.{5,6},2.2.1 */
return TclListObjAppendElements(
interp, listObj, numToInsert, insertObjs);
}
/*
* Case (2b) - pure inserts at front under some circumstances
* (i) Insertion must be at head of list
|
| ︙ | ︙ | |||
2161 2162 2163 2164 2165 2166 2167 |
ObjArrayCopy(&listRep.storePtr->slots[listRep.storePtr->firstUsed],
numToInsert,
insertObjs);
listRep.storePtr->numUsed += numToInsert;
newLen = listRep.spanPtr->spanLength + numToInsert;
if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) {
/* An unshared span record, re-use it */
| | | | 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 |
ObjArrayCopy(&listRep.storePtr->slots[listRep.storePtr->firstUsed],
numToInsert,
insertObjs);
listRep.storePtr->numUsed += numToInsert;
newLen = listRep.spanPtr->spanLength + numToInsert;
if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) {
/* An unshared span record, re-use it */
/* T:listrep-3.1 */
listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
listRep.spanPtr->spanLength = newLen;
} else {
/* Need a new span record */
if (listRep.storePtr->firstUsed == 0) {
listRep.spanPtr = NULL;
} else {
/* T:listrep-4.3 */
listRep.spanPtr =
ListSpanNew(listRep.storePtr->firstUsed, newLen);
}
}
ListObjReplaceRepAndInvalidate(listObj, &listRep);
return TCL_OK;
}
|
| ︙ | ︙ | |||
2234 2235 2236 2237 2238 2239 2240 |
listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)];
ListRepInit(origListLen + lenChange,
NULL,
LISTREP_PANIC_ON_FAIL | favor,
&newRep);
toObjs = ListRepSlotPtr(&newRep, 0);
if (leadSegmentLen > 0) {
| | | | | | 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 |
listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)];
ListRepInit(origListLen + lenChange,
NULL,
LISTREP_PANIC_ON_FAIL | favor,
&newRep);
toObjs = ListRepSlotPtr(&newRep, 0);
if (leadSegmentLen > 0) {
/* T:listrep-2.{2,3,13:18},4.{6,9,13:18} */
ObjArrayCopy(toObjs, leadSegmentLen, listObjs);
}
if (numToInsert > 0) {
/* T:listrep-2.{1,2,3,10:18},4.{1,2,4,6,10:18} */
ObjArrayCopy(&toObjs[leadSegmentLen],
numToInsert,
insertObjs);
}
if (tailSegmentLen > 0) {
/* T:listrep-2.{1,2,3,10:15},4.{1,2,4,6,9:12,16:18} */
ObjArrayCopy(&toObjs[leadSegmentLen + numToInsert],
tailSegmentLen,
&listObjs[leadSegmentLen+numToDelete]);
}
newRep.storePtr->numUsed = origListLen + lenChange;
if (newRep.spanPtr) {
/* T:listrep-2.{1,2,3,10:18},4.{1,2,4,6,9:18} */
newRep.spanPtr->spanLength = newRep.storePtr->numUsed;
}
LISTREP_CHECK(&newRep);
ListObjReplaceRepAndInvalidate(listObj, &newRep);
return TCL_OK;
}
|
| ︙ | ︙ | |||
2288 2289 2290 2291 2292 2293 2294 |
* for objects to be inserted in case there is overlap. T:listobj-11.1
*/
if (numToInsert) {
/* T:listrep-1.{1,3,12:21},3.{2,3,7:14,23:41} */
ObjArrayIncrRefs(insertObjs, 0, numToInsert);
}
if (numToDelete) {
| | | 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 |
* for objects to be inserted in case there is overlap. T:listobj-11.1
*/
if (numToInsert) {
/* T:listrep-1.{1,3,12:21},3.{2,3,7:14,23:41} */
ObjArrayIncrRefs(insertObjs, 0, numToInsert);
}
if (numToDelete) {
/* T:listrep-1.{6,7,12:21},3.{19:41} */
ObjArrayDecrRefs(listObjs, first, numToDelete);
}
/*
* TODO - below the moves are optimized but this may result in needing a
* span allocation. Perhaps for small lists, it may be more efficient to
* just move everything up front and save on allocating a span.
|
| ︙ | ︙ | |||
2319 2320 2321 2322 2323 2324 2325 |
} else if (lenChange < 0) {
/*
* More deletions than insertions. The gap after deletions is large
* enough for insertions. Move a segment depending on size.
*/
if (leadSegmentLen > tailSegmentLen) {
/* Tail segment smaller. Insert after lead, move tail down */
| | | | | | | 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 |
} else if (lenChange < 0) {
/*
* More deletions than insertions. The gap after deletions is large
* enough for insertions. Move a segment depending on size.
*/
if (leadSegmentLen > tailSegmentLen) {
/* Tail segment smaller. Insert after lead, move tail down */
/* T:listrep-1.{7,17,20},3.{21,2229,35} */
leadShift = 0;
tailShift = lenChange;
} else {
/* Lead segment smaller. Insert before tail, move lead up */
/* T:listrep-1.{6,13,16},3.{19,20,24,34} */
leadShift = -lenChange;
tailShift = 0;
}
} else {
LIST_ASSERT(lenChange > 0); /* Reminder */
/*
* We need to make room for the insertions. Again we have multiple
* possibilities. We may be able to get by just shifting one segment
* or need to shift both. In the former case, favor shifting the
* smaller segment.
*/
Tcl_Size leadSpace = ListRepNumFreeHead(&listRep);
Tcl_Size tailSpace = ListRepNumFreeTail(&listRep);
Tcl_Size finalFreeSpace = leadSpace + tailSpace - lenChange;
LIST_ASSERT((leadSpace + tailSpace) >= lenChange);
if (leadSpace >= lenChange
&& (leadSegmentLen < tailSegmentLen || tailSpace < lenChange)) {
/* Move only lead to the front to make more room */
/* T:listrep-3.25,36,38, */
leadShift = -lenChange;
tailShift = 0;
/*
* Redistribute the remaining free space between the front and
* back if either there is no tail space left or if the
* entire list is the head anyways. This is an important
* optimization for further operations like further asymmetric
* insertions.
*/
if (finalFreeSpace > 1 && (tailSpace == 0 || tailSegmentLen == 0)) {
Tcl_Size postShiftLeadSpace = leadSpace - lenChange;
if (postShiftLeadSpace > (finalFreeSpace/2)) {
Tcl_Size extraShift = postShiftLeadSpace - (finalFreeSpace / 2);
leadShift -= extraShift;
tailShift = -extraShift; /* Move tail to the front as well */
}
} /* else T:listrep-3.{7,12,25,38} */
LIST_ASSERT(leadShift >= 0 || leadSpace >= -leadShift);
} else if (tailSpace >= lenChange) {
/* Move only tail segment to the back to make more room. */
/* T:listrep-3.{8,10,11,14,26,27,30,32,37,39,41} */
leadShift = 0;
tailShift = lenChange;
/*
* See comments above. This is analogous.
*/
if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) {
Tcl_Size postShiftTailSpace = tailSpace - lenChange;
if (postShiftTailSpace > (finalFreeSpace/2)) {
/* T:listrep-1.{1,3,14,18,21},3.{2,3,26,27} */
Tcl_Size extraShift = postShiftTailSpace - (finalFreeSpace / 2);
tailShift += extraShift;
leadShift = extraShift; /* Move head to the back as well */
}
}
LIST_ASSERT(tailShift <= tailSpace);
} else {
/*
* Both lead and tail need to be shifted to make room.
* Divide remaining free space equally between front and back.
*/
/* T:listrep-3.{9,13,31,40} */
LIST_ASSERT(leadSpace < lenChange);
LIST_ASSERT(tailSpace < lenChange);
/*
* leadShift = leadSpace - (finalFreeSpace/2)
* Thus leadShift <= leadSpace
* Also,
|
| ︙ | ︙ | |||
2420 2421 2422 2423 2424 2425 2426 |
}
}
/* Careful about order of moves! */
if (leadShift > 0) {
/* Will happen when we have to make room at bottom */
if (tailShift != 0 && tailSegmentLen != 0) {
| | | | | | | | | | 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 |
}
}
/* Careful about order of moves! */
if (leadShift > 0) {
/* Will happen when we have to make room at bottom */
if (tailShift != 0 && tailSegmentLen != 0) {
/* T:listrep-1.{1,3,14,18},3.{2,3,26,27} */
Tcl_Size tailStart = leadSegmentLen + numToDelete;
memmove(&listObjs[tailStart + tailShift],
&listObjs[tailStart],
tailSegmentLen * sizeof(Tcl_Obj *));
}
if (leadSegmentLen != 0) {
/* T:listrep-1.{3,6,16,18,21},3.{19,20,34} */
memmove(&listObjs[leadShift],
&listObjs[0],
leadSegmentLen * sizeof(Tcl_Obj *));
}
} else {
if (leadShift != 0 && leadSegmentLen != 0) {
/* T:listrep-3.{7,9,12,13,31,36,38,40} */
memmove(&listObjs[leadShift],
&listObjs[0],
leadSegmentLen * sizeof(Tcl_Obj *));
}
if (tailShift != 0 && tailSegmentLen != 0) {
/* T:listrep-1.{7,17},3.{8:11,13,14,21,22,35,37,39:41} */
Tcl_Size tailStart = leadSegmentLen + numToDelete;
memmove(&listObjs[tailStart + tailShift],
&listObjs[tailStart],
tailSegmentLen * sizeof(Tcl_Obj *));
}
}
if (numToInsert) {
/* Do NOT use ObjArrayCopy here since we have already incr'ed ref counts */
/* T:listrep-1.{1,3,12:21},3.{2,3,7:14,23:41} */
memmove(&listObjs[leadSegmentLen + leadShift],
insertObjs,
numToInsert * sizeof(Tcl_Obj *));
}
listRep.storePtr->firstUsed += leadShift;
listRep.storePtr->numUsed = origListLen + lenChange;
listRep.storePtr->flags = 0;
if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) {
/* An unshared span record, re-use it, even if not required */
/* T:listrep-3.{2,3,7:14},3.{19:41} */
listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
} else {
/* Need a new span record */
if (listRep.storePtr->firstUsed == 0) {
/* T:listrep-1.{7,12,15,17,19,20} */
listRep.spanPtr = NULL;
} else {
/* T:listrep-1.{1,3,6.1,13,14,16,18,21} */
listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed,
listRep.storePtr->numUsed);
}
}
LISTREP_CHECK(&listRep);
ListObjReplaceRepAndInvalidate(listObj, &listRep);
|
| ︙ | ︙ | |||
2523 2524 2525 2526 2527 2528 2529 |
/*
* 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; if internal rep is already a list do not shimmer it.
* see TIP#22 and TIP#33 for the details.
*/
| | | | 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 |
/*
* 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; if internal rep is already a list do not shimmer it.
* see TIP#22 and TIP#33 for the details.
*/
if (!TclHasInternalRep(argObj, &tclListType)
&& TclGetIntForIndexM(NULL, argObj, TCL_SIZE_MAX - 1, &index)
== TCL_OK) {
/*
* argPtr designates a single index.
*/
return TclLindexFlat(interp, listObj, 1, &argObj);
}
/*
* Make a private copy of the index list argument to keep the internal
* representation of th indices array unchanged while it is in use. This
* is probably unnecessary. It does not appear that any damaging change to
* the internal representation is possible, and no test has been devised to
* show any error when this private copy is not made, But it's cheap, and
* it offers some future-proofing insurance in case the TclLindexFlat
* implementation changes in some unexpected way, or some new form of trace
* or callback permits things to happen that the current implementation
* does not.
*/
indexListCopy = TclDuplicatePureObj(interp, argObj, &tclListType);
if (!indexListCopy) {
/*
* The argument is neither an index nor a well-formed list.
* Report the error via TclLindexFlat.
* TODO - This is as original code. why not directly return an error?
*/
return TclLindexFlat(interp, listObj, 1, &argObj);
|
| ︙ | ︙ | |||
2605 2606 2607 2608 2609 2610 2611 |
Tcl_Size indexCount, /* Count of indices. */
Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that
* represent the indices in the list. */
{
int status;
Tcl_Size i;
| | | | | > > | > | < | 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 |
Tcl_Size indexCount, /* Count of indices. */
Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that
* represent the indices in the list. */
{
int status;
Tcl_Size i;
/* Handle AbstractList as special case */
if (TclObjTypeHasProc(listObj,indexProc)) {
Tcl_Size listLen = TclObjTypeLength(listObj);
Tcl_Size index;
Tcl_Obj *elemObj = NULL;
for (i=0 ; i<indexCount && listObj ; i++) {
if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
&index) == TCL_OK) {
}
if (i==0) {
if (TclObjTypeIndex(interp, listObj, index, &elemObj) != TCL_OK) {
return NULL;
}
} else if (index > 0) {
// TODO: support nested lists
Tcl_Obj *e2Obj = TclLindexFlat(interp, elemObj, 1, &indexArray[i]);
Tcl_DecrRefCount(elemObj);
elemObj = e2Obj;
}
}
Tcl_IncrRefCount(elemObj);
return elemObj;
}
Tcl_IncrRefCount(listObj);
|
| ︙ | ︙ | |||
2664 2665 2666 2667 2668 2669 2670 |
Tcl_IncrRefCount(listObj);
} else {
Tcl_Obj *itemObj;
/*
* Must set the internal rep again because it may have been
* changed by TclGetIntForIndexM. See test lindex-8.4.
*/
| | | 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 |
Tcl_IncrRefCount(listObj);
} else {
Tcl_Obj *itemObj;
/*
* Must set the internal rep again because it may have been
* changed by TclGetIntForIndexM. See test lindex-8.4.
*/
if (!TclHasInternalRep(listObj, &tclListType)) {
status = SetListFromAny(interp, listObj);
if (status != TCL_OK) {
/* The list is not a list at all => error. */
Tcl_DecrRefCount(listObj);
return NULL;
}
}
|
| ︙ | ︙ | |||
2736 2737 2738 2739 2740 2741 2742 |
/*
* 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.
*/
| | | | > > > > > > > | | | | > > | | | | | | | | | | | | | | | | | | | | | | > | > > > > > | 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 |
/*
* 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.
*/
if (!TclHasInternalRep(indexArgObj, &tclListType)
&& TclGetIntForIndexM(NULL, indexArgObj, TCL_SIZE_MAX - 1, &index)
== TCL_OK) {
if (TclObjTypeHasProc(listObj, setElementProc)) {
indices = &indexArgObj;
retValueObj =
TclObjTypeSetElement(interp, listObj, 1, indices, valueObj);
if (retValueObj) Tcl_IncrRefCount(retValueObj);
} else {
/* indexArgPtr designates a single index. */
/* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */
retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
}
} else {
indexListCopy = TclDuplicatePureObj(
interp, indexArgObj, &tclListType);
if (!indexListCopy) {
/*
* indexArgPtr designates something that is neither an index nor a
* well formed list. Report the error via TclLsetFlat.
*/
retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
} else {
if (TCL_OK != TclListObjGetElementsM(
interp, indexListCopy, &indexCount, &indices)) {
Tcl_DecrRefCount(indexListCopy);
/*
* indexArgPtr designates something that is neither an index nor a
* well formed list. Report the error via TclLsetFlat.
*/
retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
} else {
/*
* Let TclLsetFlat perform the actual lset operation.
*/
retValueObj = TclLsetFlat(interp, listObj, indexCount, indices, valueObj);
if (indexListCopy) {
Tcl_DecrRefCount(indexListCopy);
}
}
}
}
assert (retValueObj==NULL || retValueObj->typePtr || retValueObj->bytes);
return retValueObj;
}
/*
*----------------------------------------------------------------------
*
* TclLsetFlat --
|
| ︙ | ︙ | |||
2843 2844 2845 2846 2847 2848 2849 |
/*
* If the list is shared, make a copy to modify (copy-on-write). The string
* representation and internal representation of listObj remains unchanged.
*/
subListObj = Tcl_IsShared(listObj)
| | | | 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 |
/*
* If the list is shared, make a copy to modify (copy-on-write). The string
* representation and internal representation of listObj remains unchanged.
*/
subListObj = Tcl_IsShared(listObj)
? TclDuplicatePureObj(interp, listObj, &tclListType) : listObj;
if (!subListObj) {
return NULL;
}
/*
* Anchor the linked list of Tcl_Obj's whose string reps must be
* invalidated if the operation succeeds.
*/
retValueObj = subListObj;
result = TCL_OK;
/* Allocate if static array for pending invalidations is too small */
if (indexCount
> (int) (sizeof(pendingInvalidates) / sizeof(pendingInvalidates[0]))) {
pendingInvalidatesPtr =
(Tcl_Obj **) Tcl_Alloc(indexCount * sizeof(*pendingInvalidatesPtr));
}
/*
* Loop through all the index arguments, and for each one dive into the
* appropriate sublist.
|
| ︙ | ︙ | |||
2933 2934 2935 2936 2937 2938 2939 |
if (index == elemCount) {
TclNewObj(subListObj);
} else {
subListObj = elemPtrs[index];
}
if (Tcl_IsShared(subListObj)) {
subListObj = TclDuplicatePureObj(
| | | 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 |
if (index == elemCount) {
TclNewObj(subListObj);
} else {
subListObj = elemPtrs[index];
}
if (Tcl_IsShared(subListObj)) {
subListObj = TclDuplicatePureObj(
interp, subListObj, &tclListType);
if (!subListObj) {
return NULL;
}
copied = 1;
}
/*
|
| ︙ | ︙ | |||
2957 2958 2959 2960 2961 2962 2963 |
Tcl_ListObjAppendElement(NULL, parentList, subListObj);
} else {
TclListObjSetElement(NULL, parentList, index, subListObj);
}
if (Tcl_IsShared(subListObj)) {
Tcl_Obj * newSubListObj;
newSubListObj = TclDuplicatePureObj(
| | | 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 |
Tcl_ListObjAppendElement(NULL, parentList, subListObj);
} else {
TclListObjSetElement(NULL, parentList, index, subListObj);
}
if (Tcl_IsShared(subListObj)) {
Tcl_Obj * newSubListObj;
newSubListObj = TclDuplicatePureObj(
interp, subListObj, &tclListType);
if (copied) {
Tcl_DecrRefCount(subListObj);
}
if (newSubListObj) {
subListObj = newSubListObj;
} else {
return NULL;
|
| ︙ | ︙ | |||
3045 3046 3047 3048 3049 3050 3051 |
* compiler warning (not a problem because we checked that we have a
* proper list - or something convertible to one - above).
*/
len = -1;
TclListObjLengthM(NULL, subListObj, &len);
if (valueObj == NULL) {
| | | | | 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 |
* compiler warning (not a problem because we checked that we have a
* proper list - or something convertible to one - above).
*/
len = -1;
TclListObjLengthM(NULL, subListObj, &len);
if (valueObj == NULL) {
/* T:listrep-1.{4.2,5.4,6.1,7.1,8.3},2.{4,5}.4 */
Tcl_ListObjReplace(NULL, subListObj, index, 1, 0, NULL);
} else if (index == len) {
/* T:listrep-1.2.1,2.{2.3,9.3},3.{4,5,6}.3 */
Tcl_ListObjAppendElement(NULL, subListObj, valueObj);
} else {
/* T:listrep-1.{12.1,15.1,19.1},2.{10,13,16}.1 */
TclListObjSetElement(NULL, subListObj, index, valueObj);
TclInvalidateStringRep(subListObj);
}
Tcl_IncrRefCount(retValueObj);
return retValueObj;
}
|
| ︙ | ︙ | |||
3111 3112 3113 3114 3115 3116 3117 |
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
return TCL_ERROR;
}
elemCount = ListRepLength(&listRep);
/* Ensure that the index is in bounds. */
| | | | | 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 |
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
return TCL_ERROR;
}
elemCount = ListRepLength(&listRep);
/* Ensure that the index is in bounds. */
if ((index < 0) || (index >= elemCount)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%" TCL_SIZE_MODIFIER "u\" out of range", index));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX",
"OUTOFRANGE", NULL);
}
return TCL_ERROR;
}
/*
* Note - garbage collect this only AFTER checking indices above.
* Do not want to modify listrep and then not store it back in listObj.
*/
ListRepFreeUnreferenced(&listRep);
/* Replace a shared internal rep with an unshared copy */
if (listRep.storePtr->refCount > 1) {
ListRep newInternalRep;
/* T:listrep-2.{10,13,16}.1 */
/* TODO - leave extra space? */
ListRepClone(&listRep, &newInternalRep, LISTREP_PANIC_ON_FAIL);
listRep = newInternalRep;
} /* else T:listrep-1.{12.1,15.1,19.1} */
/* Retrieve element array AFTER potential cloning above */
ListRepElements(&listRep, elemCount, elemPtrs);
|
| ︙ | ︙ | |||
3288 3289 3290 3291 3292 3293 3294 |
while (!done) {
*elemPtrs++ = keyPtr;
*elemPtrs++ = valuePtr;
Tcl_IncrRefCount(keyPtr);
Tcl_IncrRefCount(valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
| | < < < < < | > | | < < < < | > > | < | > > > > | 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 |
while (!done) {
*elemPtrs++ = keyPtr;
*elemPtrs++ = valuePtr;
Tcl_IncrRefCount(keyPtr);
Tcl_IncrRefCount(valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
} else if (TclObjTypeHasProc(objPtr,indexProc)) {
Tcl_Size elemCount, i;
elemCount = TclObjTypeLength(objPtr);
if (ListRepInitAttempt(interp, elemCount, NULL, &listRep) != TCL_OK) {
return TCL_ERROR;
}
LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */
LIST_ASSERT(listRep.storePtr->firstUsed == 0);
elemPtrs = listRep.storePtr->slots;
/* Each iteration, store a list element */
for (i = 0; i < elemCount; i++) {
if (TclObjTypeIndex(interp, objPtr, i, elemPtrs) != TCL_OK) {
return TCL_ERROR;
}
Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */
}
LIST_ASSERT((Tcl_Size)(elemPtrs - listRep.storePtr->slots) == elemCount);
listRep.storePtr->numUsed = elemCount;
} else {
Tcl_Size estCount, length;
const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length);
/*
* Allocate enough space to hold a (Tcl_Obj *) for each
|
| ︙ | ︙ | |||
3398 3399 3400 3401 3402 3403 3404 |
* So do NOT use ListObjReplaceRepAndInvalidate. InternalRep to be freed AFTER
* IncrRefs so do not use ListObjOverwriteRep
*/
ListRepIncrRefs(&listRep);
TclFreeInternalRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = listRep.storePtr;
objPtr->internalRep.twoPtrValue.ptr2 = listRep.spanPtr;
| | | 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 |
* So do NOT use ListObjReplaceRepAndInvalidate. InternalRep to be freed AFTER
* IncrRefs so do not use ListObjOverwriteRep
*/
ListRepIncrRefs(&listRep);
TclFreeInternalRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = listRep.storePtr;
objPtr->internalRep.twoPtrValue.ptr2 = listRep.spanPtr;
objPtr->typePtr = &tclListType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to generic/tclObj.c.
| ︙ | ︙ | |||
224 225 226 227 228 229 230 | /* * The structures below defines the Tcl object types defined in this file by * means of functions that can be invoked by generic object code. See also * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager * implementations. */ | | | | | < < | | | < < | | | < < | | | < < | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 |
/*
* The structures below defines the Tcl object types defined in this file by
* 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= {
"boolean", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
TclSetBooleanFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V1(TclLengthOne)
};
const Tcl_ObjType tclDoubleType= {
"double", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfDouble, /* updateStringProc */
SetDoubleFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V1(TclLengthOne)
};
const Tcl_ObjType tclIntType = {
"int", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny, /* setFromAnyProc */
TCL_OBJTYPE_V1(TclLengthOne)
};
const Tcl_ObjType tclBignumType = {
"bignum", /* name */
FreeBignum, /* freeIntRepProc */
DupBignum, /* dupIntRepProc */
UpdateStringOfBignum, /* updateStringProc */
NULL, /* setFromAnyProc */
TCL_OBJTYPE_V1(TclLengthOne)
};
/*
* The structure below defines the Tcl obj hash key type.
*/
const Tcl_HashKeyType tclObjHashKeyType = {
|
| ︙ | ︙ | |||
384 385 386 387 388 389 390 |
TclInitObjSubsystem(void)
{
Tcl_MutexLock(&tableMutex);
typeTableInitialized = 1;
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&tableMutex);
| | | > > > > > > > > > | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 |
TclInitObjSubsystem(void)
{
Tcl_MutexLock(&tableMutex);
typeTableInitialized = 1;
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&tableMutex);
Tcl_RegisterObjType(&tclDoubleType);
Tcl_RegisterObjType(&tclStringType);
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclCmdNameType);
Tcl_RegisterObjType(&tclRegexpType);
Tcl_RegisterObjType(&tclProcBodyType);
/* For backward compatibility only ... */
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
Tcl_RegisterObjType(&tclIntType);
#if !defined(TCL_WIDE_INT_IS_LONG)
Tcl_RegisterObjType(&oldIntType);
#endif
Tcl_RegisterObjType(&oldBooleanType);
#endif
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
tclObjsAlloced = 0;
tclObjsFreed = 0;
{
int i;
|
| ︙ | ︙ | |||
1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 |
Tcl_Interp *interp,
Tcl_Obj *dupPtr,
Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr)
{
char *bytes = objPtr->bytes;
int status = TCL_OK;
TclInvalidateStringRep(dupPtr);
assert(dupPtr->typePtr == NULL);
if (objPtr->typePtr && objPtr->typePtr->dupIntRepProc) {
objPtr->typePtr->dupIntRepProc(objPtr, dupPtr);
} else {
dupPtr->internalRep = objPtr->internalRep;
dupPtr->typePtr = objPtr->typePtr;
}
| > > | | | 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 |
Tcl_Interp *interp,
Tcl_Obj *dupPtr,
Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr)
{
char *bytes = objPtr->bytes;
int status = TCL_OK;
const Tcl_ObjType *useTypePtr =
objPtr->typePtr ? objPtr->typePtr : typePtr;
TclInvalidateStringRep(dupPtr);
assert(dupPtr->typePtr == NULL);
if (objPtr->typePtr && objPtr->typePtr->dupIntRepProc) {
objPtr->typePtr->dupIntRepProc(objPtr, dupPtr);
} else {
dupPtr->internalRep = objPtr->internalRep;
dupPtr->typePtr = objPtr->typePtr;
}
if (typePtr != NULL && dupPtr->typePtr != useTypePtr) {
if (bytes) {
dupPtr->bytes = bytes;
dupPtr->length = objPtr->length;
}
/* borrow bytes from original object */
status = Tcl_ConvertToType(interp, dupPtr, useTypePtr);
if (bytes) {
dupPtr->bytes = NULL;
dupPtr->length = 0;
}
if (status != TCL_OK) {
return status;
}
|
| ︙ | ︙ | |||
1651 1652 1653 1654 1655 1656 1657 |
* Perhaps in the future this can be remedied and this special treatment
* removed.
*/
if (bytes && (dupPtr->typePtr == NULL
|| dupPtr->typePtr->updateStringProc == NULL
| | | 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 |
* Perhaps in the future this can be remedied and this special treatment
* removed.
*/
if (bytes && (dupPtr->typePtr == NULL
|| dupPtr->typePtr->updateStringProc == NULL
|| useTypePtr == &tclStringType
)
) {
if (!TclAttemptInitStringRep(dupPtr, bytes, objPtr->length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to initialize string", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
|
| ︙ | ︙ | |||
2141 2142 2143 2144 2145 2146 2147 |
TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK)
? "boolean value or \"\"" : "boolean value", NULL, TCL_INDEX_NONE, NULL, 0);
Tcl_DecrRefCount(objPtr);
}
return TCL_ERROR;
}
do {
| | | | | 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 |
TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK)
? "boolean value or \"\"" : "boolean value", NULL, TCL_INDEX_NONE, NULL, 0);
Tcl_DecrRefCount(objPtr);
}
return TCL_ERROR;
}
do {
if (objPtr->typePtr == &tclIntType || objPtr->typePtr == &tclBooleanType) {
result = (objPtr->internalRep.wideValue != 0);
goto boolEnd;
}
if (objPtr->typePtr == &tclDoubleType) {
/*
* Caution: Don't be tempted to check directly for the "double"
* Tcl_ObjType and then compare the internalrep to 0.0. This isn't
* reliable because a "double" Tcl_ObjType can hold the NaN value.
* Use the API Tcl_GetDoubleFromObj, which does the checking and
* sets the proper error message for us.
*/
double d;
if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) {
return TCL_ERROR;
}
result = (d != 0.0);
goto boolEnd;
}
if (objPtr->typePtr == &tclBignumType) {
result = 1;
boolEnd:
if (charPtr != NULL) {
flags &= (TCL_NULL_OK-2);
if (flags) {
if (flags == (int)sizeof(int)) {
*(int *)charPtr = result;
|
| ︙ | ︙ | |||
2230 2231 2232 2233 2234 2235 2236 |
/*
* 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) {
| | | | | 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 |
/*
* 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) {
return TCL_OK;
}
goto badBoolean;
}
if (objPtr->typePtr == &tclBignumType) {
goto badBoolean;
}
if (objPtr->typePtr == &tclDoubleType) {
goto badBoolean;
}
}
if (ParseBoolean(objPtr) == TCL_OK) {
return TCL_OK;
}
|
| ︙ | ︙ | |||
2372 2373 2374 2375 2376 2377 2378 |
* as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use that old internalRep.
*/
goodBoolean:
TclFreeInternalRep(objPtr);
objPtr->internalRep.wideValue = newBool;
| | | | 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 |
* as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use that old internalRep.
*/
goodBoolean:
TclFreeInternalRep(objPtr);
objPtr->internalRep.wideValue = newBool;
objPtr->typePtr = &tclBooleanType;
return TCL_OK;
numericBoolean:
TclFreeInternalRep(objPtr);
objPtr->internalRep.wideValue = newBool;
objPtr->typePtr = &tclIntType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewDoubleObj --
|
| ︙ | ︙ | |||
2470 2471 2472 2473 2474 2475 2476 |
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
/* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
| | | 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 |
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
/* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
objPtr->typePtr = &tclDoubleType;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewDoubleObj(
|
| ︙ | ︙ | |||
2543 2544 2545 2546 2547 2548 2549 |
int
Tcl_GetDoubleFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a double. */
double *dblPtr) /* Place to store resulting double. */
{
do {
| | | | | 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 |
int
Tcl_GetDoubleFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a double. */
double *dblPtr) /* Place to store resulting double. */
{
do {
if (objPtr->typePtr == &tclDoubleType) {
if (isnan(objPtr->internalRep.doubleValue)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"floating point value is Not a Number", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN",
NULL);
}
return TCL_ERROR;
}
*dblPtr = (double) objPtr->internalRep.doubleValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
*dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
mp_int big;
TclUnpackBignum(objPtr, big);
*dblPtr = TclBignumToDouble(&big);
return TCL_OK;
}
} while (SetDoubleFromAny(interp, objPtr) == TCL_OK);
|
| ︙ | ︙ | |||
2774 2775 2776 2777 2778 2779 2780 |
Tcl_GetLongFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a long. */
long *longPtr) /* Place to store resulting long. */
{
do {
#ifdef TCL_WIDE_INT_IS_LONG
| | | | | | 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 |
Tcl_GetLongFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a long. */
long *longPtr) /* Place to store resulting long. */
{
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
* 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)
&& w <= (Tcl_WideInt)(ULONG_MAX)) {
*longPtr = (long)w;
return TCL_OK;
}
goto tooLarge;
}
#endif
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) {
/*
* Must check for those bignum values that can fit in a long, even
* when auto-narrowing is enabled. Only those values in the signed
* long range get auto-narrowed to tclIntType, while all the
* values in the unsigned long range will fit in a long.
*/
|
| ︙ | ︙ | |||
3035 3036 3037 3038 3039 3040 3041 |
Tcl_GetWideIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideInt *wideIntPtr)
/* Place to store resulting long. */
{
do {
| | | | | 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 |
Tcl_GetWideIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideInt *wideIntPtr)
/* Place to store resulting long. */
{
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) {
/*
* 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;
|
| ︙ | ︙ | |||
3120 3121 3122 3123 3124 3125 3126 |
Tcl_GetWideUIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideUInt *wideUIntPtr)
/* Place to store resulting long. */
{
do {
| | | | | 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 |
Tcl_GetWideUIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideUInt *wideUIntPtr)
/* Place to store resulting long. */
{
do {
if (objPtr->typePtr == &tclIntType) {
if (objPtr->internalRep.wideValue < 0) {
wideUIntOutOfRange:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected unsigned integer but got \"%s\"",
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
}
*wideUIntPtr = (Tcl_WideUInt)objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclDoubleType) {
goto wideUIntOutOfRange;
}
if (objPtr->typePtr == &tclBignumType) {
/*
* Must check for those bignum values that can fit in a
* Tcl_WideUInt, even when auto-narrowing is enabled.
*/
mp_int big;
Tcl_WideUInt value = 0;
|
| ︙ | ︙ | |||
3204 3205 3206 3207 3208 3209 3210 |
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 {
| | | | | 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 |
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;
mp_err err;
Tcl_WideUInt value = 0, scratch;
size_t numBytes;
unsigned char *bytes = (unsigned char *) &scratch;
|
| ︙ | ︙ | |||
3321 3322 3323 3324 3325 3326 3327 |
DupBignum(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
mp_int bignumVal;
mp_int bignumCopy;
| | | 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 |
DupBignum(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
mp_int bignumVal;
mp_int bignumCopy;
copyPtr->typePtr = &tclBignumType;
TclUnpackBignum(srcPtr, bignumVal);
if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) {
Tcl_Panic("initialization failure in DupBignum");
}
PACK_BIGNUM(bignumCopy, copyPtr);
}
|
| ︙ | ︙ | |||
3491 3492 3493 3494 3495 3496 3497 |
GetBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
int copy, /* Whether to copy the returned bignum value */
mp_int *bignumValue) /* Returned bignum value. */
{
do {
| | | 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 |
GetBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
int copy, /* Whether to copy the returned bignum value */
mp_int *bignumValue) /* Returned bignum value. */
{
do {
if (objPtr->typePtr == &tclBignumType) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
TclUnpackBignum(objPtr, temp);
if (mp_init_copy(bignumValue, &temp) != MP_OKAY) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3516 3517 3518 3519 3520 3521 3522 |
*/
if (objPtr->bytes == NULL) {
TclInitEmptyStringRep(objPtr);
}
}
return TCL_OK;
}
| | | | 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 |
*/
if (objPtr->bytes == NULL) {
TclInitEmptyStringRep(objPtr);
}
}
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
if (mp_init_i64(bignumValue,
objPtr->internalRep.wideValue) != MP_OKAY) {
return TCL_ERROR;
}
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;
|
| ︙ | ︙ | |||
3683 3684 3685 3686 3687 3688 3689 |
void
TclSetBignumInternalRep(
Tcl_Obj *objPtr,
void *big)
{
mp_int *bignumValue = (mp_int *)big;
| | | 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 |
void
TclSetBignumInternalRep(
Tcl_Obj *objPtr,
void *big)
{
mp_int *bignumValue = (mp_int *)big;
objPtr->typePtr = &tclBignumType;
PACK_BIGNUM(*bignumValue, objPtr);
/*
* Clear the mp_int value.
*
* Don't call mp_clear() because it would free the digit array we just
* packed into the Tcl_Obj.
|
| ︙ | ︙ | |||
3726 3727 3728 3729 3730 3731 3732 |
Tcl_GetNumberFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
void **clientDataPtr,
int *typePtr)
{
do {
| | | | | 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 |
Tcl_GetNumberFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
void **clientDataPtr,
int *typePtr)
{
do {
if (objPtr->typePtr == &tclDoubleType) {
if (isnan(objPtr->internalRep.doubleValue)) {
*typePtr = TCL_NUMBER_NAN;
} else {
*typePtr = TCL_NUMBER_DOUBLE;
}
*clientDataPtr = &objPtr->internalRep.doubleValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
*typePtr = TCL_NUMBER_INT;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
static Tcl_ThreadDataKey bignumKey;
mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey,
sizeof(mp_int));
TclUnpackBignum(objPtr, *bigPtr);
*typePtr = TCL_NUMBER_BIG;
*clientDataPtr = bigPtr;
|
| ︙ | ︙ | |||
4701 4702 4703 4704 4705 4706 4707 |
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) {
| | | 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 |
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);
}
|
| ︙ | ︙ |
Changes to generic/tclScan.c.
| ︙ | ︙ | |||
1042 1043 1044 1045 1046 1047 1048 |
Tcl_DecrRefCount(objPtr);
string = end;
} else {
double dvalue;
if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
const Tcl_ObjInternalRep *irPtr
| | | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 |
Tcl_DecrRefCount(objPtr);
string = end;
} else {
double dvalue;
if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
const Tcl_ObjInternalRep *irPtr
= TclFetchInternalRep(objPtr, &tclDoubleType);
if (irPtr) {
dvalue = irPtr->doubleValue;
} else
#endif
{
Tcl_DecrRefCount(objPtr);
goto done;
|
| ︙ | ︙ |
Changes to generic/tclStrToD.c.
| ︙ | ︙ | |||
551 552 553 554 555 556 557 |
if (bytes == NULL) {
if (interp == NULL && endPtrPtr == NULL) {
if (TclHasInternalRep(objPtr, &tclDictType)) {
/* A dict can never be a (single) number */
return TCL_ERROR;
}
| | | 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 |
if (bytes == NULL) {
if (interp == NULL && endPtrPtr == NULL) {
if (TclHasInternalRep(objPtr, &tclDictType)) {
/* A dict can never be a (single) number */
return TCL_ERROR;
}
if (TclHasInternalRep(objPtr, &tclListType)) {
Tcl_Size length;
/* A list can only be a (single) number if its length == 1 */
TclListObjLengthM(NULL, objPtr, &length);
if (length != 1) {
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
1374 1375 1376 1377 1378 1379 1380 |
}
if (!octalSignificandOverflow) {
if ((err == MP_OKAY) && (octalSignificandWide > (MOST_BITS + signum))) {
err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
octalSignificandOverflow = 1;
} else {
| | | 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 |
}
if (!octalSignificandOverflow) {
if ((err == MP_OKAY) && (octalSignificandWide > (MOST_BITS + signum))) {
err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
octalSignificandOverflow = 1;
} else {
objPtr->typePtr = &tclIntType;
if (signum) {
objPtr->internalRep.wideValue =
(Tcl_WideInt)(-octalSignificandWide);
} else {
objPtr->internalRep.wideValue =
(Tcl_WideInt)octalSignificandWide;
}
|
| ︙ | ︙ | |||
1410 1411 1412 1413 1414 1415 1416 |
returnInteger:
if (!significandOverflow) {
if ((err == MP_OKAY) && (significandWide > MOST_BITS+signum)) {
err = mp_init_u64(&significandBig,
significandWide);
significandOverflow = 1;
} else {
| | | 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 |
returnInteger:
if (!significandOverflow) {
if ((err == MP_OKAY) && (significandWide > MOST_BITS+signum)) {
err = mp_init_u64(&significandBig,
significandWide);
significandOverflow = 1;
} else {
objPtr->typePtr = &tclIntType;
if (signum) {
objPtr->internalRep.wideValue =
(Tcl_WideInt)(-significandWide);
} else {
objPtr->internalRep.wideValue =
(Tcl_WideInt)significandWide;
}
|
| ︙ | ︙ | |||
1442 1443 1444 1445 1446 1447 1448 | * Here, we're parsing a floating-point number. 'significandWide' * or 'significandBig' contains the exact significand, according * to whether 'significandOverflow' is set. The desired floating * point value is significand * 10**k, where * k = numTrailZeros+exponent-numDigitsAfterDp. */ | | | 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 |
* Here, we're parsing a floating-point number. 'significandWide'
* or 'significandBig' contains the exact significand, according
* to whether 'significandOverflow' is set. The desired floating
* point value is significand * 10**k, where
* k = numTrailZeros+exponent-numDigitsAfterDp.
*/
objPtr->typePtr = &tclDoubleType;
if (exponentSignum) {
/*
* At this point exponent>=0, so the following calculation
* cannot underflow.
*/
exponent = -exponent;
}
|
| ︙ | ︙ | |||
1493 1494 1495 1496 1497 1498 1499 |
case sINF:
case sINFINITY:
if (signum) {
objPtr->internalRep.doubleValue = -HUGE_VAL;
} else {
objPtr->internalRep.doubleValue = HUGE_VAL;
}
| | | | 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 |
case sINF:
case sINFINITY:
if (signum) {
objPtr->internalRep.doubleValue = -HUGE_VAL;
} else {
objPtr->internalRep.doubleValue = HUGE_VAL;
}
objPtr->typePtr = &tclDoubleType;
break;
#ifdef IEEE_FLOATING_POINT
case sNAN:
case sNANFINISH:
objPtr->internalRep.doubleValue = MakeNaN(signum, significandWide);
objPtr->typePtr = &tclDoubleType;
break;
#endif
case INITIAL:
/* This case only to silence compiler warning. */
Tcl_Panic("TclParseNumber: state INITIAL can't happen here");
}
}
|
| ︙ | ︙ |
Changes to generic/tclStubInit.c.
| ︙ | ︙ | |||
106 107 108 109 110 111 112 113 |
#define TclUnusedStubEntry 0
#if TCL_UTF_MAX < 4
static void uniCodePanic() {
Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX);
}
# define Tcl_GetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, Tcl_Size *))(void *)uniCodePanic
| > | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 |
#define TclUnusedStubEntry 0
#if TCL_UTF_MAX < 4
static void uniCodePanic() {
Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX);
}
# define Tcl_GetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, Tcl_Size *))(void *)uniCodePanic
# define TclGetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, void *))(void *)uniCodePanic
# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const Tcl_UniChar *, Tcl_Size))(void *)uniCodePanic
# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, Tcl_Size))(void *)uniCodePanic
# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, Tcl_Size))(void *)uniCodePanic
#endif
#define TclUtfCharComplete Tcl_UtfCharComplete
#define TclUtfNext Tcl_UtfNext
|
| ︙ | ︙ |
Changes to generic/tclTest.c.
| ︙ | ︙ | |||
736 737 738 739 740 741 742 743 744 745 746 747 748 749 |
return TCL_ERROR;
}
#if TCL_THREADS
if (TclThread_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
#endif
/*
* Check for special options used in ../tests/main.test
*/
objPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY);
if (objPtr != NULL) {
| > > > > | 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 |
return TCL_ERROR;
}
#if TCL_THREADS
if (TclThread_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
#endif
if (Tcl_ABSListTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
/*
* Check for special options used in ../tests/main.test
*/
objPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY);
if (objPtr != NULL) {
|
| ︙ | ︙ | |||
8798 8799 8800 8801 8802 8803 8804 | * mode: c * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 * indent-tabs-mode: nil * End: */ | < | 8802 8803 8804 8805 8806 8807 8808 | * mode: c * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 * indent-tabs-mode: nil * End: */ |
Added generic/tclTestABSList.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 |
// Tcl Abstract List test command: "lstring"
#ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
#endif
#include <string.h>
#include <limits.h>
#include "tclInt.h"
/*
* Forward references
*/
Tcl_Obj *myNewLStringObj(Tcl_WideInt start,
Tcl_WideInt length);
static void freeRep(Tcl_Obj* alObj);
static Tcl_Obj* my_LStringObjSetElem(Tcl_Interp *interp,
Tcl_Obj *listPtr,
Tcl_Size numIndcies,
Tcl_Obj *const indicies[],
Tcl_Obj *valueObj);
static void DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static Tcl_Size my_LStringObjLength(Tcl_Obj *lstringObjPtr);
static int my_LStringObjIndex(Tcl_Interp *interp,
Tcl_Obj *lstringObj,
Tcl_Size index,
Tcl_Obj **charObjPtr);
static int my_LStringObjRange(Tcl_Interp *interp, Tcl_Obj *lstringObj,
Tcl_Size fromIdx, Tcl_Size toIdx,
Tcl_Obj **newObjPtr);
static int my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj,
Tcl_Obj **newObjPtr);
static int my_LStringReplace(Tcl_Interp *interp,
Tcl_Obj *listObj,
Tcl_Size first,
Tcl_Size numToDelete,
Tcl_Size numToInsert,
Tcl_Obj *const insertObjs[]);
static int my_LStringGetElements(Tcl_Interp *interp,
Tcl_Obj *listPtr,
Tcl_Size *objcptr,
Tcl_Obj ***objvptr);
static void lstringFreeElements(Tcl_Obj* lstringObj);
static void UpdateStringOfLString(Tcl_Obj *objPtr);
/*
* Internal Representation of an lstring type value
*/
typedef struct LString {
char *string; // NULL terminated utf-8 string
Tcl_Size strlen; // num bytes in string
Tcl_Size allocated; // num bytes allocated
Tcl_Obj**elements; // elements array, allocated when GetElements is
// called
} LString;
/*
* AbstractList definition of an lstring type
*/
static const Tcl_ObjType lstringTypes[11] = {
{/*0*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace) /* Replace */
},
{/*1*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
NULL, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace) /* Replace */
},
{/*2*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
NULL, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace) /* Replace */
},
{/*3*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
NULL, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace) /* Replace */
},
{/*4*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
NULL, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace) /* Replace */
},
{/*5*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
NULL, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace) /* Replace */
},
{/*6*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
NULL, /* SetElement */
my_LStringReplace) /* Replace */
},
{/*7*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
NULL) /* Replace */
},
{/*8*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace) /* Replace */
},
{/*9*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace) /* Replace */
},
{/*10*/
"lstring",
freeRep,
DupLStringRep,
UpdateStringOfLString,
NULL,
TCL_OBJTYPE_V2(
my_LStringObjLength, /* Length */
my_LStringObjIndex, /* Index */
my_LStringObjRange, /* Slice */
my_LStringObjReverse, /* Reverse */
my_LStringGetElements, /* GetElements */
my_LStringObjSetElem, /* SetElement */
my_LStringReplace) /* Replace */
}
};
/*
*----------------------------------------------------------------------
*
* my_LStringObjIndex --
*
* Implements the AbstractList Index function for the lstring type. The
* Index function returns the value at the index position given. Caller
* is resposible for freeing the Obj.
*
* Results:
* TCL_OK on success. Returns a new Obj, with a 0 refcount in the
* supplied charObjPtr location. Call has ownership of the Obj.
*
* Side effects:
* Obj allocated.
*
*----------------------------------------------------------------------
*/
static int
my_LStringObjIndex(
Tcl_Interp *interp,
Tcl_Obj *lstringObj,
Tcl_Size index,
Tcl_Obj **charObjPtr)
{
LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
(void)interp;
if (index < lstringRepPtr->strlen) {
char cchar[2];
cchar[0] = lstringRepPtr->string[index];
cchar[1] = 0;
*charObjPtr = Tcl_NewStringObj(cchar,1);
} else {
*charObjPtr = Tcl_NewObj();
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* my_LStringObjLength --
*
* Implements the AbstractList Length function for the lstring type.
* The Length function returns the number of elements in the list.
*
* Results:
* WideInt number of elements in the list.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Size
my_LStringObjLength(Tcl_Obj *lstringObjPtr)
{
LString *lstringRepPtr = (LString *)lstringObjPtr->internalRep.twoPtrValue.ptr1;
return lstringRepPtr->strlen;
}
/*
*----------------------------------------------------------------------
*
* DupLStringRep --
*
* Replicates the internal representation of the src value, and storing
* it in the copy
*
* Results:
* void
*
* Side effects:
* Modifies the rep of the copyObj.
*
*----------------------------------------------------------------------
*/
static void
DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)
{
LString *srcLString = (LString*)srcPtr->internalRep.twoPtrValue.ptr1;
LString *copyLString = (LString*)Tcl_Alloc(sizeof(LString));
memcpy(copyLString, srcLString, sizeof(LString));
copyLString->string = (char*)Tcl_Alloc(srcLString->allocated);
strncpy(copyLString->string, srcLString->string, srcLString->strlen);
copyLString->string[srcLString->strlen] = '\0';
copyLString->elements = NULL;
Tcl_ObjInternalRep itr;
itr.twoPtrValue.ptr1 = copyLString;
itr.twoPtrValue.ptr2 = NULL;
Tcl_StoreInternalRep(copyPtr, srcPtr->typePtr, &itr);
return;
}
/*
*----------------------------------------------------------------------
*
* my_LStringObjSetElem --
*
* Replace the element value at the given (nested) index with the
* valueObj provided. If the lstring obj is shared, a new list is
* created conntaining the modifed element.
*
* Results:
* The modifed lstring is returned, either new or original. If the
* index is invalid, NULL is returned, and an error is added to the
* interp, if provided.
*
* Side effects:
* A new obj may be created.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj*
my_LStringObjSetElem(
Tcl_Interp *interp,
Tcl_Obj *lstringObj,
Tcl_Size numIndicies,
Tcl_Obj *const indicies[],
Tcl_Obj *valueObj)
{
LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
Tcl_Size index;
const char *newvalue;
int status;
Tcl_Obj *returnObj;
if (numIndicies > 1) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("Multiple indicies not supported by lstring."));
return NULL;
}
status = Tcl_GetIntForIndex(interp, indicies[0], lstringRepPtr->strlen, &index);
if (status != TCL_OK) {
return NULL;
}
returnObj = Tcl_IsShared(lstringObj) ? Tcl_DuplicateObj(lstringObj) : lstringObj;
lstringRepPtr = (LString*)returnObj->internalRep.twoPtrValue.ptr1;
if (index >= lstringRepPtr->strlen) {
index = lstringRepPtr->strlen;
lstringRepPtr->strlen++;
lstringRepPtr->string = (char*)Tcl_Realloc(lstringRepPtr->string, lstringRepPtr->strlen+1);
}
newvalue = Tcl_GetString(valueObj);
lstringRepPtr->string[index] = newvalue[0];
Tcl_InvalidateStringRep(returnObj);
return returnObj;
}
/*
*----------------------------------------------------------------------
*
* my_LStringObjRange --
*
* Creates a new Obj with a slice of the src listPtr.
*
* Results:
* A new Obj is assigned to newObjPtr. Returns TCL_OK
*
* Side effects:
* A new Obj is created.
*
*----------------------------------------------------------------------
*/
static int my_LStringObjRange(
Tcl_Interp *interp,
Tcl_Obj *lstringObj,
Tcl_Size fromIdx,
Tcl_Size toIdx,
Tcl_Obj **newObjPtr)
{
Tcl_Obj *rangeObj;
LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
LString *rangeRep;
Tcl_WideInt len = toIdx - fromIdx + 1;
if (lstringRepPtr->strlen < fromIdx ||
lstringRepPtr->strlen < toIdx) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("Range out of bounds "));
return TCL_ERROR;
}
if (len <= 0) {
// Return empty value;
*newObjPtr = Tcl_NewObj();
} else {
rangeRep = (LString*)Tcl_Alloc(sizeof(LString));
rangeRep->allocated = len+1;
rangeRep->strlen = len;
rangeRep->string = (char*)Tcl_Alloc(rangeRep->allocated);
strncpy(rangeRep->string,&lstringRepPtr->string[fromIdx],len);
rangeRep->string[len] = 0;
rangeRep->elements = NULL;
rangeObj = Tcl_NewObj();
Tcl_ObjInternalRep itr;
itr.twoPtrValue.ptr1 = rangeRep;
itr.twoPtrValue.ptr2 = NULL;
Tcl_StoreInternalRep(rangeObj, lstringObj->typePtr, &itr);
if (rangeRep->strlen > 0) {
Tcl_InvalidateStringRep(rangeObj);
} else {
Tcl_InitStringRep(rangeObj, NULL, 0);
}
*newObjPtr = rangeObj;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* my_LStringObjReverse --
*
* Creates a new Obj with the the order of the elements in the lstring
* value reversed, where first is last and last is first, etc.
*
* Results:
* A new Obj is assigned to newObjPtr. Returns TCL_OK
*
* Side effects:
* A new Obj is created.
*
*----------------------------------------------------------------------
*/
static int
my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj, Tcl_Obj **newObjPtr)
{
LString *srcRep = (LString*)srcObj->internalRep.twoPtrValue.ptr1;
Tcl_Obj *revObj;
LString *revRep = (LString*)Tcl_Alloc(sizeof(LString));
Tcl_ObjInternalRep itr;
Tcl_Size len;
char *srcp, *dstp, *endp;
(void)interp;
len = srcRep->strlen;
revRep->strlen = len;
revRep->allocated = len+1;
revRep->string = (char*)Tcl_Alloc(revRep->allocated);
revRep->elements = NULL;
srcp = srcRep->string;
endp = &srcRep->string[len];
dstp = &revRep->string[len];
*dstp-- = 0;
while (srcp < endp) {
*dstp-- = *srcp++;
}
revObj = Tcl_NewObj();
itr.twoPtrValue.ptr1 = revRep;
itr.twoPtrValue.ptr2 = NULL;
Tcl_StoreInternalRep(revObj, srcObj->typePtr, &itr);
if (revRep->strlen > 0) {
Tcl_InvalidateStringRep(revObj);
} else {
Tcl_InitStringRep(revObj, NULL, 0);
}
*newObjPtr = revObj;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* my_LStringReplace --
*
* Delete and/or Insert elements in the list, starting at index first.
* See more details in the comments below. This should not be called with
* a Shared Obj.
*
* Results:
* The value of the listObj is modified.
*
* Side effects:
* The string rep is invalidated.
*
*----------------------------------------------------------------------
*/
static int
my_LStringReplace(
Tcl_Interp *interp,
Tcl_Obj *listObj,
Tcl_Size first,
Tcl_Size numToDelete,
Tcl_Size numToInsert,
Tcl_Obj *const insertObjs[])
{
LString *lstringRep = (LString*)listObj->internalRep.twoPtrValue.ptr1;
Tcl_Size newLen;
Tcl_Size x, ix, kx;
char *newStr;
char *oldStr = lstringRep->string;
(void)interp;
newLen = lstringRep->strlen - numToDelete + numToInsert;
if (newLen >= lstringRep->allocated) {
lstringRep->allocated = newLen+1;
newStr = (char*)Tcl_Alloc(lstringRep->allocated);
newStr[newLen] = 0;
} else {
newStr = oldStr;
}
/* Tcl_ListObjReplace replaces zero or more elements of the list
* referenced by listPtr with the objc values in the array referenced by
* objv.
*
* If listPtr does not point to a list value, Tcl_ListObjReplace
* will attempt to convert it to one; if the conversion fails, it returns
* TCL_ERROR and leaves an error message in the interpreter's result value
* if interp is not NULL. Otherwise, it returns TCL_OK after replacing the
* values.
*
* * If objv is NULL, no new elements are added.
*
* * If the argument first is zero or negative, it refers to the first
* element.
*
* * If first is greater than or equal to the number of elements in the
* list, then no elements are deleted; the new elements are appended
* to the list. count gives the number of elements to replace.
*
* * If count is zero or negative then no elements are deleted; the new
* elements are simply inserted before the one designated by first.
* Tcl_ListObjReplace invalidates listPtr's old string representation.
*
* * The reference counts of any elements inserted from objv are
* incremented since the resulting list now refers to them. Similarly,
* the reference counts for any replaced values are decremented.
*/
// copy 0 to first-1
if (newStr != oldStr) {
strncpy(newStr, oldStr, first);
}
// move front elements to keep
for(x=0, kx=0; x<newLen && kx<first; kx++, x++) {
newStr[x] = oldStr[kx];
}
// Insert new elements into new string
for(x=first, ix=0; ix<numToInsert; x++, ix++) {
char const *svalue = Tcl_GetString(insertObjs[ix]);
newStr[x] = svalue[0];
}
// Move remaining elements
if ((first+numToDelete) < newLen) {
for(/*x,*/ kx=first+numToDelete; (kx <lstringRep->strlen && x<newLen); x++, kx++) {
newStr[x] = oldStr[kx];
}
}
// Terminate new string.
newStr[newLen] = 0;
if (oldStr != newStr) {
Tcl_Free(oldStr);
}
lstringRep->string = newStr;
lstringRep->strlen = newLen;
/* Changes made to value, string rep and elements array no longer valid */
Tcl_InvalidateStringRep(listObj);
lstringFreeElements(listObj);
return TCL_OK;
}
static const Tcl_ObjType *
my_SetAbstractProc(int ptype)
{
const Tcl_ObjType *typePtr = &lstringTypes[0]; /* default value */
if (4 <= ptype && ptype <= 11) {
/* Table has no entries for the slots upto setfromany */
typePtr = &lstringTypes[(ptype-3)];
}
return typePtr;
}
/*
*----------------------------------------------------------------------
*
* my_NewLStringObj --
*
* Creates a new lstring Obj using the string value of objv[0]
*
* Results:
* results
*
* Side effects:
* side effects
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
my_NewLStringObj(
Tcl_Interp *interp,
int objc,
Tcl_Obj * const objv[])
{
LString *lstringRepPtr;
Tcl_ObjInternalRep itr;
size_t repSize;
Tcl_Obj *lstringPtr;
const char *string;
static const char* procTypeNames[] = {
"FREEREP", "DUPREP", "UPDATESTRING", "SETFROMANY",
"LENGTH", "INDEX", "SLICE", "REVERSE", "GETELEMENTS",
"SETELEMENT", "REPLACE", NULL
};
int i = 0;
int ptype;
const Tcl_ObjType *lstringTypePtr = &lstringTypes[10];
repSize = sizeof(LString);
lstringRepPtr = (LString*)Tcl_Alloc(repSize);
while (i<objc) {
const char *s = Tcl_GetString(objv[i]);
if (strcmp(s, "-not")==0) {
i++;
if (Tcl_GetIndexFromObj(interp, objv[i], procTypeNames, "proctype", 0, &ptype)==TCL_OK) {
lstringTypePtr = my_SetAbstractProc(ptype);
}
} else if (strcmp(s, "--") == 0) {
// End of options
i++;
break;
} else {
break;
}
i++;
}
if (i != objc-1) {
Tcl_WrongNumArgs(interp, 0, objv, "lstring string");
return NULL;
}
string = Tcl_GetString(objv[i]);
lstringRepPtr->strlen = strlen(string);
lstringRepPtr->allocated = lstringRepPtr->strlen + 1;
lstringRepPtr->string = (char*)Tcl_Alloc(lstringRepPtr->allocated);
strcpy(lstringRepPtr->string, string);
lstringRepPtr->elements = NULL;
lstringPtr = Tcl_NewObj();
itr.twoPtrValue.ptr1 = lstringRepPtr;
itr.twoPtrValue.ptr2 = NULL;
Tcl_StoreInternalRep(lstringPtr, lstringTypePtr, &itr);
if (lstringRepPtr->strlen > 0) {
Tcl_InvalidateStringRep(lstringPtr);
} else {
Tcl_InitStringRep(lstringPtr, NULL, 0);
}
return lstringPtr;
}
/*
*----------------------------------------------------------------------
*
* freeElements --
*
* Free the element array
*
*/
static void
lstringFreeElements(Tcl_Obj* lstringObj)
{
LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
if (lstringRepPtr->elements) {
Tcl_Obj **objptr = lstringRepPtr->elements;
while (objptr < &lstringRepPtr->elements[lstringRepPtr->strlen]) {
Tcl_DecrRefCount(*objptr++);
}
Tcl_Free((char*)lstringRepPtr->elements);
lstringRepPtr->elements = NULL;
}
}
/*
*----------------------------------------------------------------------
*
* freeRep --
*
* Free the value storage of the lstring Obj.
*
* Results:
* void
*
* Side effects:
* Memory free'd.
*
*----------------------------------------------------------------------
*/
static void
freeRep(Tcl_Obj* lstringObj)
{
LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
if (lstringRepPtr->string) {
Tcl_Free(lstringRepPtr->string);
}
lstringFreeElements(lstringObj);
Tcl_Free((char*)lstringRepPtr);
lstringObj->internalRep.twoPtrValue.ptr1 = NULL;
}
/*
*----------------------------------------------------------------------
*
* my_LStringGetElements --
*
* Get the elements of the list in an array.
*
* Results:
* objc, objv return values
*
* Side effects:
* A Tcl_Obj is stored for every element of the abstract list
*
*----------------------------------------------------------------------
*/
static int my_LStringGetElements(Tcl_Interp *interp,
Tcl_Obj *lstringObj,
Tcl_Size *objcptr,
Tcl_Obj ***objvptr)
{
LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
Tcl_Obj **objPtr;
char *cptr = lstringRepPtr->string;
(void)interp;
if (lstringRepPtr->strlen == 0) {
*objcptr = 0;
*objvptr = NULL;
return TCL_OK;
}
if (lstringRepPtr->elements == NULL) {
lstringRepPtr->elements = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*) * lstringRepPtr->strlen);
objPtr=lstringRepPtr->elements;
while (objPtr < &lstringRepPtr->elements[lstringRepPtr->strlen]) {
*objPtr = Tcl_NewStringObj(cptr++,1);
Tcl_IncrRefCount(*objPtr++);
}
}
*objvptr = lstringRepPtr->elements;
*objcptr = lstringRepPtr->strlen;
return TCL_OK;
}
/*
** UpdateStringRep
*/
static void
UpdateStringOfLString(Tcl_Obj *objPtr)
{
# define LOCAL_SIZE 64
int localFlags[LOCAL_SIZE], *flagPtr = NULL;
Tcl_ObjType const *typePtr = objPtr->typePtr;
char *p;
int bytesNeeded = 0;
int llen, i;
/*
* Handle empty list case first, so rest of the routine is simpler.
*/
llen = typePtr->lengthProc(objPtr);
if (llen <= 0) {
Tcl_InitStringRep(objPtr, NULL, 0);
return;
}
/*
* Pass 1: estimate space.
*/
if (llen <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
/* We know numElems <= LIST_MAX, so this is safe. */
flagPtr = (int *) Tcl_Alloc(llen*sizeof(int));
}
for (bytesNeeded = 0, i = 0; i < llen; i++) {
Tcl_Obj *elemObj;
const char *elemStr;
Tcl_Size elemLen;
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
typePtr->indexProc(NULL, objPtr, i, &elemObj);
Tcl_IncrRefCount(elemObj);
elemStr = Tcl_GetStringFromObj(elemObj, &elemLen);
/* Note TclScanElement updates flagPtr[i] */
bytesNeeded += Tcl_ScanCountedElement(elemStr, elemLen, &flagPtr[i]);
if (bytesNeeded < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
Tcl_DecrRefCount(elemObj);
}
if (bytesNeeded > INT_MAX - llen + 1) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
bytesNeeded += llen; /* Separating spaces and terminating nul */
/*
* Pass 2: generate the string repr.
*/
objPtr->bytes = (char *) Tcl_Alloc(bytesNeeded);
p = objPtr->bytes;
for (i = 0; i < llen; i++) {
Tcl_Obj *elemObj;
const char *elemStr;
Tcl_Size elemLen;
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
typePtr->indexProc(NULL, objPtr, i, &elemObj);
Tcl_IncrRefCount(elemObj);
elemStr = Tcl_GetStringFromObj(elemObj, &elemLen);
p += Tcl_ConvertCountedElement(elemStr, elemLen, p, flagPtr[i]);
*p++ = ' ';
Tcl_DecrRefCount(elemObj);
}
p[-1] = '\0'; /* Overwrite last space added */
/* Length of generated string */
objPtr->length = p - 1 - objPtr->bytes;
if (flagPtr != localFlags) {
Tcl_Free(flagPtr);
}
}
/*
*----------------------------------------------------------------------
*
* lLStringObjCmd --
*
* Script level command that creats an lstring Obj value.
*
* Results:
* Returns and lstring Obj value in the interp results.
*
* Side effects:
* Interp results modified.
*
*----------------------------------------------------------------------
*/
static int
lLStringObjCmd(
void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj * const objv[])
{
Tcl_Obj *lstringObj;
(void)clientData;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
}
lstringObj = my_NewLStringObj(interp, objc-1, &objv[1]);
if (lstringObj) {
Tcl_SetObjResult(interp, lstringObj);
return TCL_OK;
}
return TCL_ERROR;
}
/*
** lgen - Derived from TIP 192 - Lazy Lists
** Generate a list using a command provided as argument(s).
** The command computes the value for a given index.
*/
/*
* Internal rep for the Generate Series
*/
typedef struct LgenSeries {
Tcl_Interp *interp; // used to evaluate gen script
Tcl_Size len; // list length
Tcl_Size nargs; // Number of arguments in genFn including "index"
Tcl_Obj *genFnObj; // The preformed command as a list. Index is set in
// the last element (last argument)
} LgenSeries;
/*
* Evaluate the generation function.
* The provided funtion computes the value for a give index
*/
static Tcl_Obj*
lgen(
Tcl_Obj* objPtr,
Tcl_Size index)
{
LgenSeries *lgenSeriesPtr = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1;
Tcl_Obj *elemObj = NULL;
Tcl_Interp *intrp = lgenSeriesPtr->interp;
Tcl_Obj *genCmd = lgenSeriesPtr->genFnObj;
Tcl_Size endidx = lgenSeriesPtr->nargs-1;
if (0 <= index && index < lgenSeriesPtr->len) {
Tcl_Obj *indexObj = Tcl_NewWideIntObj(index);
Tcl_ListObjReplace(intrp, genCmd, endidx, 1, 1, &indexObj);
// EVAL DIRECT to avoid interfering with bytecode compile which may be
// active on the stack
int flags = TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT;
int status = Tcl_EvalObjEx(intrp, genCmd, flags);
elemObj = Tcl_GetObjResult(intrp);
if (status != TCL_OK) {
Tcl_SetObjResult(intrp, Tcl_ObjPrintf(
"Error: %s\nwhile executing %s\n",
elemObj ? Tcl_GetString(elemObj) : "NULL", Tcl_GetString(genCmd)));
return NULL;
}
}
return elemObj;
}
/*
* Abstract List Length function
*/
static Tcl_Size
lgenSeriesObjLength(Tcl_Obj *objPtr)
{
LgenSeries *lgenSeriesRepPtr = (LgenSeries *)objPtr->internalRep.twoPtrValue.ptr1;
return lgenSeriesRepPtr->len;
}
/*
* Abstract List Index function
*/
static int
lgenSeriesObjIndex(
Tcl_Interp *interp,
Tcl_Obj *lgenSeriesObjPtr,
Tcl_Size index,
Tcl_Obj **elemPtr)
{
LgenSeries *lgenSeriesRepPtr;
Tcl_Obj *element;
lgenSeriesRepPtr = (LgenSeries*)lgenSeriesObjPtr->internalRep.twoPtrValue.ptr1;
if (index < 0 || index >= lgenSeriesRepPtr->len)
return TCL_ERROR;
if (lgenSeriesRepPtr->interp == NULL && interp == NULL) {
return TCL_ERROR;
}
lgenSeriesRepPtr->interp = interp;
element = lgen(lgenSeriesObjPtr, index);
if (element) {
*elemPtr = element;
} else {
return TCL_ERROR;
}
return TCL_OK;
}
/*
** UpdateStringRep
*/
static void
UpdateStringOfLgen(Tcl_Obj *objPtr)
{
LgenSeries *lgenSeriesRepPtr;
Tcl_Obj *element;
Tcl_Size i;
size_t bytlen;
Tcl_Obj *tmpstr = Tcl_NewObj();
lgenSeriesRepPtr = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1;
for (i=0, bytlen=0; i<lgenSeriesRepPtr->len; i++) {
element = lgen(objPtr, i);
if (element) {
if (i) {
Tcl_AppendToObj(tmpstr," ",1);
}
Tcl_AppendObjToObj(tmpstr,element);
}
}
bytlen = Tcl_GetCharLength(tmpstr);
Tcl_InitStringRep(objPtr, Tcl_GetString(tmpstr), bytlen);
Tcl_DecrRefCount(tmpstr);
return;
}
/*
* ObjType Free Internal Rep function
*/
static void
FreeLgenInternalRep(Tcl_Obj *objPtr)
{
LgenSeries *lgenSeries = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1;
if (lgenSeries->genFnObj) {
Tcl_DecrRefCount(lgenSeries->genFnObj);
}
lgenSeries->interp = NULL;
Tcl_Free(lgenSeries);
objPtr->internalRep.twoPtrValue.ptr1 = 0;
}
static void DupLgenSeriesRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
/*
* Abstract List ObjType definition
*/
static Tcl_ObjType lgenType = {
"lgenseries",
FreeLgenInternalRep,
DupLgenSeriesRep,
UpdateStringOfLgen,
NULL, /* SetFromAnyProc */
TCL_OBJTYPE_V2(
lgenSeriesObjLength,
lgenSeriesObjIndex,
NULL, /* slice */
NULL, /* reverse */
NULL, /* get elements */
NULL, /* set element */
NULL) /* replace */
};
/*
* ObjType Duplicate Internal Rep Function
*/
static void
DupLgenSeriesRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
LgenSeries *srcLgenSeries = (LgenSeries*)srcPtr->internalRep.twoPtrValue.ptr1;
Tcl_Size repSize = sizeof(LgenSeries);
LgenSeries *copyLgenSeries = (LgenSeries*)Tcl_Alloc(repSize);
copyLgenSeries->interp = srcLgenSeries->interp;
copyLgenSeries->nargs = srcLgenSeries->nargs;
copyLgenSeries->len = srcLgenSeries->len;
copyLgenSeries->genFnObj = Tcl_DuplicateObj(srcLgenSeries->genFnObj);
Tcl_IncrRefCount(copyLgenSeries->genFnObj);
copyPtr->typePtr = &lgenType;
copyPtr->internalRep.twoPtrValue.ptr1 = copyLgenSeries;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
return;
}
/*
* Create a new lgen Tcl_Obj
*/
Tcl_Obj *
newLgenObj(
Tcl_Interp *interp,
int objc,
Tcl_Obj * const objv[])
{
Tcl_WideInt length;
LgenSeries *lGenSeriesRepPtr;
Tcl_Size repSize;
Tcl_Obj *lGenSeriesObj;
if (objc < 2) {
return NULL;
}
if (Tcl_GetWideIntFromObj(NULL, objv[0], &length) != TCL_OK
|| length < 0) {
return NULL;
}
lGenSeriesObj = Tcl_NewObj();
repSize = sizeof(LgenSeries);
lGenSeriesRepPtr = (LgenSeries*)Tcl_Alloc(repSize);
lGenSeriesRepPtr->interp = interp; //Tcl_CreateInterp();
lGenSeriesRepPtr->len = length;
// Allocate array of *obj for cmd + index + args
// objv length cmd arg1 arg2 arg3 ...
// argsv 0 1 2 3 ... index
lGenSeriesRepPtr->nargs = objc;
lGenSeriesRepPtr->genFnObj = Tcl_NewListObj(objc-1, objv+1);
// Addd 0 placeholder for index
Tcl_ListObjAppendElement(interp, lGenSeriesRepPtr->genFnObj, Tcl_NewIntObj(0));
Tcl_IncrRefCount(lGenSeriesRepPtr->genFnObj);
lGenSeriesObj->internalRep.twoPtrValue.ptr1 = lGenSeriesRepPtr;
lGenSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
lGenSeriesObj->typePtr = &lgenType;
if (length > 0) {
Tcl_InvalidateStringRep(lGenSeriesObj);
} else {
Tcl_InitStringRep(lGenSeriesObj, NULL, 0);
}
return lGenSeriesObj;
}
/*
* The [lgen] command
*/
static int
lGenObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj * const objv[])
{
Tcl_Obj *genObj = newLgenObj(interp, objc-1, &objv[1]);
if (genObj) {
Tcl_SetObjResult(interp, genObj);
return TCL_OK;
}
Tcl_WrongNumArgs(interp, 1, objv, "length cmd ?args?");
return TCL_ERROR;
}
/*
* lgen package init
*/
int Lgen_Init(Tcl_Interp *interp) {
if (Tcl_InitStubs(interp, "8.7", 0) == NULL) {
return TCL_ERROR;
}
Tcl_CreateObjCommand(interp, "lgen", lGenObjCmd, NULL, NULL);
Tcl_PkgProvide(interp, "lgen", "1.0");
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ABSListTest_Init --
*
* Provides Abstract List implemenations via new commands
*
* lstring command
* Usage:
* lstring /string/
*
* Description:
* Creates a list where each character in the string is treated as an
* element. The string is kept as a string, not an actual list. Indexing
* is done by char.
*
* lgen command
* Usage:
* lgen /length/ /cmd/ ?args...?
*
* The /cmd/ should take the last argument as the index value, and return
* a value for that element.
*
* Results:
* The commands listed above are added to the interp.
*
* Side effects:
* New commands defined.
*
*----------------------------------------------------------------------
*/
int Tcl_ABSListTest_Init(Tcl_Interp *interp) {
if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) {
return TCL_ERROR;
}
Tcl_CreateObjCommand(interp, "lstring", lLStringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "lgen", lGenObjCmd, NULL, NULL);
Tcl_PkgProvide(interp, "abstractlisttest", "1.0.0");
return TCL_OK;
}
|
Changes to generic/tclTestObj.c.
| ︙ | ︙ | |||
970 971 972 973 974 975 976 |
}
for (i = 0; i < len; ++i) {
Tcl_Obj *objP;
if (Tcl_ListObjIndex(interp, varPtr[varIndex], i, &objP)
!= TCL_OK) {
return TCL_ERROR;
}
| | | > | 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 |
}
for (i = 0; i < len; ++i) {
Tcl_Obj *objP;
if (Tcl_ListObjIndex(interp, varPtr[varIndex], i, &objP)
!= TCL_OK) {
return TCL_ERROR;
}
if (objP->refCount < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"Tcl_ListObjIndex returned object with ref count < 0",
TCL_INDEX_NONE));
/* Keep looping since we are also looping for leaks */
}
Tcl_BumpObj(objP);
}
break;
case LISTOBJ_GETELEMENTSMEMCHECK:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
|
| ︙ | ︙ |
Changes to generic/tclUtil.c.
| ︙ | ︙ | |||
119 120 121 122 123 124 125 | * stored directly in the wideValue, so no memory management is required * for it. This is a caching internalrep, 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. */ | | | | < < | | 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
* stored directly in the wideValue, so no memory management is required
* for it. This is a caching internalrep, 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.
*/
static const Tcl_ObjType endOffsetType = {
"end-offset", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
TCL_OBJTYPE_V1(TclLengthOne)
};
Tcl_Size
TclLengthOne(
TCL_UNUSED(Tcl_Obj *))
{
return 1;
}
|
| ︙ | ︙ | |||
1975 1976 1977 1978 1979 1980 1981 |
* is only valid when the lists are in canonical form.
*/
for (i = 0; i < objc; i++) {
Tcl_Size length;
objPtr = objv[i];
| | > | > | | 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 |
* is only valid when the lists are in canonical form.
*/
for (i = 0; i < objc; i++) {
Tcl_Size length;
objPtr = objv[i];
if (TclListObjIsCanonical(objPtr) ||
TclObjTypeHasProc(objPtr,indexProc)) {
continue;
}
(void)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) &&
!TclObjTypeHasProc(objPtr,indexProc)) {
continue;
}
if (resPtr) {
Tcl_Obj *elemPtr = NULL;
Tcl_ListObjIndex(NULL, objPtr, 0, &elemPtr);
if (elemPtr == NULL) {
continue;
}
if (Tcl_GetString(elemPtr)[0] == '#' || TCL_OK
!= Tcl_ListObjAppendList(NULL, resPtr, objPtr)) {
/* Abandon ship! */
Tcl_DecrRefCount(resPtr);
goto slow;
}
} else {
resPtr = TclDuplicatePureObj(
NULL, objPtr, &tclListType);
if (!resPtr) {
return NULL;
}
}
}
if (!resPtr) {
TclNewObj(resPtr);
|
| ︙ | ︙ | |||
3499 3500 3501 3502 3503 3504 3505 |
Tcl_WideInt *widePtr) /* Location filled in with an integer
* representing an index. */
{
Tcl_ObjInternalRep *irPtr;
Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
void *cd;
| | | 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 |
Tcl_WideInt *widePtr) /* Location filled in with an integer
* representing an index. */
{
Tcl_ObjInternalRep *irPtr;
Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
void *cd;
while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) {
Tcl_ObjInternalRep ir;
Tcl_Size length;
const char *bytes = Tcl_GetStringFromObj(objPtr, &length);
if (*bytes != 'e') {
int numType;
const char *opPtr;
|
| ︙ | ︙ | |||
3685 3686 3687 3688 3689 3690 3691 |
}
}
}
parseOK:
/* Success. Store the new internal rep. */
ir.wideValue = offset;
| | | 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 |
}
}
}
parseOK:
/* Success. Store the new internal rep. */
ir.wideValue = offset;
Tcl_StoreInternalRep(objPtr, &endOffsetType, &ir);
}
offset = irPtr->wideValue;
if (offset == WIDE_MAX) {
*widePtr = (endValue == -1) ? WIDE_MAX : endValue + 1;
} else if (offset == WIDE_MIN) {
|
| ︙ | ︙ | |||
3789 3790 3791 3792 3793 3794 3795 |
int after, /* Value to return for index after end */
int *indexPtr) /* Where to write the encoded answer, not NULL */
{
Tcl_WideInt wide;
int idx;
if (TCL_OK == GetWideForIndex(interp, objPtr, (unsigned)TCL_INDEX_END , &wide)) {
| | | 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 |
int after, /* Value to return for index after end */
int *indexPtr) /* Where to write the encoded answer, not NULL */
{
Tcl_WideInt wide;
int idx;
if (TCL_OK == GetWideForIndex(interp, objPtr, (unsigned)TCL_INDEX_END , &wide)) {
const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &endOffsetType);
if (irPtr && irPtr->wideValue >= 0) {
/* "int[+-]int" syntax, works the same here as "int" */
irPtr = NULL;
}
/*
* We parsed an end+offset index value.
* wide holds the offset value in the range WIDE_MIN...WIDE_MAX.
|
| ︙ | ︙ |
Changes to generic/tclVar.c.
| ︙ | ︙ | |||
241 242 243 244 245 246 247 |
* scalar variable
* twoPtrValue.ptr2: pointer to the element name string (owned by this
* Tcl_Obj), or NULL if it is a scalar variable
*/
static const Tcl_ObjType localVarNameType = {
"localVarName",
| | > | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 |
* scalar variable
* twoPtrValue.ptr2: pointer to the element name string (owned by this
* Tcl_Obj), or NULL if it is a scalar variable
*/
static const Tcl_ObjType localVarNameType = {
"localVarName",
FreeLocalVarName, DupLocalVarName, NULL, NULL,
TCL_OBJTYPE_V0
};
#define LocalSetInternalRep(objPtr, index, namePtr) \
do { \
Tcl_ObjInternalRep ir; \
Tcl_Obj *ptr = (namePtr); \
if (ptr) {Tcl_IncrRefCount(ptr);} \
|
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
irPtr = TclFetchInternalRep((objPtr), &localVarNameType); \
(name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \
(index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : TCL_INDEX_NONE; \
} while (0)
static const Tcl_ObjType parsedVarNameType = {
"parsedVarName",
| | > | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 |
irPtr = TclFetchInternalRep((objPtr), &localVarNameType); \
(name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \
(index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : TCL_INDEX_NONE; \
} while (0)
static const Tcl_ObjType parsedVarNameType = {
"parsedVarName",
FreeParsedVarName, DupParsedVarName, NULL, NULL,
TCL_OBJTYPE_V0
};
#define ParsedSetInternalRep(objPtr, arrayPtr, elem) \
do { \
Tcl_ObjInternalRep ir; \
Tcl_Obj *ptr1 = (arrayPtr); \
Tcl_Obj *ptr2 = (elem); \
|
| ︙ | ︙ | |||
3093 3094 3095 3096 3097 3098 3099 |
ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr);
/*
* Make sure that these objects (which we need throughout the body of the
* loop) don't vanish.
*/
| | | 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 |
ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr);
/*
* Make sure that these objects (which we need throughout the body of the
* loop) don't vanish.
*/
varListObj = TclDuplicatePureObj(interp, objv[1], &tclListType);
if (!varListObj) {
return TCL_ERROR;
}
scriptObj = objv[3];
Tcl_IncrRefCount(scriptObj);
/*
|
| ︙ | ︙ | |||
4070 4071 4072 4073 4074 4075 4076 | /* * We needn't worry about traces invalidating arrayPtr: should that be * the case, TclPtrSetVarIdx will return NULL so that we break out of * the loop and return an error. */ copyListObj = | | | 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 |
/*
* We needn't worry about traces invalidating arrayPtr: should that be
* the case, TclPtrSetVarIdx will return NULL so that we break out of
* the loop and return an error.
*/
copyListObj =
TclDuplicatePureObj(interp, arrayElemObj, &tclListType);
if (!copyListObj) {
return TCL_ERROR;
}
for (i=0 ; i<elemLen ; i+=2) {
Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
|
| ︙ | ︙ |
Changes to library/tcltest/tcltest.tcl.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
variable Version 2.5.6
# 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]
variable patchLevel [info patchlevel]
##### Export the public tcltest procs; several categories
#
# Export the main functional commands that do useful things
namespace export cleanupTests loadTestedCommands makeDirectory \
makeFile removeDirectory removeFile runAllTests test
| > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
variable Version 2.5.6
# 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]
variable patchLevel [info patchlevel]
variable fullutf [package vsatisfies $version 8.7-]
##### Export the public tcltest procs; several categories
#
# Export the main functional commands that do useful things
namespace export cleanupTests loadTestedCommands makeDirectory \
makeFile removeDirectory removeFile runAllTests test
|
| ︙ | ︙ | |||
1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 |
# Results:
# The transformed strings
#
# Side effects:
# None.
proc tcltest::Asciify {s} {
set print ""
foreach c [split $s ""] {
if {[string is print $c] && (($c <= "\x7E") || ($c == "\n"))} {
append print $c
| > | | | | | 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 |
# Results:
# The transformed strings
#
# Side effects:
# None.
proc tcltest::Asciify {s} {
variable fullutf
set print ""
foreach c [split $s ""] {
if {[string is print $c] && (($c <= "\x7E") || ($c == "\n"))} {
append print $c
} elseif {$c < "\u0100"} {
append print \\x[format %02X [scan $c %c]]
} elseif {$fullutf && ($c >= "\U10000")} {
append print \\U[format %08X [scan $c %c]]
} else {
append print \\u[format %04X [scan $c %c]]
}
}
return $print
}
# tcltest::ConstraintInitializer --
#
|
| ︙ | ︙ |
Added tests/abstractlist.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 |
# Exercise AbstractList via the "lstring" command defined in tclTestABSList.c
#
# Copyright © 2022 Brian Griffin
#
# 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::*
}
catch {
::tcltest::loadTestedCommands
package require -exact tcl::test [info patchlevel]
}
testConstraint testevalex [llength [info commands testevalex]]
set abstractlisttestvars [info var *]
proc value-cmp {vara varb} {
upvar $vara a
upvar $varb b
set ta [tcl::unsupported::representation $a]
set tb [tcl::unsupported::representation $b]
return [string compare $ta $tb]
}
set str "My name is Inigo Montoya. You killed my father. Prepare to die!"
set str2 "Vizzini: HE DIDN'T FALL? INCONCEIVABLE. Inigo Montoya: You keep using that word. I do not think it means what you think it means."
test abstractlist-1.0 {error cases} -body {
lstring
} \
-returnCodes 1 \
-result {wrong # args: should be "lstring string"}
test abstractlist-1.1 {error cases} -body {
lstring a b c
} -returnCodes 1 \
-result {wrong # args: should be "lstring string"}
test abstractlist-2.0 {no shimmer llength} {
set l [lstring $str]
set l-isa [testobj objtype $l]
set len [llength $l]
set l-isa2 [testobj objtype $l]
list $l ${l-isa} ${len} ${l-isa2}
} {{M y { } n a m e { } i s { } I n i g o { } M o n t o y a . { } Y o u { } k i l l e d { } m y { } f a t h e r . { } P r e p a r e { } t o { } d i e !} lstring 63 lstring}
test abstractlist-2.1 {no shimmer lindex} {
set l [lstring $str]
set l-isa [testobj objtype $l]
set ele [lindex $l 22]
set l-isa2 [testobj objtype $l]
list $l ${l-isa} ${ele} ${l-isa2}
} {{M y { } n a m e { } i s { } I n i g o { } M o n t o y a . { } Y o u { } k i l l e d { } m y { } f a t h e r . { } P r e p a r e { } t o { } d i e !} lstring y lstring}
test abstractlist-2.2 {no shimmer lreverse} {
set l [lstring $str]
set l-isa [testobj objtype $l]
set r [lreverse $l]
set r-isa [testobj objtype $r]
set l-isa2 [testobj objtype $l]
list $r ${l-isa} ${r-isa} ${l-isa2}
} {{! e i d { } o t { } e r a p e r P { } . r e h t a f { } y m { } d e l l i k { } u o Y { } . a y o t n o M { } o g i n I { } s i { } e m a n { } y M} lstring lstring lstring}
test abstractlist-2.3 {no shimmer lrange} {
set l [lstring $str]
set l-isa [testobj objtype $l]
set il [lsearch -all [lstring $str] { }]
set l-isa2 [testobj objtype $l]
lappend il [llength $l]
set start 0
set words [lmap i $il {
set w [join [lrange $l $start $i-1] {} ]
set start [expr {$i+1}]
set w
}]
set l-isa3 [testobj objtype $l]
list ${l-isa} $il ${l-isa2} ${l-isa3} $words
} {lstring {2 7 10 16 25 29 36 39 47 55 58 63} lstring lstring {My name is Inigo Montoya. You killed my father. Prepare to die!}}
test abstractlist-2.4 {no shimmer foreach} {
set l [lstring $str]
set l-isa [testobj objtype $l]
set word {}
set words {}
foreach c $l {
if {$c eq { }} {
lappend words $word
set word {}
} else {
append word $c
}
}
if {$word ne ""} {
lappend words $word
}
set l-isa2 [testobj objtype $l]
list ${l-isa} ${l-isa2} $words
} {lstring lstring {My name is Inigo Montoya. You killed my father. Prepare to die!}}
#
# The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring.
#
test abstractlist-2.5 {!no shimmer lreplace} {
set l [lstring $str2]
set l-isa [testobj objtype $l]
set m [lreplace $l 18 23 { } f a i l ?]
set m-isa [testobj objtype $m]
set l-isa1 [testobj objtype $l]
list ${l-isa} $m ${m-isa} ${l-isa1}
} {lstring {V i z z i n i : { } H E { } D I D N ' T { } f a i l ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring lstring}
test abstractlist-2.6 {no shimmer ledit} {
# "ledit m 9 8 S"
set l [lstring $str2]
set l-isa [testobj objtype $l]
set e [ledit l 9 8 S]
set e-isa [testobj objtype $e]
list ${l-isa} $e ${e-isa}
} {lstring {V i z z i n i : { } S H E { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring}
test abstractlist-2.7 {no shimmer linsert} -body {
# "ledit m 9 8 S"
set l [lstring $str2]
set l-isa [testobj objtype $l]
set i [linsert $l 12 {*}[split "almost " {}]]
set i-isa [testobj objtype $i]
set res [list ${l-isa} $i ${i-isa}]
set p [lpop i 23]
set p-isa [testobj objtype $p]
set i-isa2 [testobj objtype $i]
lappend res $p ${p-isa} $i ${i-isa2}
} -cleanup {
unset l i l-isa i-isa res p p-isa
} -result {lstring {V i z z i n i : { } H E { } a l m o s t { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring ' none {V i z z i n i : { } H E { } a l m o s t { } D I D N T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring}
test abstractlist-2.8 {shimmer lassign} {
set l [lstring Inconceivable]
set l-isa [testobj objtype $l]
set l2 [lassign $l i n c]
set l-isa2 [testobj objtype $l]
set l2-isa [testobj objtype $l2]
list $l ${l-isa} $l2 ${l-isa2} ${l2-isa}
} {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} lstring lstring}
test abstractlist-2.9 {no shimmer lremove} {
set l [lstring Inconceivable]
set l-isa [testobj objtype $l]
set l2 [lremove $l 0 1]
set l-isa2 [testobj objtype $l]
set l2-isa [testobj objtype $l2]
list $l ${l-isa} $l2 ${l-isa2} ${l2-isa}
} {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring}
test abstractlist-2.10 {shimmer lreverse} {
set l [lstring Inconceivable]
set l-isa [testobj objtype $l]
set l2 [lreverse $l]
set l-isa2 [testobj objtype $l]
set l2-isa [testobj objtype $l2]
list $l ${l-isa} $l2 ${l-isa2} ${l2-isa}
} {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring}
test abstractlist-2.11 {shimmer lset} {
set l [lstring Inconceivable]
set l-isa [testobj objtype $l]
set m [lset l 2 k]
set m-isa [testobj objtype $m]
list $l ${l-isa} $m ${m-isa} [value-cmp l m]
} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0}
# lrepeat
test abstractlist-2.12 {shimmer lrepeat} {
set l [lstring Inconceivable]
set l-isa [testobj objtype $l]
set m [lrepeat 3 $l]
set m-isa [testobj objtype $m]
set n [lindex $m 1]
list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n]
} {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0}
test abstractlist-2.13 {no shimmer join llength==1} {
set l [lstring G]
set l-isa [testobj objtype $l]
set j [join $l :]
set j-isa [testobj objtype $j]
list ${l-isa} $l ${j-isa} $j
} {lstring G none G}
test abstractlist-2.14 {error case lset multiple indicies} -body {
set l [lstring Inconceivable]
set l-isa [testobj objtype $l]
set m [lset l 2 0 1 k]
set m-isa [testobj objtype $m]
list $l ${l-isa} $m ${m-isa} [value-cmp l m]
} -returnCodes 1 \
-result {Multiple indicies not supported by lstring.}
# lsort
test abstractlist-3.0 {no shimmer llength} {
set l [lstring -not SLICE $str]
set l-isa [testobj objtype $l]
set len [llength $l]
set l-isa2 [testobj objtype $l]
list $l ${l-isa} ${len} ${l-isa2}
} {{M y { } n a m e { } i s { } I n i g o { } M o n t o y a . { } Y o u { } k i l l e d { } m y { } f a t h e r . { } P r e p a r e { } t o { } d i e !} lstring 63 lstring}
test abstractlist-3.1 {no shimmer lindex} {
set l [lstring -not SLICE $str]
set l-isa [testobj objtype $l]
set n 22
set ele [lindex $l $n] ;# exercise INST_LIST_INDEX
set l-isa2 [testobj objtype $l]
list $l ${l-isa} ${ele} ${l-isa2}
} {{M y { } n a m e { } i s { } I n i g o { } M o n t o y a . { } Y o u { } k i l l e d { } m y { } f a t h e r . { } P r e p a r e { } t o { } d i e !} lstring y lstring}
test abstractlist-3.2 {no shimmer lreverse} {
set l [lstring -not SLICE $str]
set l-isa [testobj objtype $l]
set r [lreverse $l]
set r-isa [testobj objtype $r]
set l-isa2 [testobj objtype $l]
list $r ${l-isa} ${r-isa} ${l-isa2}
} {{! e i d { } o t { } e r a p e r P { } . r e h t a f { } y m { } d e l l i k { } u o Y { } . a y o t n o M { } o g i n I { } s i { } e m a n { } y M} lstring lstring lstring}
test abstractlist-3.3 {shimmer lrange} {
set l [lstring -not SLICE $str]
set l-isa [testobj objtype $l]
set il [lsearch -all [lstring -not SLICE $str] { }]
set l-isa2 [testobj objtype $l]
lappend il [llength $l]
set start 0
set words [lmap i $il {
set w [join [lrange $l $start $i-1] {} ]
set start [expr {$i+1}]
set w
}]
set l-isa3 [testobj objtype $l]; # lrange defaults to list behavior
list ${l-isa} $il ${l-isa2} ${l-isa3} $words
} {lstring {2 7 10 16 25 29 36 39 47 55 58 63} lstring list {My name is Inigo Montoya. You killed my father. Prepare to die!}}
test abstractlist-3.4 {no shimmer foreach} {
set l [lstring -not SLICE $str]
set l-isa [testobj objtype $l]
set word {}
set words {}
foreach c $l {
if {$c eq { }} {
lappend words $word
set word {}
} else {
append word $c
}
}
if {$word ne ""} {
lappend words $word
}
set l-isa2 [testobj objtype $l]
list ${l-isa} ${l-isa2} $words
} {lstring lstring {My name is Inigo Montoya. You killed my father. Prepare to die!}}
#
# The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring.
#
test abstractlist-3.5 {!no shimmer lreplace} {
set l [lstring -not SLICE $str2]
set l-isa [testobj objtype $l]
set m [lreplace $l 18 23 { } f a i l ?]
set m-isa [testobj objtype $m]
set l-isa1 [testobj objtype $l]
list ${l-isa} $m ${m-isa} ${l-isa1}
} {lstring {V i z z i n i : { } H E { } D I D N ' T { } f a i l ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring lstring}
test abstractlist-3.6 {no shimmer ledit} {
# "ledit m 9 8 S"
set l [lstring -not SLICE $str2]
set l-isa [testobj objtype $l]
set e [ledit l 9 8 S]
set e-isa [testobj objtype $e]
list ${l-isa} $e ${e-isa}
} {lstring {V i z z i n i : { } S H E { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring}
test abstractlist-3.7 {no shimmer linsert} {
# "ledit m 9 8 S"
set res {}
set l [lstring -not SLICE $str2]
set l-isa [testobj objtype $l]
set i [linsert $l 12 {*}[split "almost " {}]]
set i-isa [testobj objtype $i]
set res [list ${l-isa} $i ${i-isa}]
set p [lpop i 23]
set p-isa [testobj objtype $p]
set i-isa2 [testobj objtype $i]
lappend res $p ${p-isa} $i ${i-isa2}
} {lstring {V i z z i n i : { } H E { } a l m o s t { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring ' none {V i z z i n i : { } H E { } a l m o s t { } D I D N T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring}
test abstractlist-3.8 {shimmer lassign} {
set l [lstring -not SLICE Inconceivable]
set l-isa [testobj objtype $l]
set l2 [lassign $l i n c] ;# must be using lrange internally
set l-isa2 [testobj objtype $l]
set l2-isa [testobj objtype $l2]
list $l ${l-isa} $l2 ${l-isa2} ${l2-isa}
} {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} list list}
test abstractlist-3.9 {no shimmer lremove} {
set l [lstring -not SLICE Inconceivable]
set l-isa [testobj objtype $l]
set l2 [lremove $l 0 1]
set l-isa2 [testobj objtype $l]
set l2-isa [testobj objtype $l2]
list $l ${l-isa} $l2 ${l-isa2} ${l2-isa}
} {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring}
test abstractlist-3.10 {shimmer lreverse} {
set l [lstring -not SLICE Inconceivable]
set l-isa [testobj objtype $l]
set l2 [lreverse $l]
set l-isa2 [testobj objtype $l]
set l2-isa [testobj objtype $l2]
list $l ${l-isa} $l2 ${l-isa2} ${l2-isa}
} {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring}
test abstractlist-3.11 {shimmer lset} {
set l [lstring -not SLICE Inconceivable]
set l-isa [testobj objtype $l]
set four 4
set m [lset l $four-2 k]
set m-isa [testobj objtype $m]
list $l ${l-isa} $m ${m-isa} [value-cmp l m]
} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0}
# lrepeat
test abstractlist-3.12 {shimmer lrepeat} {
set l [lstring -not SLICE Inconceivable]
set l-isa [testobj objtype $l]
set m [lrepeat 3 $l]
set m-isa [testobj objtype $m]
set n [lindex $m 1]
list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n]
} {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0}
# lsort
foreach not {{} REVERSE SLICE SETELEMENT REPLACE GETELEMENTS} {
testConstraint [format "%sShimmer" [string totitle $not]] [expr {$not eq ""}]
set options [expr {$not ne "" ? "-not $not" : ""}]
test abstractlist-$not-4.0 {no shimmer llength} {
set l [lstring {*}$options $str]
set l-isa [testobj objtype $l]
set len [llength $l]
set l-isa2 [testobj objtype $l]
list $l ${l-isa} ${len} ${l-isa2}
} {{M y { } n a m e { } i s { } I n i g o { } M o n t o y a . { } Y o u { } k i l l e d { } m y { } f a t h e r . { } P r e p a r e { } t o { } d i e !} lstring 63 lstring}
test abstractlist-$not-4.1 {no shimmer lindex} {
set l [lstring {*}$options $str]
set l-isa [testobj objtype $l]
set ele [lindex $l 22]
set l-isa2 [testobj objtype $l]
list $l ${l-isa} ${ele} ${l-isa2}
} {{M y { } n a m e { } i s { } I n i g o { } M o n t o y a . { } Y o u { } k i l l e d { } m y { } f a t h e r . { } P r e p a r e { } t o { } d i e !} lstring y lstring}
test abstractlist-$not-4.2 {lreverse} ReverseShimmer {
set l [lstring {*}$options $str]
set l-isa [testobj objtype $l]
set r [lreverse $l]
set r-isa [testobj objtype $r]
set l-isa2 [testobj objtype $l]
list $r ${l-isa} ${r-isa} ${l-isa2}
} {{! e i d { } o t { } e r a p e r P { } . r e h t a f { } y m { } d e l l i k { } u o Y { } . a y o t n o M { } o g i n I { } s i { } e m a n { } y M} lstring lstring lstring}
test abstractlist-$not-4.3 {no shimmer lrange} RangeShimmer {
set l [lstring {*}$options $str]
set l-isa [testobj objtype $l]
set il [lsearch -all [lstring {*}$options $str] { }]
set l-isa2 [testobj objtype $l]
lappend il [llength $l]
set start 0
set words [lmap i $il {
set w [join [lrange $l $start $i-1] {} ]
set start [expr {$i+1}]
set w
}]
set l-isa3 [testobj objtype $l]
list ${l-isa} $il ${l-isa2} ${l-isa3} $words
} {lstring {2 7 10 16 25 29 36 39 47 55 58 63} lstring lstring {My name is Inigo Montoya. You killed my father. Prepare to die!}}
test abstractlist-$not-4.4 {no shimmer foreach} {
set l [lstring {*}$options $str]
set l-isa [testobj objtype $l]
set word {}
set words {}
foreach c $l {
if {$c eq { }} {
lappend words $word
set word {}
} else {
append word $c
}
}
if {$word ne ""} {
lappend words $word
}
set l-isa2 [testobj objtype $l]
list ${l-isa} ${l-isa2} $words
} {lstring lstring {My name is Inigo Montoya. You killed my father. Prepare to die!}}
#
# The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring.
#
test abstractlist-$not-4.5 {!no shimmer lreplace} RangeShimmer {
set l [lstring {*}$options $str2]
set l-isa [testobj objtype $l]
set m [lreplace $l 18 23 { } f a i l ?]
set m-isa [testobj objtype $m]
set l-isa1 [testobj objtype $l]
list ${l-isa} $m ${m-isa} ${l-isa1}
} {lstring {V i z z i n i : { } H E { } D I D N ' T { } f a i l ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} list lstring}
test abstractlist-$not-4.6 {no shimmer ledit} {SetelementShimmer ReplaceShimmer} {
# "ledit m 9 8 S"
set l [lstring {*}$options $str2]
set l-isa [testobj objtype $l]
set e [ledit l 9 8 S]
set e-isa [testobj objtype $e]
list ${l-isa} $e ${e-isa}
} {lstring {V i z z i n i : { } S H E { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring}
test abstractlist-$not-4.7 {no shimmer linsert} {ReplaceShimmer GetelementsShimmer} {
# "ledit m 9 8 S"
set l [lstring {*}$options $str2]
set l-isa [testobj objtype $l]
set i [linsert $l 12 {*}[split "almost " {}]]
set i-isa [testobj objtype $i]
set res [list ${l-isa} $i ${i-isa}]
set p [lpop i 23]
set p-isa [testobj objtype $p]
set i-isa2 [testobj objtype $i]
lappend res $p ${p-isa} $i ${i-isa2}
} {lstring {V i z z i n i : { } H E { } a l m o s t { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring ' none {V i z z i n i : { } H E { } a l m o s t { } D I D N T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring}
# lassign probably uses lrange internally
test abstractlist-$not-4.8 {shimmer lassign} RangeShimmer {
set l [lstring {*}$options Inconceivable]
set l-isa [testobj objtype $l]
set l2 [lassign $l i n c]
set l-isa2 [testobj objtype $l]
set l2-isa [testobj objtype $l2]
list $l ${l-isa} $l2 ${l-isa2} ${l2-isa}
} {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} lstring lstring}
test abstractlist-$not-4.9 {no shimmer lremove} ReplaceShimmer {
set l [lstring {*}$options Inconceivable]
set l-isa [testobj objtype $l]
set l2 [lremove $l 0 1]
set l-isa2 [testobj objtype $l]
set l2-isa [testobj objtype $l2]
list $l ${l-isa} $l2 ${l-isa2} ${l2-isa}
} {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring}
test abstractlist-$not-4.10 {shimmer lreverse} ReverseShimmer {
set l [lstring {*}$options Inconceivable]
set l-isa [testobj objtype $l]
set l2 [lreverse $l]
set l-isa2 [testobj objtype $l]
set l2-isa [testobj objtype $l2]
list $l ${l-isa} $l2 ${l-isa2} ${l2-isa}
} {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring}
test abstractlist-$not-4.11 {shimmer lset} SetelementShimmer {
set l [lstring {*}$options Inconceivable]
set l-isa [testobj objtype $l]
set m [lset l 2 k]
set m-isa [testobj objtype $m]
list $l ${l-isa} $m ${m-isa} [value-cmp l m]
} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0}
test abstractlist-$not-4.11x {lset not compiled} {SetelementShimmer testevalex} {
set l [lstring {*}$options Inconceivable]
set l-isa [testobj objtype $l]
set m [testevalex {lset l 2 k}]
set m-isa [testobj objtype $m]
list $l ${l-isa} $m ${m-isa} [value-cmp l m]
} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0}
test abstractlist-$not-4.11e {error case lset multiple indicies} \
-constraints {SetelementShimmer testevalex} -body {
set l [lstring Inconceivable]
set l-isa [testobj objtype $l]
set m [testevalex {lset l 2 0 1 k}]
set m-isa [testobj objtype $m]
list $l ${l-isa} $m ${m-isa} [value-cmp l m]
} -returnCodes 1 \
-result {Multiple indicies not supported by lstring.}
# lrepeat
test abstractlist-$not-4.12 {shimmer lrepeat} {
set l [lstring {*}$options Inconceivable]
set l-isa [testobj objtype $l]
set m [lrepeat 3 $l]
set m-isa [testobj objtype $m]
set n [lindex $m 1]
list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n]
} {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0}
# Disable constraint
testConstraint [format "%sShimmer" [string totitle $not]] 1
}
#
# Test fix for bug in TEBC for STR CONCAT, and LIST INDEX
# instructions.
# This example abstract list (lgen) causes a rescursive call in TEBC,
# stack management was not included for these instructions in TEBC.
#
test abstractlist-lgen-bug {bug in str concat and list operations} -setup {
set lgenfile [makeFile {
# Test TIP 192 - Lazy Lists
set res {}
set cntr 0
# Fatal error here when [source]'d -- It is a refcounting problem...
lappend res Index*2:[lgen 1 expr 2* ]:--
set x [lseq 17]
set y [lgen 17 apply {{index} {expr {$index * 6}}}] ;# expr * 6
foreach i $x n $y {
lappend res "$i -> $n"
}
proc my_expr {offset index} {
expr {$index + $offset}
}
lappend res my_expr(3):[my_expr 3 0]
lappend res [set ss [lgen 15 my_expr 7]]
lappend res s2:[list "Index+7:" $ss ":--"]
lappend res foo:[list "Index-8:" [lgen 15 my_expr -8] ":--"]
set 9 [lgen 15 my_expr 7]
lappend res 9len=[llength $9]
lappend res 9(3)=[lindex $9 3]
lappend res bar:[list "Index+7:" $9 ":--"]
lappend res Index+7:$9:--
lappend res Index+7:[lgen 15 my_expr 7]:--
proc fib {phi n} {
set d [expr {round(pow($phi, $n) / sqrt(5.0))}]
return $d
}
set phi [expr {(1 + sqrt(5.0)) / 2.0}]
lappend res fib:[lmap n [lseq 5] {fib $phi $n}]
set x [lgen 20 fib $phi]
lappend res "First 20 fibbinacci:[lgen 20 fib $phi]"
lappend res "First 20 fibbinacci from x :$x"
unset x
lappend res Good-Bye!
set res
} source.file]
} -body {
set tcl_traceExec 0
set tcl_traceCompile 0
set f $lgenfile
#set script [format "puts ====-%s-====\nsource %s\nputs ====-done-====\n" $f $f]
set script [format "source %s" $f]
#puts stderr "eval $script"
eval $script
} -cleanup {
removeFile source.file
unset res
} -result {Index*2:0:-- {0 -> 0} {1 -> 6} {2 -> 12} {3 -> 18} {4 -> 24} {5 -> 30} {6 -> 36} {7 -> 42} {8 -> 48} {9 -> 54} {10 -> 60} {11 -> 66} {12 -> 72} {13 -> 78} {14 -> 84} {15 -> 90} {16 -> 96} my_expr(3):3 {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} {s2:Index+7: {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} :--} {foo:Index-8: {-8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6} :--} 9len=15 9(3)=10 {bar:Index+7: {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} :--} {Index+7:7 8 9 10 11 12 13 14 15 16 17 18 19 20 21:--} {Index+7:7 8 9 10 11 12 13 14 15 16 17 18 19 20 21:--} {fib:0 1 1 2 3} {First 20 fibbinacci:0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181} {First 20 fibbinacci from x :0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181} Good-Bye!}
test abstractlist-lgen-bug2 {bug in foreach} -body {
set x [lseq 17]
set y [lgen 17 expr 6*]
lappend res x-[lrange [tcl::unsupported::representation $x] 0 3]
lappend res y-[lrange [tcl::unsupported::representation $y] 0 3]
foreach i $x n $y {
lappend res "$i -> $n"
}
lappend res x-[lrange [tcl::unsupported::representation $x] 0 3]
lappend res y-[lrange [tcl::unsupported::representation $y] 0 3]
} -cleanup {
unset res
} -result {{x-value is a arithseries} {y-value is a lgenseries} {0 -> 0} {1 -> 6} {2 -> 12} {3 -> 18} {4 -> 24} {5 -> 30} {6 -> 36} {7 -> 42} {8 -> 48} {9 -> 54} {10 -> 60} {11 -> 66} {12 -> 72} {13 -> 78} {14 -> 84} {15 -> 90} {16 -> 96} {x-value is a arithseries} {y-value is a lgenseries}}
# scalar values
test abstractlist-int {TclLengthOne: anti-shimmer of boolean, int, double, bignum} {
set res {}
foreach i [list [expr {1+0}] [expr {true}] [expr {3.141592}] [expr {round(double(0x7fffffffffffffff))}]] {
lappend res [testobj objtype $i]
lappend res [llength $i]
lappend res [testobj objtype $i]
}
#set w [expr {3.141592}]
#lappend res [testobj objtype $w] [llength $w] [testobj objtype $w]
set res
} {int 1 int boolean 1 boolean double 1 double bignum 1 bignum}
# lsort
# cleanup
::tcltest::cleanupTests
proc my_abstl_cleanup {vars} {
set nowvars [uplevel info vars]
foreach var $nowvars {
if {$var ni $vars} {
uplevel unset $var
lappend clean-list $var
}
}
return ${clean-list}
}
my_abstl_cleanup $abstractlisttestvars
|
Changes to tests/binary.test.
| ︙ | ︙ | |||
2013 2014 2015 2016 2017 2018 2019 |
} \x3F\xCC\xCC\xCD
test binary-53.19 {Tcl_BinaryObjCmd: format} {} {
set a {1.6 3.4}
binary format r1 $a
} \xCD\xCC\xCC\x3F
test binary-53.20 {Tcl_BinaryObjCmd: float Inf} {} {
binary format R Inf
| | | | 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 |
} \x3F\xCC\xCC\xCD
test binary-53.19 {Tcl_BinaryObjCmd: format} {} {
set a {1.6 3.4}
binary format r1 $a
} \xCD\xCC\xCC\x3F
test binary-53.20 {Tcl_BinaryObjCmd: float Inf} {} {
binary format R Inf
} \x7F\x80\x00\x00
test binary-53.21 {Tcl_BinaryObjCmd: float Inf} {} {
binary format r Inf
} \x00\x00\x80\x7F
test binary-53.22 {Binary float Inf round trip} -body {
binary scan [binary format R Inf] R inf
binary scan [binary format R -Inf] R inf_
list $inf $inf_
} -result {Inf -Inf}
test binary-53.23 {Binary float round to FLT_MAX} -body {
binary scan [binary format H* 7f7fffff] R fltmax
|
| ︙ | ︙ |
Changes to tests/chanio.test.
| ︙ | ︙ | |||
1100 1101 1102 1103 1104 1105 1106 |
set f [open $path(test1)]
chan configure $f -encoding shiftjis -profile tcl8
lappend x [chan gets $f line] $line
lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f]
lappend x [chan gets $f line] $line
} -cleanup {
chan close $f
| | | 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 |
set f [open $path(test1)]
chan configure $f -encoding shiftjis -profile tcl8
lappend x [chan gets $f line] $line
lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f]
lappend x [chan gets $f line] $line
} -cleanup {
chan close $f
} -result [list 16 "123456789012301\x82" 18 0 1 -1 ""]
test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup {
variable x ""
} -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
|
| ︙ | ︙ |
Changes to tests/cmdAH.test.
| ︙ | ︙ | |||
203 204 205 206 207 208 209 |
}
if {$enc eq "utf-16$endian" || $enc eq "utf-32$endian"} {
return [string range $enc 0 5]
}
return ""
}
| < < < < < < < < < < < < < < < < < < | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 |
}
if {$enc eq "utf-16$endian" || $enc eq "utf-32$endian"} {
return [string range $enc 0 5]
}
return ""
}
#
# Check errors for invalid number of arguments
proc badnumargs {id cmd cmdargs} {
variable numargErrors
test $id.a "Syntax error: $cmd $cmdargs" \
-body [list {*}$cmd {*}$cmdargs] \
-result $numargErrors($cmd) \
|
| ︙ | ︙ | |||
350 351 352 353 354 355 356 |
unknownencodingtest cmdAH-4.3.6 {convertfrom -failindex ABC}
unknownencodingtest cmdAH-4.3.7 {convertfrom -profile ABC}
unknownencodingtest cmdAH-4.3.8 {convertfrom nosuchencoding ABC}
unknownencodingtest cmdAH-4.3.9 {convertfrom -failindex VAR -profile ABC}
unknownencodingtest cmdAH-4.3.10 {convertfrom -profile strict -failindex ABC}
testconvert cmdAH-4.3.11 {
encoding convertfrom jis0208 \x38\x43
| | | | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 |
unknownencodingtest cmdAH-4.3.6 {convertfrom -failindex ABC}
unknownencodingtest cmdAH-4.3.7 {convertfrom -profile ABC}
unknownencodingtest cmdAH-4.3.8 {convertfrom nosuchencoding ABC}
unknownencodingtest cmdAH-4.3.9 {convertfrom -failindex VAR -profile ABC}
unknownencodingtest cmdAH-4.3.10 {convertfrom -profile strict -failindex ABC}
testconvert cmdAH-4.3.11 {
encoding convertfrom jis0208 \x38\x43
} 乎 -setup {
set system [encoding system]
encoding system iso8859-1
} -cleanup {
encoding system $system
}
# Verify single arg defaults to system encoding
testconvert cmdAH-4.3.12 {
encoding convertfrom \x38\x43
} 乎 -setup {
set system [encoding system]
encoding system jis0208
} -cleanup {
encoding system $system
}
# convertfrom ?-profile? : valid byte sequences
|
| ︙ | ︙ | |||
512 513 514 515 516 517 518 |
# Test that last two args always treated as ENCODING DATA
unknownencodingtest cmdAH-4.4.6 {convertto -failindex ABC}
unknownencodingtest cmdAH-4.4.7 {convertto -profile ABC}
unknownencodingtest cmdAH-4.4.8 {convertto nosuchencoding ABC}
unknownencodingtest cmdAH-4.4.9 {convertto -failindex VAR -profile ABC}
unknownencodingtest cmdAH-4.4.10 {convertto -profile strict -failindex ABC}
testconvert cmdAH-4.4.11 {
| | | | | | 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 |
# Test that last two args always treated as ENCODING DATA
unknownencodingtest cmdAH-4.4.6 {convertto -failindex ABC}
unknownencodingtest cmdAH-4.4.7 {convertto -profile ABC}
unknownencodingtest cmdAH-4.4.8 {convertto nosuchencoding ABC}
unknownencodingtest cmdAH-4.4.9 {convertto -failindex VAR -profile ABC}
unknownencodingtest cmdAH-4.4.10 {convertto -profile strict -failindex ABC}
testconvert cmdAH-4.4.11 {
encoding convertto jis0208 乎
} \x38\x43 -setup {
set system [encoding system]
encoding system iso8859-1
} -cleanup {
encoding system $system
}
# Verify single arg defaults to system encoding
testconvert cmdAH-4.4.12 {
encoding convertto 乎
} \x38\x43 -setup {
set system [encoding system]
encoding system jis0208
} -cleanup {
encoding system $system
}
# convertto ?-profile? : valid byte sequences
foreach {enc str hex ctrl comment} $encValidStrings {
if {"knownBug" in $ctrl} continue
set bytes [binary decode hex $hex]
set printable [tcltest::Asciify $str]
set prefix A
set suffix B
set prefix_bytes [encoding convertto $enc A]
set suffix_bytes [encoding convertto $enc B]
foreach profile $encProfiles {
testprofile cmdAH-4.4.13.$printable.solo convertto $enc $profile $str $bytes
testprofile cmdAH-4.4.13.$printable.lead convertto $enc $profile $str$suffix $bytes$suffix_bytes
testprofile cmdAH-4.4.13.$printable.tail convertto $enc $profile $prefix$str $prefix_bytes$bytes
testprofile cmdAH-4.4.13.$printable.middle convertto $enc $profile $prefix$str$suffix $prefix_bytes$bytes$suffix_bytes
}
}
# convertto ?-profile? : invalid byte sequences
foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings {
if {"knownBug" in $ctrl} continue
set bytes [binary decode hex $hex]
set printable [tcltest::Asciify $str]
set prefix A
set suffix B
set prefix_bytes [encoding convertto $enc $prefix]
set suffix_bytes [encoding convertto $enc $suffix]
set prefixLen [string length $prefix_bytes]
set result [list $bytes]
# TODO - if the bad byte is unprintable, tcltest errors out when printing a mismatch
|
| ︙ | ︙ | |||
601 602 603 604 605 606 607 |
}
}
# convertto -failindex ?-profile? - valid data
foreach {enc str hex ctrl comment} $encValidStrings {
if {"knownBug" in $ctrl} continue
set bytes [binary decode hex $hex]
| | | | 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 |
}
}
# convertto -failindex ?-profile? - valid data
foreach {enc str hex ctrl comment} $encValidStrings {
if {"knownBug" in $ctrl} continue
set bytes [binary decode hex $hex]
set printable [tcltest::Asciify $str]
set prefix A
set suffix B
set prefix_bytes [encoding convertto $enc A]
set suffix_bytes [encoding convertto $enc B]
foreach profile $encProfiles {
testfailindex cmdAH-4.4.14.$enc.$printable.solo convertto $enc $str $bytes -1 $profile
testfailindex cmdAH-4.4.14.$enc.$printable.lead convertto $enc $str$suffix $bytes$suffix_bytes -1 $profile
testfailindex cmdAH-4.4.14.$enc.$printable.tail convertto $enc $prefix$str $prefix_bytes$bytes -1 $profile
testfailindex cmdAH-4.4.14.$enc.$printable.middle convertto $enc $prefix$str$suffix $prefix_bytes$bytes$suffix_bytes -1 $profile
}
}
# convertto -failindex ?-profile? - invalid data
foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings {
if {"knownBug" in $ctrl} continue
set bytes [binary decode hex $hex]
set printable [tcltest::Asciify $str]
set prefix A
set suffix B
set prefixLen [string length [encoding convertto $enc $prefix]]
if {$ctrl eq {} || "solo" in $ctrl} {
testfailindex cmdAH-4.4.14.$printable.solo convertto $enc $str $bytes $failidx $profile
}
if {$ctrl eq {} || "lead" in $ctrl} {
|
| ︙ | ︙ |
Changes to tests/dict.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
# 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::*
}
# 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 dict-1.1 {dict command basic syntax} -returnCodes error -body {
dict
} -result {wrong # args: should be "dict subcommand ?arg ...?"}
test dict-1.2 {dict command basic syntax} -returnCodes error -body {
dict ?
} -match glob -result {unknown or ambiguous subcommand "?": must be *}
| > > > > > > | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
# 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::*
}
catch {
::tcltest::loadTestedCommands
package require -exact tcl::test [info patchlevel]
}
# 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 dict-1.1 {dict command basic syntax} -returnCodes error -body {
dict
} -result {wrong # args: should be "dict subcommand ?arg ...?"}
test dict-1.2 {dict command basic syntax} -returnCodes error -body {
dict ?
} -match glob -result {unknown or ambiguous subcommand "?": must be *}
|
| ︙ | ︙ | |||
134 135 136 137 138 139 140 |
} -result {missing value to go with key}
test dict-3.15 {compiled dict get error cleanliness - Bug 2431847} -body {
apply {{} {
dict set a(z) b c
dict get $a(z) d
}}
} -returnCodes error -result {key "d" not known in dictionary}
| | > > > > | > > > > | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
} -result {missing value to go with key}
test dict-3.15 {compiled dict get error cleanliness - Bug 2431847} -body {
apply {{} {
dict set a(z) b c
dict get $a(z) d
}}
} -returnCodes error -result {key "d" not known in dictionary}
test dict-3.16 {dict/list shimmering - Bug 3004007} {
set l [list p 1 p 2 q 3]
dict get $l q
list $l [testobj objtype $l]
} {{p 1 p 2 q 3} dict}
test dict-3.17 {dict/list shimmering - Bug 3004007} {
set l [list p 1 p 2 q 3]
dict get $l q
list [llength $l] [testobj objtype $l]
} {6 dict}
test dict-4.1 {dict replace command} {
dict replace {a b c d}
} {a b c d}
test dict-4.2 {dict replace command} {
dict replace {a b c d} e f
} {a b c d e f}
|
| ︙ | ︙ | |||
658 659 660 661 662 663 664 |
}}
} ok,a,b
test dict-14.14 {dict for command: handle representation loss} -body {
set dictVar {a b c d e f g h}
set keys {}
set values {}
dict for {k v} $dictVar {
| | | | | 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 |
}}
} ok,a,b
test dict-14.14 {dict for command: handle representation loss} -body {
set dictVar {a b c d e f g h}
set keys {}
set values {}
dict for {k v} $dictVar {
if {[string length $dictVar]} {
lappend keys $k
lappend values $v
}
}
list [lsort $keys] [lsort $values] [testobj objtype $dictVar]
} -cleanup {
unset dictVar keys values k v
} -result {{a c e g} {b d f h} string}
test dict-14.15 {dict for command: keys are unique and iterated over once only} -setup {
unset -nocomplain accum
array set accum {}
} -body {
set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
dict for {k v} $dictVar {
append accum($k) $v,
|
| ︙ | ︙ | |||
1804 1805 1806 1807 1808 1809 1810 |
} ok,a,b
test dict-24.14 {dict map command: handle representation loss} -setup {
set keys {}
set values {}
} -body {
set dictVar {a b c d e f g h}
list [dict size [dict map {k v} $dictVar {
| | | | | | | | 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 |
} ok,a,b
test dict-24.14 {dict map command: handle representation loss} -setup {
set keys {}
set values {}
} -body {
set dictVar {a b c d e f g h}
list [dict size [dict map {k v} $dictVar {
if {[string length $dictVar]} {
lappend keys $k
lappend values $v
return -level 0 $k
}
}]] [lsort $keys] [lsort $values] [testobj objtype $dictVar]
} -cleanup {
unset dictVar keys values k v
} -result {4 {a c e g} {b d f h} string}
test dict-24.14a {dict map command: handle representation loss} -body {
apply {{} {
set dictVar {a b c d e f g h}
list [dict size [dict map {k v} $dictVar {
if {[string length $dictVar]} {
lappend keys $k
lappend values $v
return -level 0 $k
}
}]] [lsort $keys] [lsort $values] [testobj objtype $dictVar]
}}
} -result {4 {a c e g} {b d f h} string}
test dict-24.15 {dict map command: keys are unique and iterated over once only} -setup {
unset -nocomplain accum
array set accum {}
} -body {
set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo}
dict map {k v} $dictVar {
append accum($k) $v,
|
| ︙ | ︙ |
Changes to tests/encoding.test.
| ︙ | ︙ | |||
228 229 230 231 232 233 234 |
fconfigure $f -translation binary -encoding iso8859-1
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
return $x
} "ab\x8C\xC1g"
| < < < < < < < < < < < < | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 |
fconfigure $f -translation binary -encoding iso8859-1
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
return $x
} "ab\x8C\xC1g"
test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {
set system [encoding system]
set path [encoding dirs]
encoding system iso8859-1
encoding dirs {}
llength jis0208 ;# Shimmer any cached Tcl_Encoding in shared literal
set x [list [catch {encoding convertto jis0208 乎} msg] $msg]
|
| ︙ | ︙ | |||
261 262 263 264 265 266 267 |
test encoding-11.3 {LoadEncodingFile: double-byte} {
encoding convertfrom jis0208 8C
} 乎
test encoding-11.4 {LoadEncodingFile: multi-byte} {
encoding convertfrom shiftjis \x8C\xC1
} 乎
test encoding-11.5 {LoadEncodingFile: escape file} {
| | | | | | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 |
test encoding-11.3 {LoadEncodingFile: double-byte} {
encoding convertfrom jis0208 8C
} 乎
test encoding-11.4 {LoadEncodingFile: multi-byte} {
encoding convertfrom shiftjis \x8C\xC1
} 乎
test encoding-11.5 {LoadEncodingFile: escape file} {
encoding convertto iso2022 乎
} \x1B\$B8C\x1B(B
test encoding-11.5.1 {LoadEncodingFile: escape file} {
encoding convertto iso2022-jp 乎
} \x1B\$B8C\x1B(B
test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup {
set system [encoding system]
set path [encoding dirs]
encoding system iso8859-1
} -body {
cd [temporaryDirectory]
encoding dirs [file join tmp encoding]
|
| ︙ | ︙ | |||
289 290 291 292 293 294 295 |
removeDirectory [file join tmp encoding]
removeDirectory tmp
cd [workingDirectory]
encoding dirs $path
encoding system $system
} -result {invalid encoding file "splat"}
test encoding-11.8 {encoding: extended Unicode UTF-16} {
| | | | | | | | | | 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 |
removeDirectory [file join tmp encoding]
removeDirectory tmp
cd [workingDirectory]
encoding dirs $path
encoding system $system
} -result {invalid encoding file "splat"}
test encoding-11.8 {encoding: extended Unicode UTF-16} {
encoding convertto utf-16le 😹
} =Ø9Þ
test encoding-11.9 {encoding: extended Unicode UTF-16} {
encoding convertto utf-16be 😹
} Ø=Þ9
test encoding-11.10 {encoding: extended Unicode UTF-32} {
encoding convertto utf-32le 😹
} 9\xF6\x01\x00
test encoding-11.11 {encoding: extended Unicode UTF-32} {
encoding convertto utf-32be 😹
} \x00\x01\xF69
# 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 Ġ]
append x [encoding convertto -profile tcl8 iso8859-3 Õ]
append x [encoding convertfrom iso8859-3 Õ]
} "Õ?Ġ"
|
| ︙ | ︙ | |||
326 327 328 329 330 331 332 |
test encoding-12.5 {LoadTableEncoding: symbol encoding} {
set x [encoding convertto symbol γ]
append x [encoding convertto symbol g]
append x [encoding convertfrom symbol g]
} "ggγ"
test encoding-13.1 {LoadEscapeTable} {
| | | | 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 |
test encoding-12.5 {LoadTableEncoding: symbol encoding} {
set x [encoding convertto symbol γ]
append x [encoding convertto symbol g]
append x [encoding convertfrom symbol g]
} "ggγ"
test encoding-13.1 {LoadEscapeTable} {
encoding convertto iso2022 ab乎棙g
} ab\x1B\$B8C\x1B\$\(DD%\x1B(Bg
test encoding-15.1 {UtfToUtfProc} {
encoding convertto utf-8 £
} "\xC2\xA3"
test encoding-15.2 {UtfToUtfProc null character output} testbytestring {
binary scan [testbytestring [encoding convertto utf-8 \x00]] H* z
set z
|
| ︙ | ︙ | |||
751 752 753 754 755 756 757 |
set f [open [file join [file dirname [info script]] iso2022.txt]]
fconfigure $f -encoding iso2022-jp
gets $f
}
} {}
test encoding-24.2 {EscapeFreeProc on open channels} {exec} {
# Bug #524674 output
| | < > | | | | 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 |
set f [open [file join [file dirname [info script]] iso2022.txt]]
fconfigure $f -encoding iso2022-jp
gets $f
}
} {}
test encoding-24.2 {EscapeFreeProc on open channels} {exec} {
# Bug #524674 output
runInSubprocess {
encoding system cp1252; # Bug #2891556 crash revelator
fconfigure stdout -encoding iso2022-jp
puts ab乎棙g
set env(TCL_FINALIZE_ON_EXIT) 1
exit
}
} "ab\x1B\$B8C\x1B\$(DD%\x1B(Bg"
test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
# Bug #219314 - if we don't free escape encodings correctly on channel
# closure, we go boom
set file [makeFile {
encoding system iso2022-jp
set a "乎乞也"; # 3 Japanese Kanji letters
puts $a
} iso2022.tcl]
set f [open "|[list [interpreter] $file]"]
fconfigure $f -encoding iso2022-jp
set count [gets $f line]
close $f
removeFile iso2022.tcl
list $count $line
} [list 3 乎乞也]
test {encoding-24.4 utf-8 invalid strict} {Parse invalid utf-8, strict} -body {
encoding convertfrom -profile strict utf-8 "\xC0\x80"
} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'}
test {encoding-24.4 utf-8 invalid tcl8} {UtfToUtfProc utf-8} {
encoding convertfrom -profile tcl8 utf-8 \xC0\x80
} \x00
|
| ︙ | ︙ | |||
1084 1085 1086 1087 1088 1089 1090 |
} -result 91
runtests
test encoding-bug-183a1adcc0-1 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
| | | | | | | | | 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 |
} -result 91
runtests
test encoding-bug-183a1adcc0-1 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
# Note - buffers are initialized to \xFF
list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 1} result] $result
} -result [list 0 [list nospace {} \xFF]]
test encoding-bug-183a1adcc0-2 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
# Note - buffers are initialized to \xFF
list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 0} result] $result
} -result [list 0 [list nospace {} {}]]
test encoding-bug-183a1adcc0-3 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
# Note - buffers are initialized to \xFF
list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 2} result] $result
} -result [list 0 [list nospace {} \x00\x00]]
test encoding-bug-183a1adcc0-4 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding
} -body {
# Note - buffers are initialized to \xFF
list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 3} result] $result
} -result [list 0 [list nospace {} \x00\x00\xFF]]
test encoding-bug-183a1adcc0-5 {Bug [183a1adcc0] Buffer overflow Tcl_UtfToExternal} -constraints {
testencoding ucs2 knownBug
} -body {
# The knownBug constraint is because test depends on TCL_UTF_MAX and
# also UtfToUtf16 assumes space required in destination buffer is
# sizeof(Tcl_UniChar) which is incorrect when TCL_UTF_MAX==4
# Note - buffers are initialized to \xFF
list [catch {testencoding Tcl_UtfToExternal utf-16 A {start end} {} 4} result] $result
} -result [list 0 [list ok {} [expr {$::tcl_platform(byteOrder) eq "littleEndian" ? "\x41\x00" : "\x00\x41"}]\x00\x00]]
}
test encoding-29.0 {get encoding nul terminator lengths} -constraints {
testencoding
|
| ︙ | ︙ | |||
1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 |
test encoding-30.3 {encoding convertfrom large strings > 4GB} -constraints {
perf
} -body {
list [string length [set s [string repeat A 0x100000000]]] [string equal $s [encoding convertfrom ascii $s]]
} -result {4294967296 1}
# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 |
test encoding-30.3 {encoding convertfrom large strings > 4GB} -constraints {
perf
} -body {
list [string length [set s [string repeat A 0x100000000]]] [string equal $s [encoding convertfrom ascii $s]]
} -result {4294967296 1}
test encoding-bug-6a3e2cb0f0-1 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body {
encoding convertfrom -profile tcl8 iso2022-jp x\x1B\x7Aaby
} -result x\uFFFDy
test encoding-bug-6a3e2cb0f0-2 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body {
encoding convertfrom -profile strict iso2022-jp x\x1B\x7Aaby
} -returnCodes error -result {unexpected byte sequence starting at index 1: '\x1B'}
test encoding-bug-6a3e2cb0f0-3 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body {
encoding convertfrom -profile replace iso2022-jp x\x1B\x7Aaby
} -result x\uFFFDy
test encoding-bug-66ffafd309-1-tcl8 {Bug [66ffafd309] - truncated DBCS} -body {
encoding convertfrom -profile tcl8 gb12345 x
} -result x
test encoding-bug-66ffafd309-1-strict {Bug [66ffafd309] - truncated DBCS} -body {
encoding convertfrom -profile strict gb12345 x
} -result {unexpected byte sequence starting at index 0: '\x78'} -returnCodes error
test encoding-bug-66ffafd309-1-replace {Bug [66ffafd309] - truncated DBCS} -body {
encoding convertfrom -profile replace gb12345 x
} -result \uFFFD
test encoding-bug-66ffafd309-2-tcl8 {Bug [66ffafd309] - invalid DBCS} -body {
# Not truncated but invalid
encoding convertfrom -profile tcl8 jis0208 \x78\x79
} -result \x78\x79
test encoding-bug-66ffafd309-2-strict {Bug [66ffafd309] - invalid DBCS} -body {
# Not truncated but invalid
encoding convertfrom -profile strict jis0208 \x78\x79
} -result {unexpected byte sequence starting at index 1: '\x79'} -returnCodes error
test encoding-bug-66ffafd309-2-replace {Bug [66ffafd309] - invalid DBCS} -body {
# Not truncated but invalid
encoding convertfrom -profile replace jis0208 \x78\x79
} -result \uFFFD\uFFFD
# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/encodingVectors.tcl.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
#
# utf-16, utf-32 missing because they are automatically
# generated based on le/be versions.
set encValidStrings {}; # Reset the table
lappend encValidStrings {*}{
ascii \u0000 00 {} {Lowest ASCII}
| | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
#
# utf-16, utf-32 missing because they are automatically
# generated based on le/be versions.
set encValidStrings {}; # Reset the table
lappend encValidStrings {*}{
ascii \u0000 00 {} {Lowest ASCII}
ascii \u007F 7F {} {Highest ASCII}
ascii \u007D 7D {} {Brace - just to verify test scripts are escaped correctly}
ascii \u007B 7B {} {Terminating brace - just to verify test scripts are escaped correctly}
utf-8 \u0000 00 {} {Unicode Table 3.7 Row 1}
utf-8 \u007F 7F {} {Unicode Table 3.7 Row 1}
utf-8 \u0080 C280 {} {Unicode Table 3.7 Row 2}
utf-8 \u07FF DFBF {} {Unicode Table 3.7 Row 2}
|
| ︙ | ︙ | |||
589 590 591 592 593 594 595 |
utf-32le 00D80000 strict {} 0 {} {High-surrogate}
utf-32le 00DC0000 tcl8 \uDC00 -1 {} {Low-surrogate}
utf-32le 00DC0000 replace \uFFFD -1 {} {Low-surrogate}
utf-32le 00DC0000 strict {} 0 {} {Low-surrogate}
utf-32le 00D8000000DC0000 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair}
utf-32le 00D8000000DC0000 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair}
utf-32le 00D8000000DC0000 strict {} 0 {} {High-low-surrogate-pair}
| | | | | | | | | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 |
utf-32le 00D80000 strict {} 0 {} {High-surrogate}
utf-32le 00DC0000 tcl8 \uDC00 -1 {} {Low-surrogate}
utf-32le 00DC0000 replace \uFFFD -1 {} {Low-surrogate}
utf-32le 00DC0000 strict {} 0 {} {Low-surrogate}
utf-32le 00D8000000DC0000 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair}
utf-32le 00D8000000DC0000 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair}
utf-32le 00D8000000DC0000 strict {} 0 {} {High-low-surrogate-pair}
utf-32le 00001100 tcl8 \uFFFD -1 {} {Out of range}
utf-32le 00001100 replace \uFFFD -1 {} {Out of range}
utf-32le 00001100 strict {} 0 {} {Out of range}
utf-32le FFFFFFFF tcl8 \uFFFD -1 {} {Out of range}
utf-32le FFFFFFFF replace \uFFFD -1 {} {Out of range}
utf-32le FFFFFFFF strict {} 0 {} {Out of range}
utf-32be 41 tcl8 \uFFFD -1 {solo tail} {Truncated}
utf-32be 41 replace \uFFFD -1 {solo tail} {Truncated}
utf-32be 41 strict {} 0 {solo tail} {Truncated}
utf-32be 0041 tcl8 \uFFFD -1 {solo tail} {Truncated}
utf-32be 0041 replace \uFFFD -1 {solo} {Truncated}
utf-32be 0041 strict {} 0 {solo tail} {Truncated}
utf-32be 000041 tcl8 \uFFFD -1 {solo tail} {Truncated}
utf-32be 000041 replace \uFFFD -1 {solo} {Truncated}
utf-32be 000041 strict {} 0 {solo tail} {Truncated}
utf-32be 0000D800 tcl8 \uD800 -1 {} {High-surrogate}
utf-32be 0000D800 replace \uFFFD -1 {} {High-surrogate}
utf-32be 0000D800 strict {} 0 {} {High-surrogate}
utf-32be 0000DC00 tcl8 \uDC00 -1 {} {Low-surrogate}
utf-32be 0000DC00 replace \uFFFD -1 {} {Low-surrogate}
utf-32be 0000DC00 strict {} 0 {} {Low-surrogate}
utf-32be 0000D8000000DC00 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair}
utf-32be 0000D8000000DC00 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair}
utf-32be 0000D8000000DC00 strict {} 0 {} {High-low-surrogate-pair}
utf-32be 00110000 tcl8 \uFFFD -1 {} {Out of range}
utf-32be 00110000 replace \uFFFD -1 {} {Out of range}
utf-32be 00110000 strict {} 0 {} {Out of range}
utf-32be FFFFFFFF tcl8 \uFFFD -1 {} {Out of range}
utf-32be FFFFFFFF replace \uFFFD -1 {} {Out of range}
utf-32be FFFFFFFF strict {} 0 {} {Out of range}
}
# Strings that cannot be encoded for specific encoding / profiles
# <ENCODING STRING PROFILE EXPECTEDRESULT EXPECTEDFAILINDEX CTRL COMMENT>
# <ENCODING,STRING,PROFILE> should be unique for test ids to be unique.
# See earlier comments about CTRL field.
|
| ︙ | ︙ |
Changes to tests/io.test.
| ︙ | ︙ | |||
1197 1198 1199 1200 1201 1202 1203 |
set f [open $path(test1)]
fconfigure $f -encoding shiftjis -profile tcl8
set x [list [gets $f line] $line]
lappend x [tell $f] [testchannel inputbuffered $f] [eof $f]
lappend x [gets $f line] $line
close $f
set x
| | | 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 |
set f [open $path(test1)]
fconfigure $f -encoding shiftjis -profile tcl8
set x [list [gets $f line] $line]
lappend x [tell $f] [testchannel inputbuffered $f] [eof $f]
lappend x [gets $f line] $line
close $f
set x
} [list 16 "123456789012301\x82" 18 0 1 -1 ""]
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"]
variable x {}
|
| ︙ | ︙ |
Changes to tests/lseq.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint arithSeriesDouble 1
testConstraint arithSeriesShimmer 1
testConstraint arithSeriesShimmerOk 1
testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}]
# Arg errors
test lseq-1.1 {error cases} -body {
lseq
} \
-returnCodes 1 \
-result {wrong # args: should be "lseq n ??op? n ??by? n??"}
| > > > > > > > > > > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
package require tcltest 2.5
namespace import -force ::tcltest::*
}
testConstraint arithSeriesDouble 1
testConstraint arithSeriesShimmer 1
testConstraint arithSeriesShimmerOk 1
testConstraint knownBug 0
testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}]
testConstraint has32BitLengths [expr {$tcl_platform(pointerSize) == 4}]
proc memusage {} {
set fd [open /proc/[pid]/statm]
set line [gets $fd]
if {[llength $line] != 7} {
error "Unexpected /proc/pid/statm format"
}
return [lindex $line 5]
}
testConstraint hasMemUsage [expr {![catch {memusage}]}]
# Arg errors
test lseq-1.1 {error cases} -body {
lseq
} \
-returnCodes 1 \
-result {wrong # args: should be "lseq n ??op? n ??by? n??"}
|
| ︙ | ︙ | |||
432 433 434 435 436 437 438 |
} -cleanup {
unset r a
} -result {arithseries
3.5 5.0 6.5 8.0 9.5 11.0 12.5 14.0 15.5 17.0 18.5
arithseries
18.5 17.0 15.5 14.0 12.5 11.0 9.5 8.0 6.5 5.0 3.5}
| | > > > > > > > > > > > > > > > | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 |
} -cleanup {
unset r a
} -result {arithseries
3.5 5.0 6.5 8.0 9.5 11.0 12.5 14.0 15.5 17.0 18.5
arithseries
18.5 17.0 15.5 14.0 12.5 11.0 9.5 8.0 6.5 5.0 3.5}
test lseq-3.31 {lreverse inplace with doubles} {arithSeriesDouble} {
lreverse [lseq 1.1 29.9 0.3]
} {29.9 29.6 29.3 29.0 28.7 28.4 28.1 27.8 27.5 27.2 26.9 26.6 26.3 26.0 25.7 25.4 25.1 24.8 24.5 24.2 23.9 23.6 23.3 23.0 22.7 22.4 22.1 21.8 21.5 21.2 20.9 20.6 20.3 20.0 19.7 19.4 19.1 18.8 18.5 18.2 17.9 17.6 17.3 17.0 16.7 16.4 16.1 15.8 15.5 15.2 14.9 14.6 14.3 14.0 13.7 13.4 13.1 12.8 12.5 12.2 11.9 11.6 11.3 11.0 10.7 10.4 10.1 9.8 9.5 9.2 8.9 8.6 8.3 8.0 7.7 7.4 7.1 6.8 6.5 6.2 5.9 5.6 5.3 5.0 4.7 4.4 4.1 3.8 3.5 3.2 2.9 2.6 2.3 2.0 1.7 1.4 1.1}
# lsearch -
# -- should not shimmer lseq list
# -- should not leak lseq elements
test lseq-3.32 {lsearch nested lists of lseq} arithSeriesShimmer {
set srchlist {}
for {set i 5} {$i < 25} {incr i} {
lappend srchlist [lseq $i count 7 by 3]
}
set a [lsearch -all -inline -index 1 $srchlist 23]
set b [lmap i $a {lindex [tcl::unsupported::representation $i] 3}]
list [lindex [tcl::unsupported::representation $a] 3] $a $b \
[lindex [tcl::unsupported::representation [lindex $srchlist 15]] 3]
} {list {{20 23 26 29 32 35 38}} arithseries arithseries}
# lsearch -
# -- should not shimmer lseq list
# -- should not leak lseq elements
test lseq-3.32 {lsearch nested lists of lseq} -constraints arithSeriesShimmer -body {
set srchlist {}
for {set i 5} {$i < 25} {incr i} {
|
| ︙ | ︙ | |||
536 537 538 539 540 541 542 543 544 545 546 547 |
lappend res $s $e
}
eval $tcmd
} -cleanup {
unset res s e tcmd
} -result {0 10 0 10 0 9223372036854774991 0 10 0 2147483638}
# Ticket 99e834bf33 - lseq, lindex end off by one
test lseq-4.5 {lindex off by one} -body {
lappend res [eval {lindex [lseq 1 4] end}]
lappend res [eval {lindex [lseq 1 4] end-1}]
| > > > > > > > > > > > > > > > > > > > < < < | 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 |
lappend res $s $e
}
eval $tcmd
} -cleanup {
unset res s e tcmd
} -result {0 10 0 10 0 9223372036854774991 0 10 0 2147483638}
test lseq-4.4.32 {lseq corner case} -constraints has32BitLengths -body {
set tcmd {
set res {}
set s [catch {lindex [lseq 10 100] 0} e]
lappend res $s $e
set s [catch {lindex [lseq 10 9223372036854775000] 0} e]
lappend res $s $e
set s [catch {llength [lseq 10 9223372036854775000]} e]
lappend res $s $e
set s [catch {lindex [lseq 10 2147483647] 0} e]
lappend res $s $e
set s [catch {llength [lseq 10 2147483647]} e]
lappend res $s $e
}
eval $tcmd
} -cleanup {
unset res s e tcmd
} -result {0 10 1 {max length of a Tcl list exceeded} 1 {max length of a Tcl list exceeded} 0 10 0 2147483638}
# Ticket 99e834bf33 - lseq, lindex end off by one
test lseq-4.5 {lindex off by one} -body {
lappend res [eval {lindex [lseq 1 4] end}]
lappend res [eval {lindex [lseq 1 4] end-1}]
} -cleanup {
unset res
} -result {4 3}
# Bad refcount on ResultObj
test lseq-4.6 {lindex flat} -body {
set l [lseq 2 10]
|
| ︙ | ︙ | |||
586 587 588 589 590 591 592 |
# Panic when using variable value?
test lseq-4.10 {panic using variable index} -body {
set i 0
lindex [lseq 10] $i
} -cleanup {unset i} -result {0}
| | > > > > | | | | 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
# Panic when using variable value?
test lseq-4.10 {panic using variable index} -body {
set i 0
lindex [lseq 10] $i
} -cleanup {unset i} -result {0}
test lseq-4.11 {bug lseq / lindex discrepancies} -body {
lindex [lseq 0x7fffffff] 0x80000000
} -result {}
test lseq-4.12 {bug lseq} -constraints has64BitLengths -body {
llength [lseq 0x100000000]
} -result {4294967296}
test lseq-4.12.32 {bug lseq} -constraints has32BitLengths -body {
llength [lseq 0x100000000]
} -returnCodes 1 -result {max length of a Tcl list exceeded}
test lseq-4.13 {bug lseq} -constraints knownBug -body {
set l [lseq 0x7fffffffffffffff]
list \
[llength $l] \
[lindex $l end] \
[lindex $l 9223372036854775800]
} -cleanup {unset l} -result {9223372036854775807 9223372036854775806 9223372036854775800}
test lseq-4.14 {bug lseq - inconsistent rounding} {
# using a non-integer increment, [lseq] rounding seems to be not consistent:
lseq 4 40 0.1
} {4.0 4.1 4.2 4.3 4.4 4.5 4.6 4.7 4.8 4.9 5.0 5.1 5.2 5.3 5.4 5.5 5.6 5.7 5.8 5.9 6.0 6.1 6.2 6.3 6.4 6.5 6.6 6.7 6.8 6.9 7.0 7.1 7.2 7.3 7.4 7.5 7.6 7.7 7.8 7.9 8.0 8.1 8.2 8.3 8.4 8.5 8.6 8.7 8.8 8.9 9.0 9.1 9.2 9.3 9.4 9.5 9.6 9.7 9.8 9.9 10.0 10.1 10.2 10.3 10.4 10.5 10.6 10.7 10.8 10.9 11.0 11.1 11.2 11.3 11.4 11.5 11.6 11.7 11.8 11.9 12.0 12.1 12.2 12.3 12.4 12.5 12.6 12.7 12.8 12.9 13.0 13.1 13.2 13.3 13.4 13.5 13.6 13.7 13.8 13.9 14.0 14.1 14.2 14.3 14.4 14.5 14.6 14.7 14.8 14.9 15.0 15.1 15.2 15.3 15.4 15.5 15.6 15.7 15.8 15.9 16.0 16.1 16.2 16.3 16.4 16.5 16.6 16.7 16.8 16.9 17.0 17.1 17.2 17.3 17.4 17.5 17.6 17.7 17.8 17.9 18.0 18.1 18.2 18.3 18.4 18.5 18.6 18.7 18.8 18.9 19.0 19.1 19.2 19.3 19.4 19.5 19.6 19.7 19.8 19.9 20.0 20.1 20.2 20.3 20.4 20.5 20.6 20.7 20.8 20.9 21.0 21.1 21.2 21.3 21.4 21.5 21.6 21.7 21.8 21.9 22.0 22.1 22.2 22.3 22.4 22.5 22.6 22.7 22.8 22.9 23.0 23.1 23.2 23.3 23.4 23.5 23.6 23.7 23.8 23.9 24.0 24.1 24.2 24.3 24.4 24.5 24.6 24.7 24.8 24.9 25.0 25.1 25.2 25.3 25.4 25.5 25.6 25.7 25.8 25.9 26.0 26.1 26.2 26.3 26.4 26.5 26.6 26.7 26.8 26.9 27.0 27.1 27.2 27.3 27.4 27.5 27.6 27.7 27.8 27.9 28.0 28.1 28.2 28.3 28.4 28.5 28.6 28.7 28.8 28.9 29.0 29.1 29.2 29.3 29.4 29.5 29.6 29.7 29.8 29.9 30.0 30.1 30.2 30.3 30.4 30.5 30.6 30.7 30.8 30.9 31.0 31.1 31.2 31.3 31.4 31.5 31.6 31.7 31.8 31.9 32.0 32.1 32.2 32.3 32.4 32.5 32.6 32.7 32.8 32.9 33.0 33.1 33.2 33.3 33.4 33.5 33.6 33.7 33.8 33.9 34.0 34.1 34.2 34.3 34.4 34.5 34.6 34.7 34.8 34.9 35.0 35.1 35.2 35.3 35.4 35.5 35.6 35.7 35.8 35.9 36.0 36.1 36.2 36.3 36.4 36.5 36.6 36.7 36.8 36.9 37.0 37.1 37.2 37.3 37.4 37.5 37.6 37.7 37.8 37.9 38.0 38.1 38.2 38.3 38.4 38.5 38.6 38.7 38.8 38.9 39.0 39.1 39.2 39.3 39.4 39.5 39.6 39.7 39.8 39.9 40.0}
test lseq-4.15 {bug lseq - inconsistent rounding} {
# using a non-integer increment, [lseq] rounding seems to be not consistent:
lseq 6 40 0.1
} {6.0 6.1 6.2 6.3 6.4 6.5 6.6 6.7 6.8 6.9 7.0 7.1 7.2 7.3 7.4 7.5 7.6 7.7 7.8 7.9 8.0 8.1 8.2 8.3 8.4 8.5 8.6 8.7 8.8 8.9 9.0 9.1 9.2 9.3 9.4 9.5 9.6 9.7 9.8 9.9 10.0 10.1 10.2 10.3 10.4 10.5 10.6 10.7 10.8 10.9 11.0 11.1 11.2 11.3 11.4 11.5 11.6 11.7 11.8 11.9 12.0 12.1 12.2 12.3 12.4 12.5 12.6 12.7 12.8 12.9 13.0 13.1 13.2 13.3 13.4 13.5 13.6 13.7 13.8 13.9 14.0 14.1 14.2 14.3 14.4 14.5 14.6 14.7 14.8 14.9 15.0 15.1 15.2 15.3 15.4 15.5 15.6 15.7 15.8 15.9 16.0 16.1 16.2 16.3 16.4 16.5 16.6 16.7 16.8 16.9 17.0 17.1 17.2 17.3 17.4 17.5 17.6 17.7 17.8 17.9 18.0 18.1 18.2 18.3 18.4 18.5 18.6 18.7 18.8 18.9 19.0 19.1 19.2 19.3 19.4 19.5 19.6 19.7 19.8 19.9 20.0 20.1 20.2 20.3 20.4 20.5 20.6 20.7 20.8 20.9 21.0 21.1 21.2 21.3 21.4 21.5 21.6 21.7 21.8 21.9 22.0 22.1 22.2 22.3 22.4 22.5 22.6 22.7 22.8 22.9 23.0 23.1 23.2 23.3 23.4 23.5 23.6 23.7 23.8 23.9 24.0 24.1 24.2 24.3 24.4 24.5 24.6 24.7 24.8 24.9 25.0 25.1 25.2 25.3 25.4 25.5 25.6 25.7 25.8 25.9 26.0 26.1 26.2 26.3 26.4 26.5 26.6 26.7 26.8 26.9 27.0 27.1 27.2 27.3 27.4 27.5 27.6 27.7 27.8 27.9 28.0 28.1 28.2 28.3 28.4 28.5 28.6 28.7 28.8 28.9 29.0 29.1 29.2 29.3 29.4 29.5 29.6 29.7 29.8 29.9 30.0 30.1 30.2 30.3 30.4 30.5 30.6 30.7 30.8 30.9 31.0 31.1 31.2 31.3 31.4 31.5 31.6 31.7 31.8 31.9 32.0 32.1 32.2 32.3 32.4 32.5 32.6 32.7 32.8 32.9 33.0 33.1 33.2 33.3 33.4 33.5 33.6 33.7 33.8 33.9 34.0 34.1 34.2 34.3 34.4 34.5 34.6 34.7 34.8 34.9 35.0 35.1 35.2 35.3 35.4 35.5 35.6 35.7 35.8 35.9 36.0 36.1 36.2 36.3 36.4 36.5 36.6 36.7 36.8 36.9 37.0 37.1 37.2 37.3 37.4 37.5 37.6 37.7 37.8 37.9 38.0 38.1 38.2 38.3 38.4 38.5 38.6 38.7 38.8 38.9 39.0 39.1 39.2 39.3 39.4 39.5 39.6 39.7 39.8 39.9 40.0}
test lseq-4.16 {bug lseq - inconsistent rounding} {
# using a non-integer increment, [lseq] rounding seems to be not consistent:
set res {}
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
test lseq-convertToList {does not result in a memory error} -body {
trace add variable var1 write [list ::apply [list args {
error {this is an error}
} [namespace current]]]
list [catch {set var1 [lindex [lreplace [lseq 1 2] 1 1 hello] 0]} cres] $cres
} -cleanup {unset var1 cres} -result {1 {can't set "var1": this is an error}}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 |
test lseq-convertToList {does not result in a memory error} -body {
trace add variable var1 write [list ::apply [list args {
error {this is an error}
} [namespace current]]]
list [catch {set var1 [lindex [lreplace [lseq 1 2] 1 1 hello] 0]} cres] $cres
} -cleanup {unset var1 cres} -result {1 {can't set "var1": this is an error}}
test lseq-bug-54329e39c7 {does not cause memory bloat} -constraints {
hasMemUsage
} -body {
set l [lseq 1000000]
proc p l {foreach x $l {}}
set premem [memusage]
p $l
set postmem [memusage]
expr {($postmem - $premem) < 10}
} -result 1
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/utfext.test.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 |
# Maps encoded bytes string to utf-8 equivalents, both in hex
# encoding utf-8 encdata
lappend utfExtMap {*}{
ascii 414243 414243
}
| < < < < < < < < < < < < < < < < < < < | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
# Maps encoded bytes string to utf-8 equivalents, both in hex
# encoding utf-8 encdata
lappend utfExtMap {*}{
ascii 414243 414243
}
# Simple test with basic flags
proc testbasic {direction enc hexin hexout {flags {start end}}} {
if {$direction eq "toutf"} {
set cmd Tcl_ExternalToUtf
} else {
set cmd Tcl_UtfToExternal
}
|
| ︙ | ︙ | |||
88 89 90 91 92 93 94 95 96 97 98 99 100 101 |
testencoding Tcl_UtfToExternal utf-16 A {start end} {} 1
} -result [list nospace {} \xFF]
# Another bug - char limit not obeyed
# % set cv 2
# % testencoding Tcl_ExternalToUtf utf-8 abcdefgh {start end noterminate charlimit} {} 20 rv wv cv
# nospace {} abcÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
testencoding Tcl_UtfToExternal utf-16 A {start end} {} 1
} -result [list nospace {} \xFF]
# Another bug - char limit not obeyed
# % set cv 2
# % testencoding Tcl_ExternalToUtf utf-8 abcdefgh {start end noterminate charlimit} {} 20 rv wv cv
# nospace {} abcÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ
test TableToUtf-bug-5be203d6ca {Bug 5be203d6ca - truncated prefix in table encoding} -body {
set src \x82\x4F\x82\x50\x82
lassign [testencoding Tcl_ExternalToUtf shiftjis $src {start} 0 16 srcRead dstWritten charsWritten] buf
set result [list [testencoding Tcl_ExternalToUtf shiftjis $src {start} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten]
lappend result {*}[list [testencoding Tcl_ExternalToUtf shiftjis [string range $src $srcRead end] {end} 0 10 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten]
} -result [list [list multibyte 0 \xEF\xBC\x90\xEF\xBC\x91\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 4 6 2 [list ok 0 \xC2\x82\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 1 2 1]
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/winConsole.test.
| ︙ | ︙ | |||
214 215 216 217 218 219 220 |
fconfigure stdin $opt
} -result $result
}
test console-fconfigure-get-1.[incr testnum] {
Console get stdin option -eofchar
} -constraints {win interactive} -body {
fconfigure stdin -eofchar
| | | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 |
fconfigure stdin $opt
} -result $result
}
test console-fconfigure-get-1.[incr testnum] {
Console get stdin option -eofchar
} -constraints {win interactive} -body {
fconfigure stdin -eofchar
} -result \x1A
test console-fconfigure-get-1.[incr testnum] {
fconfigure -winsize
} -constraints {win interactive} -body {
fconfigure stdin -winsize
} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -profile, -translation, or -inputmode} -returnCodes error
|
| ︙ | ︙ |
Changes to tests/winDde.test.
| ︙ | ︙ | |||
126 127 128 129 130 131 132 |
-constraints dde -body {
expr {[llength [dde services {} self]] >= 1}
} -result 1
# -------------------------------------------------------------------------
test winDde-3.1 {DDE execute locally} -constraints dde -body {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 |
-constraints dde -body {
expr {[llength [dde services {} self]] >= 1}
} -result 1
# -------------------------------------------------------------------------
test winDde-3.1 {DDE execute locally} -constraints dde -body {
set \xE1 ""
dde execute TclEval self [list set \xE1 foo]
set \xE1
} -result foo
test winDde-3.2 {DDE execute -async locally} -constraints dde -body {
set \xE1 ""
dde execute -async TclEval self [list set \xE1 foo]
update
set \xE1
} -result foo
test winDde-3.3 {DDE request locally} -constraints dde -body {
set \xE1 ""
dde execute TclEval self [list set \xE1 foo]
dde request TclEval self \xE1
} -result foo
test winDde-3.4 {DDE eval locally} -constraints dde -body {
set \xE1 ""
dde eval self set \xE1 foo
} -result foo
test winDde-3.5 {DDE request locally} -constraints dde -body {
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 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
# and compose utf-8 (e.g. "c3 84" ) manually
test winDde-3.7 {DDE request binary} -constraints {dde notWine} -body {
set \xE1 "not set"
dde execute -binary TclEval self [list set \xC3\xA1 \xC3\x84\x00]
scan [set \xE1] %c
} -result 196
test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body {
set \xE1 ""
dde poke TclEval self \xE1 \xC4
dde request TclEval self \xE1
} -result \xC4
test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body {
set \xE1 ""
dde poke -binary TclEval self \xE1 \xC3\x84\x00
dde request TclEval self \xE1
} -result \xC4
# -------------------------------------------------------------------------
test winDde-4.1 {DDE execute remotely} -constraints {dde stdio} -body {
set \xE1 ""
set name ch\xEDld-4.1
set child [createChildProcess $name]
dde execute TclEval $name [list set \xE1 foo]
dde execute TclEval $name {set done 1}
update
set \xE1
} -result ""
test winDde-4.2 {DDE execute async remotely} -constraints {dde stdio} -body {
set \xE1 ""
set name ch\xEDld-4.2
set child [createChildProcess $name]
dde execute -async TclEval $name [list set \xE1 foo]
update
dde execute TclEval $name {set done 1}
update
set \xE1
} -result ""
test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body {
set \xE1 ""
set name ch\xEDld-4.3
set child [createChildProcess $name]
dde execute TclEval $name [list set \xE1 foo]
set \xE1 [dde request TclEval $name \xE1]
dde execute TclEval $name {set done 1}
update
set \xE1
} -result foo
test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body {
set \xE1 ""
set name ch\xEDld-4.4
set child [createChildProcess $name]
set \xE1 [dde eval $name set \xE1 foo]
dde execute TclEval $name {set done 1}
update
set \xE1
} -result foo
test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body {
set \xE1 ""
set name ch\xEDld-4.5
set child [createChildProcess $name]
dde poke TclEval $name \xE1 foo
set \xE1 [dde request TclEval $name \xE1]
dde execute TclEval $name {set done 1}
update
set \xE1
} -result foo
# -------------------------------------------------------------------------
test winDde-5.1 {check for bad arguments} -constraints dde -body {
dde execute "" "" "" ""
} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"}
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 |
} -cleanup {interp delete child} -result 1
test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup {
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 {
| | | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
} -cleanup {interp delete child} -result 1
test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup {
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 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 child
child invokehidden load $::ddelib Dde
child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}}
child invokehidden dde servername -handler DDEACCEPT child
} -body {
|
| ︙ | ︙ |
Changes to unix/Makefile.in.
| ︙ | ︙ | |||
289 290 291 292 293 294 295 |
DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \
${AC_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@
TCLSH_OBJS = tclAppInit.o
TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
| | | > | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 |
DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \
${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 tclTestABSList.o
XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o \
tclTestABSList.o
GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
tclArithSeries.o tclAssembly.o tclAsync.o tclBasic.o tclBinary.o \
tclCkalloc.o tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \
tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \
tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclDisassemble.o \
tclEncoding.o tclEnsemble.o \
|
| ︙ | ︙ | |||
390 391 392 393 394 395 396 | $(GENERIC_DIR)/tclOO.h \ $(GENERIC_DIR)/tclOODecls.h \ $(GENERIC_DIR)/tclOOInt.h \ $(GENERIC_DIR)/tclOOIntDecls.h \ $(GENERIC_DIR)/tclPatch.h \ $(GENERIC_DIR)/tclPlatDecls.h \ $(GENERIC_DIR)/tclPort.h \ | < | | 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 | $(GENERIC_DIR)/tclOO.h \ $(GENERIC_DIR)/tclOODecls.h \ $(GENERIC_DIR)/tclOOInt.h \ $(GENERIC_DIR)/tclOOIntDecls.h \ $(GENERIC_DIR)/tclPatch.h \ $(GENERIC_DIR)/tclPlatDecls.h \ $(GENERIC_DIR)/tclPort.h \ $(GENERIC_DIR)/tclRegexp.h GENERIC_SRCS = \ $(GENERIC_DIR)/regcomp.c \ $(GENERIC_DIR)/regexec.c \ $(GENERIC_DIR)/regfree.c \ $(GENERIC_DIR)/regerror.c \ $(GENERIC_DIR)/tclAlloc.c \ |
| ︙ | ︙ | |||
463 464 465 466 467 468 469 470 471 472 473 474 475 476 | $(GENERIC_DIR)/tclResolve.c \ $(GENERIC_DIR)/tclResult.c \ $(GENERIC_DIR)/tclScan.c \ $(GENERIC_DIR)/tclStubInit.c \ $(GENERIC_DIR)/tclStringObj.c \ $(GENERIC_DIR)/tclStrToD.c \ $(GENERIC_DIR)/tclTest.c \ $(GENERIC_DIR)/tclTestObj.c \ $(GENERIC_DIR)/tclTestProcBodyObj.c \ $(GENERIC_DIR)/tclThread.c \ $(GENERIC_DIR)/tclThreadAlloc.c \ $(GENERIC_DIR)/tclThreadJoin.c \ $(GENERIC_DIR)/tclThreadStorage.c \ $(GENERIC_DIR)/tclTimer.c \ | > | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 | $(GENERIC_DIR)/tclResolve.c \ $(GENERIC_DIR)/tclResult.c \ $(GENERIC_DIR)/tclScan.c \ $(GENERIC_DIR)/tclStubInit.c \ $(GENERIC_DIR)/tclStringObj.c \ $(GENERIC_DIR)/tclStrToD.c \ $(GENERIC_DIR)/tclTest.c \ $(GENERIC_DIR)/tclTestABSList.c \ $(GENERIC_DIR)/tclTestObj.c \ $(GENERIC_DIR)/tclTestProcBodyObj.c \ $(GENERIC_DIR)/tclThread.c \ $(GENERIC_DIR)/tclThreadAlloc.c \ $(GENERIC_DIR)/tclThreadJoin.c \ $(GENERIC_DIR)/tclThreadStorage.c \ $(GENERIC_DIR)/tclTimer.c \ |
| ︙ | ︙ | |||
1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 | -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip \ $(GENERIC_DIR)/tclZipfs.c tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) tclUuid.h $(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 tclTestProcBodyObj.o: $(GENERIC_DIR)/tclTestProcBodyObj.c $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestProcBodyObj.c | > > > | 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 | -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip \ $(GENERIC_DIR)/tclZipfs.c tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) tclUuid.h $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c tclTestABSList.o: $(GENERIC_DIR)/tclTestABSList.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestABSList.c tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c tclTestProcBodyObj.o: $(GENERIC_DIR)/tclTestProcBodyObj.c $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestProcBodyObj.c |
| ︙ | ︙ |
Changes to unix/configure.
| ︙ | ︙ | |||
733 734 735 736 737 738 739 740 741 742 743 744 745 746 | TCL_LIBS LIBOBJS AR RANLIB TOMMATH_INCLUDE TOMMATH_SRCS TOMMATH_OBJS ZLIB_INCLUDE ZLIB_SRCS ZLIB_OBJS TCLSH_PROG SHARED_BUILD EGREP GREP | > > | 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 | TCL_LIBS LIBOBJS AR RANLIB TOMMATH_INCLUDE TOMMATH_SRCS TOMMATH_OBJS TCL_PC_CFLAGS TCL_PC_REQUIRES_PRIVATE ZLIB_INCLUDE ZLIB_SRCS ZLIB_OBJS TCLSH_PROG SHARED_BUILD EGREP GREP |
| ︙ | ︙ | |||
5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 |
libtommath_ok=no
fi
fi
fi
if test $libtommath_ok = yes
then :
printf "%s\n" "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h
else $as_nop
| > > > > | 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 |
libtommath_ok=no
fi
fi
fi
if test $libtommath_ok = yes
then :
TCL_PC_REQUIRES_PRIVATE='libtommath >= 1.2.0,'
TCL_PC_CFLAGS='-DTCL_WITH_EXTERNAL_TOMMATH'
printf "%s\n" "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h
else $as_nop
|
| ︙ | ︙ |
Changes to unix/configure.ac.
| ︙ | ︙ | |||
181 182 183 184 185 186 187 188 189 190 191 192 193 194 |
AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include <tommath.h>])],[
libtommath_ok=no])
AS_IF([test $libtommath_ok = yes], [
AC_CHECK_LIB([tommath],[mp_log_u32],[MATH_LIBS="$MATH_LIBS -ltommath"],[
libtommath_ok=no])])
fi
AS_IF([test $libtommath_ok = yes], [
AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath])
], [
AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}])
AC_SUBST(TOMMATH_SRCS,[\${TOMMATH_SRCS}])
AC_SUBST(TOMMATH_INCLUDE,[-I\${TOMMATH_DIR}])
])
| > > | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 |
AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include <tommath.h>])],[
libtommath_ok=no])
AS_IF([test $libtommath_ok = yes], [
AC_CHECK_LIB([tommath],[mp_log_u32],[MATH_LIBS="$MATH_LIBS -ltommath"],[
libtommath_ok=no])])
fi
AS_IF([test $libtommath_ok = yes], [
AC_SUBST(TCL_PC_REQUIRES_PRIVATE, ['libtommath >= 1.2.0,'])
AC_SUBST(TCL_PC_CFLAGS, ['-DTCL_WITH_EXTERNAL_TOMMATH'])
AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath])
], [
AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}])
AC_SUBST(TOMMATH_SRCS,[\${TOMMATH_SRCS}])
AC_SUBST(TOMMATH_INCLUDE,[-I\${TOMMATH_DIR}])
])
|
| ︙ | ︙ |
Changes to unix/dltest/Makefile.in.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | CFLAGS_DEBUG = @CFLAGS_DEBUG@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ -DTCL_NO_DEPRECATED=1 -Wall -Wextra -Wc++-compat -Wconversion -Werror LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
CFLAGS_DEBUG = @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ -DTCL_NO_DEPRECATED=1 -Wall -Wextra -Wc++-compat -Wconversion -Werror
LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@
CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic \
${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS}
all: embtest tcl9pkga${SHLIB_SUFFIX} tcl9pkgb${SHLIB_SUFFIX} tcl9pkgc${SHLIB_SUFFIX} \
tcl9pkgd${SHLIB_SUFFIX} tcl9pkge${SHLIB_SUFFIX} tcl9pkgt${SHLIB_SUFFIX} tcl9pkgua${SHLIB_SUFFIX} \
tcl9pkgooa${SHLIB_SUFFIX} pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgt${SHLIB_SUFFIX}
@if test -n "$(DLTEST_SUFFIX)"; then $(MAKE) dltest_suffix; fi
@touch ../dltest.marker
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | pkgua.o: $(SRC_DIR)/pkgua.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgua.c pkgooa.o: $(SRC_DIR)/pkgooa.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgooa.c embtest: embtest.o | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
pkgua.o: $(SRC_DIR)/pkgua.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgua.c
pkgooa.o: $(SRC_DIR)/pkgooa.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgooa.c
embtest: embtest.o
$(CC) $(CC_SWITCHES) -o $@ embtest.o ${SHLIB_LD_LIBS}
tcl9pkgπ${SHLIB_SUFFIX}: pkgπ.o
${SHLIB_LD} -o $@ pkgπ.o ${SHLIB_LD_LIBS}
tcl9pkga${SHLIB_SUFFIX}: pkga.o
${SHLIB_LD} -o $@ pkga.o ${SHLIB_LD_LIBS}
|
| ︙ | ︙ |
Changes to unix/dltest/pkgb.c.
1 2 3 | /* * pkgb.c -- * | | | 1 2 3 4 5 6 7 8 9 10 11 | /* * pkgb.c -- * * This file contains a simple Tcl package "pkgb" that is intended for * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. |
| ︙ | ︙ |
Changes to unix/dltest/pkgd.c.
1 2 3 | /* * pkgd.c -- * | | | 1 2 3 4 5 6 7 8 9 10 11 | /* * pkgd.c -- * * This file contains a simple Tcl package "pkgd" that is intended for * testing the Tcl dynamic loading facilities. It can be used in both * safe and unsafe interpreters. * * Copyright © 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. |
| ︙ | ︙ |
Changes to unix/tcl.pc.in.
1 2 3 4 5 6 7 8 9 10 11 12 | # tcl pkg-config source file prefix=@prefix@ exec_prefix=@exec_prefix@ libdir=@libdir@ includedir=@includedir@ libfile=@TCL_LIB_FILE@ Name: Tool Command Language Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses. URL: https://www.tcl-lang.org/ Version: @TCL_VERSION@@TCL_PATCH_LEVEL@ | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
# tcl pkg-config source file
prefix=@prefix@
exec_prefix=@exec_prefix@
libdir=@libdir@
includedir=@includedir@
libfile=@TCL_LIB_FILE@
Name: Tool Command Language
Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses.
URL: https://www.tcl-lang.org/
Version: @TCL_VERSION@@TCL_PATCH_LEVEL@
Requires.private: @TCL_PC_REQUIRES_PRIVATE@ zlib >= 1.2.3
Libs: -L${libdir} @TCL_LIB_FLAG@ @TCL_STUB_LIB_FLAG@
Libs.private: @TCL_LIBS@
Cflags: -I${includedir} @TCL_PC_CFLAGS@
|
Changes to win/Makefile.in.
| ︙ | ︙ | |||
265 266 267 268 269 270 271 272 273 274 275 276 277 278 |
STUB_CC_SWITCHES = -I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
-I"${ZLIB_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} -DMP_PREC=4 \
${AC_FLAGS} ${COMPILE_DEBUG_FLAGS}
TCLTEST_OBJS = \
tclTest.$(OBJEXT) \
tclTestObj.$(OBJEXT) \
tclTestProcBodyObj.$(OBJEXT) \
tclThreadTest.$(OBJEXT) \
tclWinTest.$(OBJEXT)
GENERIC_OBJS = \
regcomp.$(OBJEXT) \
| > | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 |
STUB_CC_SWITCHES = -I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
-I"${ZLIB_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} -DMP_PREC=4 \
${AC_FLAGS} ${COMPILE_DEBUG_FLAGS}
TCLTEST_OBJS = \
tclTest.$(OBJEXT) \
tclTestABSList.$(OBJEXT) \
tclTestObj.$(OBJEXT) \
tclTestProcBodyObj.$(OBJEXT) \
tclThreadTest.$(OBJEXT) \
tclWinTest.$(OBJEXT)
GENERIC_OBJS = \
regcomp.$(OBJEXT) \
|
| ︙ | ︙ |
Changes to win/makefile.vc.
| ︙ | ︙ | |||
221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 | TCLTESTOBJS = \ $(TMP_DIR)\tclTest.obj \ $(TMP_DIR)\tclTestObj.obj \ $(TMP_DIR)\tclTestProcBodyObj.obj \ $(TMP_DIR)\tclThreadTest.obj \ $(TMP_DIR)\tclWinTest.obj \ !if !$(STATIC_BUILD) $(OUT_DIR)\tommath.lib \ !endif $(TMP_DIR)\testMain.obj COREOBJS = \ $(TMP_DIR)\regcomp.obj \ $(TMP_DIR)\regerror.obj \ $(TMP_DIR)\regexec.obj \ $(TMP_DIR)\regfree.obj \ | > | | | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 | TCLTESTOBJS = \ $(TMP_DIR)\tclTest.obj \ $(TMP_DIR)\tclTestObj.obj \ $(TMP_DIR)\tclTestProcBodyObj.obj \ $(TMP_DIR)\tclThreadTest.obj \ $(TMP_DIR)\tclWinTest.obj \ $(TMP_DIR)\tclTestABSList.obj \ !if !$(STATIC_BUILD) $(OUT_DIR)\tommath.lib \ !endif $(TMP_DIR)\testMain.obj COREOBJS = \ $(TMP_DIR)\regcomp.obj \ $(TMP_DIR)\regerror.obj \ $(TMP_DIR)\regexec.obj \ $(TMP_DIR)\regfree.obj \ $(TMP_DIR)\tclArithSeries.obj \ $(TMP_DIR)\tclAlloc.obj \ $(TMP_DIR)\tclAssembly.obj \ $(TMP_DIR)\tclAsync.obj \ $(TMP_DIR)\tclBasic.obj \ $(TMP_DIR)\tclBinary.obj \ $(TMP_DIR)\tclCkalloc.obj \ $(TMP_DIR)\tclClock.obj \ $(TMP_DIR)\tclCmdAH.obj \ |
| ︙ | ︙ | |||
823 824 825 826 827 828 829 830 831 832 833 834 835 836 | $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclUuid.h $(cc32) $(appcflags) -I$(TMP_DIR) \ -Fo$@ $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c $(cc32) $(appcflags) -Fo$@ $? $(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 \ | > > > | 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 | $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclUuid.h $(cc32) $(appcflags) -I$(TMP_DIR) \ -Fo$@ $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c $(cc32) $(appcflags) -Fo$@ $? $(TMP_DIR)\tclTestABSList.obj: $(GENERICDIR)\tclTestABSList.c $(cc32) $(appcflags) -Fo$@ $? $(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 \ |
| ︙ | ︙ |