1# Commands covered:  lrange
2#
3# This file contains a collection of tests for one or more of the Tcl
4# built-in commands.  Sourcing this file into Tcl runs the tests and
5# generates output for errors.  No output means no errors were found.
6#
7# Copyright © 1991-1993 The Regents of the University of California.
8# Copyright © 1994 Sun Microsystems, Inc.
9# Copyright © 1998-1999 Scriptics Corporation.
10#
11# See the file "license.terms" for information on usage and redistribution
12# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13
14if {"::tcltest" ni [namespace children]} {
15    package require tcltest 2.5
16    namespace import -force ::tcltest::*
17}
18
19::tcltest::loadTestedCommands
20catch [list package require -exact tcl::test [info patchlevel]]
21
22testConstraint testpurebytesobj [llength [info commands testpurebytesobj]]
23
24test lrange-1.1 {range of list elements} {
25    lrange {a b c d} 1 2
26} {b c}
27test lrange-1.2 {range of list elements} {
28    lrange {a {bcd e {f g {}}} l14 l15 d} 1 1
29} {{bcd e {f g {}}}}
30test lrange-1.3 {range of list elements} {
31    lrange {a {bcd e {f g {}}} l14 l15 d} 3 end
32} {l15 d}
33test lrange-1.4 {range of list elements} {
34    lrange {a {bcd e {f g {}}} l14 l15 d} 4 10000
35} {d}
36test lrange-1.5 {range of list elements} {
37    lrange {a {bcd e {f g {}}} l14 l15 d} 4 3
38} {}
39test lrange-1.6 {range of list elements} {
40    lrange {a {bcd e {f g {}}} l14 l15 d} 10 11
41} {}
42test lrange-1.7 {range of list elements} {
43    lrange {a b c d e} -1 2
44} {a b c}
45test lrange-1.8 {range of list elements} {
46    lrange {a b c d e} -2 -1
47} {}
48test lrange-1.9 {range of list elements} {
49    lrange {a b c d e} -2 end
50} {a b c d e}
51test lrange-1.10 {range of list elements} {
52    lrange "a b\{c d" 1 2
53} "b\\{c d"
54test lrange-1.11 {range of list elements} {
55    lrange "a b c d" end end
56} d
57test lrange-1.12 {range of list elements} {
58    lrange "a b c d" end 100000
59} d
60test lrange-1.13 {range of list elements} {
61    lrange "a b c d" end 3
62} d
63test lrange-1.14 {range of list elements} {
64    lrange "a b c d" end 2
65} {}
66test lrange-1.15 {range of list elements} {
67    concat \"[lrange {a b \{\   	} 0 2]"
68} {"a b \{\ "}
69# emacs highlighting bug workaround --> "
70test lrange-1.16 {list element quoting} {
71    lrange {[append a .b]} 0 end
72} {{[append} a .b\]}
73
74test lrange-2.1 {error conditions} {
75    list [catch {lrange a b} msg] $msg
76} {1 {wrong # args: should be "lrange list first last"}}
77test lrange-2.2 {error conditions} {
78    list [catch {lrange a b 6 7} msg] $msg
79} {1 {wrong # args: should be "lrange list first last"}}
80test lrange-2.3 {error conditions} {
81    list [catch {lrange a b 6} msg] $msg
82} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
83test lrange-2.4 {error conditions} {
84    list [catch {lrange a 0 enigma} msg] $msg
85} {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}}
86test lrange-2.5 {error conditions} {
87    list [catch {lrange "a \{b c" 3 4} msg] $msg
88} {1 {unmatched open brace in list}}
89test lrange-2.6 {error conditions} {
90    list [catch {lrange "a b c \{ d e" 1 4} msg] $msg
91} {1 {unmatched open brace in list}}
92
93test lrange-3.1 {Bug 3588366: end-offsets before start} {
94    apply {l {
95	lrange $l 0 end-5
96    }} {1 2 3 4 5}
97} {}
98test lrange-3.2 {compiled with static indices out of range, negative} {
99    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]
100} [lrepeat 4 {}]
101test lrange-3.3 {compiled with calculated indices out of range, negative constant} {
102    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]
103} [lrepeat 4 {}]
104test lrange-3.4 {compiled with calculated indices out of range, after end} -body {
105    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]
106} -result [lrepeat 4 {}]
107
108test lrange-3.5 {compiled with calculated indices, start out of range (negative)} {
109    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]
110} [lrepeat 4 {a b}]
111test lrange-3.6 {compiled with calculated indices, end out of range (after end)} {
112    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]
113} [lrepeat 4 {b c}]
114
115test lrange-3.7a {compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} {
116    list [lrange { } 0 1] [lrange [format %c 32] 0 1] [lrange [set a { }] 0 1] \
117	 [lrange { } 0-1 end+1] [lrange [format %c 32] 0-1 end+1] [lrange $a 0-1 end+1]
118} [lrepeat 6 {}]
119test lrange-3.7b {not compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} -body {
120    set cmd lrange
121    list [$cmd { } 0 1] [$cmd [format %c 32] 0 1] [$cmd [set a { }] 0 1] \
122	 [$cmd { } 0-1 end+1] [$cmd [format %c 32] 0-1 end+1] [$cmd $a 0-1 end+1]
123} -result [lrepeat 6 {}]
124# following 4 tests could cause a segfault on empty non-lists with tclEmptyStringRep
125# (as before the fix [58c46e74b931d3a1]):
126test lrange-3.7a.2 {compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} {
127    list [lrange {} 0 1] [lrange [lindex a -1] 0 1] [lrange [set a {}] 0 1] \
128	 [lrange {} 0-1 end+1] [lrange [lindex a -1] 0-1 end+1] [lrange $a 0-1 end+1]
129} [lrepeat 6 {}]
130test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} -body {
131    set cmd lrange
132    list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \
133	 [$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1]
134} -result [lrepeat 6 {}]
135test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints {
136    testpurebytesobj
137} -body {
138    list [lrange [testpurebytesobj] 0 1] [lrange [testpurebytesobj { }] 0 1] [lrange [set a [testpurebytesobj {}]] 0 1] \
139	 [lrange [testpurebytesobj] 0-1 end+1] [lrange [testpurebytesobj { }] 0-1 end+1] [lrange $a 0-1 end+1]
140} -result [lrepeat 6 {}]
141test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints {
142    testpurebytesobj
143} -body {
144    set cmd lrange
145    list [$cmd [testpurebytesobj] 0 1] [$cmd [testpurebytesobj { }] 0 1] [$cmd [set a [testpurebytesobj {}]] 0 1] \
146	 [$cmd [testpurebytesobj] 0-1 end+1] [$cmd [testpurebytesobj { }] 0-1 end+1] [$cmd $a 0-1 end+1]
147} -result [lrepeat 6 {}]
148
149test lrange-4.1 {lrange pure promise} -body {
150    set ll1 [list $tcl_version 2 3 4]
151    # Shared
152    set ll2 $ll1
153    # With string rep
154    string length $ll1
155    set rep1 [tcl::unsupported::representation $ll1]
156    # Get new pure object
157    set x [lrange $ll1 0 end]
158    set rep2 [tcl::unsupported::representation $x]
159    regexp {object pointer at (\S+)} $rep1 -> obj1
160    regexp {object pointer at (\S+)} $rep2 -> obj2
161    list $rep1 $rep2 [string equal $obj1 $obj2]
162    # Check for a new clean object
163} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0}
164
165test lrange-4.2 {lrange pure promise} -body {
166    set ll1 [list $tcl_version 2 3 4]
167    # Shared
168    set ll2 $ll1
169    # With string rep
170    string length $ll1
171    set rep1 [tcl::unsupported::representation $ll1]
172    # Get new pure object, not compiled
173    set x [[string cat l range] $ll1 0 end]
174    set rep2 [tcl::unsupported::representation $x]
175    regexp {object pointer at (\S+)} $rep1 -> obj1
176    regexp {object pointer at (\S+)} $rep2 -> obj2
177    list $rep1 $rep2 [string equal $obj1 $obj2]
178    # Check for a new clean object
179} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0}
180
181test lrange-4.3 {lrange pure promise} -body {
182    set ll1 [list $tcl_version 2 3 4]
183    # With string rep
184    string length $ll1
185    set rep1 [tcl::unsupported::representation $ll1]
186    # Get pure object, unshared
187    set ll2 [lrange $ll1[set ll1 {}] 0 end]
188    set rep2 [tcl::unsupported::representation $ll2]
189    regexp {object pointer at (\S+)} $rep1 -> obj1
190    regexp {object pointer at (\S+)} $rep2 -> obj2
191    list $rep1 $rep2 [string equal $obj1 $obj2]
192    # Internal optimisations should keep the same object
193} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1}
194
195test lrange-4.4 {lrange pure promise} -body {
196    set ll1 [list $tcl_version 2 3 4]
197    # With string rep
198    string length $ll1
199    set rep1 [tcl::unsupported::representation $ll1]
200    # Get pure object, unshared, not compiled
201    set ll2 [[string cat l range] $ll1[set ll1 {}] 0 end]
202    set rep2 [tcl::unsupported::representation $ll2]
203    regexp {object pointer at (\S+)} $rep1 -> obj1
204    regexp {object pointer at (\S+)} $rep2 -> obj2
205    list $rep1 $rep2 [string equal $obj1 $obj2]
206    # Internal optimisations should keep the same object
207} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1}
208
209# Testing for compiled vs non-compiled behaviour, and shared vs non-shared.
210# Far too many variations to check with spelt-out tests.
211# Note that this *just* checks whether the different versions are the same
212# not whether any of them is correct.
213apply {{} {
214    set lss     {{} {a} {a b c} {a b c d}}
215    set idxs    {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2}
216    set lrange  lrange
217
218    foreach ls $lss {
219	foreach a $idxs {
220	    foreach b $idxs {
221                # Shared, uncompiled
222                set ls2 $ls
223                set expected [list [catch {$lrange $ls $a $b} m] $m]
224                # Shared, compiled
225                set tester [list lrange $ls $a $b]
226                set script [list catch $tester m]
227                set script "list \[$script\] \$m"
228                test lrange-5.[incr n].1 {lrange shared compiled} -body \
229			[list apply [list {} $script]] -result $expected
230                # Unshared, uncompiled
231                set tester [string map [list %l [list $ls] %a $a %b $b] {
232                    [string cat l range] [lrange %l 0 end] %a %b
233                }]
234                set script [list catch $tester m]
235                set script "list \[$script\] \$m"
236                test lrange-5.$n.2 {lrange unshared uncompiled} -body \
237			[list apply [list {} $script]] -result $expected
238                # Unshared, compiled
239                set tester [string map [list %l [list $ls] %a $a %b $b] {
240                    lrange [lrange %l 0 end] %a %b
241                }]
242                set script [list catch $tester m]
243                set script "list \[$script\] \$m"
244                test lrange-5.$n.3 {lrange unshared compiled} -body \
245			[list apply [list {} $script]] -result $expected
246	    }
247	}
248    }
249}}
250
251# cleanup
252::tcltest::cleanupTests
253return
254
255# Local Variables:
256# mode: tcl
257# End:
258