diff options
Diffstat (limited to 'tests/lrange.test')
| -rw-r--r-- | tests/lrange.test | 180 |
1 files changed, 6 insertions, 174 deletions
diff --git a/tests/lrange.test b/tests/lrange.test index 695c370..ec5936d 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -4,23 +4,18 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright © 1991-1993 The Regents of the University of California. -# Copyright © 1994 Sun Microsystems, Inc. -# Copyright © 1998-1999 Scriptics Corporation. +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest namespace import -force ::tcltest::* } -::tcltest::loadTestedCommands -catch [list package require -exact tcl::test [info patchlevel]] - -testConstraint testpurebytesobj [llength [info commands testpurebytesobj]] - test lrange-1.1 {range of list elements} { lrange {a b c d} 1 2 } {b c} @@ -66,9 +61,8 @@ test lrange-1.14 {range of list elements} { test lrange-1.15 {range of list elements} { concat \"[lrange {a b \{\ } 0 2]" } {"a b \{\ "} -# emacs highlighting bug workaround --> " test lrange-1.16 {list element quoting} { - lrange {[append a .b]} 0 end + lrange {[append a .b]} 0 end } {{[append} a .b\]} test lrange-2.1 {error conditions} { @@ -90,168 +84,6 @@ test lrange-2.6 {error conditions} { list [catch {lrange "a b c \{ d e" 1 4} msg] $msg } {1 {unmatched open brace in list}} -test lrange-3.1 {Bug 3588366: end-offsets before start} { - apply {l { - lrange $l 0 end-5 - }} {1 2 3 4 5} -} {} -test lrange-3.2 {compiled with static indices out of range, negative} { - list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3] -} [lrepeat 4 {}] -test lrange-3.3 {compiled with calculated indices out of range, negative constant} { - list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1] -} [lrepeat 4 {}] -test lrange-3.4 {compiled with calculated indices out of range, after end} -body { - list [lrange {a b c} end+1 end+2] [lrange {a b c} end+2 end+1] [lrange {a b c} end+2 end+3] [lrange {a b c} end+3 end+2] -} -result [lrepeat 4 {}] - -test lrange-3.5 {compiled with calculated indices, start out of range (negative)} { - list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1] -} [lrepeat 4 {a b}] -test lrange-3.6 {compiled with calculated indices, end out of range (after end)} { - list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1] -} [lrepeat 4 {b c}] - -test lrange-3.7a {compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} { - list [lrange { } 0 1] [lrange [format %c 32] 0 1] [lrange [set a { }] 0 1] \ - [lrange { } 0-1 end+1] [lrange [format %c 32] 0-1 end+1] [lrange $a 0-1 end+1] -} [lrepeat 6 {}] -test lrange-3.7b {not compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} -body { - set cmd lrange - list [$cmd { } 0 1] [$cmd [format %c 32] 0 1] [$cmd [set a { }] 0 1] \ - [$cmd { } 0-1 end+1] [$cmd [format %c 32] 0-1 end+1] [$cmd $a 0-1 end+1] -} -result [lrepeat 6 {}] -# following 4 tests could cause a segfault on empty non-lists with tclEmptyStringRep -# (as before the fix [58c46e74b931d3a1]): -test lrange-3.7a.2 {compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} { - list [lrange {} 0 1] [lrange [lindex a -1] 0 1] [lrange [set a {}] 0 1] \ - [lrange {} 0-1 end+1] [lrange [lindex a -1] 0-1 end+1] [lrange $a 0-1 end+1] -} [lrepeat 6 {}] -test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} -body { - set cmd lrange - list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \ - [$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1] -} -result [lrepeat 6 {}] -test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints { - testpurebytesobj -} -body { - list [lrange [testpurebytesobj] 0 1] [lrange [testpurebytesobj { }] 0 1] [lrange [set a [testpurebytesobj {}]] 0 1] \ - [lrange [testpurebytesobj] 0-1 end+1] [lrange [testpurebytesobj { }] 0-1 end+1] [lrange $a 0-1 end+1] -} -result [lrepeat 6 {}] -test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints { - testpurebytesobj -} -body { - set cmd lrange - list [$cmd [testpurebytesobj] 0 1] [$cmd [testpurebytesobj { }] 0 1] [$cmd [set a [testpurebytesobj {}]] 0 1] \ - [$cmd [testpurebytesobj] 0-1 end+1] [$cmd [testpurebytesobj { }] 0-1 end+1] [$cmd $a 0-1 end+1] -} -result [lrepeat 6 {}] - -test lrange-4.1 {lrange pure promise} -body { - set ll1 [list $tcl_version 2 3 4] - # Shared - set ll2 $ll1 - # With string rep - string length $ll1 - set rep1 [tcl::unsupported::representation $ll1] - # Get new pure object - set x [lrange $ll1 0 end] - set rep2 [tcl::unsupported::representation $x] - regexp {object pointer at (\S+)} $rep1 -> obj1 - regexp {object pointer at (\S+)} $rep2 -> obj2 - list $rep1 $rep2 [string equal $obj1 $obj2] - # Check for a new clean object -} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0} - -test lrange-4.2 {lrange pure promise} -body { - set ll1 [list $tcl_version 2 3 4] - # Shared - set ll2 $ll1 - # With string rep - string length $ll1 - set rep1 [tcl::unsupported::representation $ll1] - # Get new pure object, not compiled - set x [[string cat l range] $ll1 0 end] - set rep2 [tcl::unsupported::representation $x] - regexp {object pointer at (\S+)} $rep1 -> obj1 - regexp {object pointer at (\S+)} $rep2 -> obj2 - list $rep1 $rep2 [string equal $obj1 $obj2] - # Check for a new clean object -} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0} - -test lrange-4.3 {lrange pure promise} -body { - set ll1 [list $tcl_version 2 3 4] - # With string rep - string length $ll1 - set rep1 [tcl::unsupported::representation $ll1] - # Get pure object, unshared - set ll2 [lrange $ll1[set ll1 {}] 0 end] - set rep2 [tcl::unsupported::representation $ll2] - regexp {object pointer at (\S+)} $rep1 -> obj1 - regexp {object pointer at (\S+)} $rep2 -> obj2 - list $rep1 $rep2 [string equal $obj1 $obj2] - # Internal optimisations should keep the same object -} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} - -test lrange-4.4 {lrange pure promise} -body { - set ll1 [list $tcl_version 2 3 4] - # With string rep - string length $ll1 - set rep1 [tcl::unsupported::representation $ll1] - # Get pure object, unshared, not compiled - set ll2 [[string cat l range] $ll1[set ll1 {}] 0 end] - set rep2 [tcl::unsupported::representation $ll2] - regexp {object pointer at (\S+)} $rep1 -> obj1 - regexp {object pointer at (\S+)} $rep2 -> obj2 - list $rep1 $rep2 [string equal $obj1 $obj2] - # Internal optimisations should keep the same object -} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} - -# Testing for compiled vs non-compiled behaviour, and shared vs non-shared. -# Far too many variations to check with spelt-out tests. -# Note that this *just* checks whether the different versions are the same -# not whether any of them is correct. -apply {{} { - set lss {{} {a} {a b c} {a b c d}} - set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2} - set lrange lrange - - foreach ls $lss { - foreach a $idxs { - foreach b $idxs { - # Shared, uncompiled - set ls2 $ls - set expected [list [catch {$lrange $ls $a $b} m] $m] - # Shared, compiled - set tester [list lrange $ls $a $b] - set script [list catch $tester m] - set script "list \[$script\] \$m" - test lrange-5.[incr n].1 {lrange shared compiled} -body \ - [list apply [list {} $script]] -result $expected - # Unshared, uncompiled - set tester [string map [list %l [list $ls] %a $a %b $b] { - [string cat l range] [lrange %l 0 end] %a %b - }] - set script [list catch $tester m] - set script "list \[$script\] \$m" - test lrange-5.$n.2 {lrange unshared uncompiled} -body \ - [list apply [list {} $script]] -result $expected - # Unshared, compiled - set tester [string map [list %l [list $ls] %a $a %b $b] { - lrange [lrange %l 0 end] %a %b - }] - set script [list catch $tester m] - set script "list \[$script\] \$m" - test lrange-5.$n.3 {lrange unshared compiled} -body \ - [list apply [list {} $script]] -result $expected - } - } - } -}} - # cleanup ::tcltest::cleanupTests return - -# Local Variables: -# mode: tcl -# End: |