# Commands covered: lrange
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::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}
test lrange-1.2 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 1 1
} {{bcd e {f g {}}}}
test lrange-1.3 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 3 end
} {l15 d}
test lrange-1.4 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 4 10000
} {d}
test lrange-1.5 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 4 3
} {}
test lrange-1.6 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 10 11
} {}
test lrange-1.7 {range of list elements} {
lrange {a b c d e} -1 2
} {a b c}
test lrange-1.8 {range of list elements} {
lrange {a b c d e} -2 -1
} {}
test lrange-1.9 {range of list elements} {
lrange {a b c d e} -2 end
} {a b c d e}
test lrange-1.10 {range of list elements} {
lrange "a b\{c d" 1 2
} "b\\{c d"
test lrange-1.11 {range of list elements} {
lrange "a b c d" end end
} d
test lrange-1.12 {range of list elements} {
lrange "a b c d" end 100000
} d
test lrange-1.13 {range of list elements} {
lrange "a b c d" end 3
} d
test lrange-1.14 {range of list elements} {
lrange "a b c d" end 2
} {}
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
} {{[append} a .b\]}
test lrange-2.1 {error conditions} {
list [catch {lrange a b} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.2 {error conditions} {
list [catch {lrange a b 6 7} msg] $msg
} {1 {wrong # args: should be "lrange list first last"}}
test lrange-2.3 {error conditions} {
list [catch {lrange a b 6} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.4 {error conditions} {
list [catch {lrange a 0 enigma} msg] $msg
} {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}}
test lrange-2.5 {error conditions} {
list [catch {lrange "a \{b c" 3 4} msg] $msg
} {1 {unmatched open brace in list}}
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: