diff options
Diffstat (limited to 'tests/foreach.test')
| -rw-r--r-- | tests/foreach.test | 113 |
1 files changed, 82 insertions, 31 deletions
diff --git a/tests/foreach.test b/tests/foreach.test index 5a13035..6fd5476 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -9,12 +9,10 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: foreach.test,v 1.4 1999/06/26 03:54:14 jenn Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest - namespace import ::tcltest::* + namespace import -force ::tcltest::* } catch {unset a} @@ -73,8 +71,11 @@ catch {unset a} test foreach-1.14 {foreach errors} { catch {unset a} set a(0) 44 - list [catch {foreach a {1 2 3} {}} msg] $msg -} {1 {couldn't set loop variable: "a"}} + list [catch {foreach a {1 2 3} {}} msg o] $msg $::errorInfo +} {1 {can't set "a": variable is array} {can't set "a": variable is array + (setting foreach loop variable "a") + invoked from within +"foreach a {1 2 3} {}"}} test foreach-1.15 {foreach errors} { list [catch {foreach {} {} {}} msg] $msg } {1 {foreach varlist is empty}} @@ -157,13 +158,13 @@ test foreach-3.1 {compiled foreach backward jump works correctly} { return $l } array set x {0 zero 1 one 2 two 3 three} - foo x -} {{0 zero} {1 one} {2 two} {3 three}} + lsort [foo x] +} [lsort {{0 zero} {1 one} {2 two} {3 three}}] test foreach-4.1 {noncompiled foreach and shared variable or value list objects that are converted to another type} { catch {unset x} foreach {12.0} {a b c} { - set x 12.0 + set x 12.0 set x [expr $x + 1] } set x @@ -171,8 +172,8 @@ test foreach-4.1 {noncompiled foreach and shared variable or value list objects # Check "continue". -test foreach-4.1 {continue tests} {catch continue} 4 -test foreach-4.2 {continue tests} { +test foreach-5.1 {continue tests} {catch continue} 4 +test foreach-5.2 {continue tests} { set a {} foreach i {a b c d} { if {[string compare $i "b"] == 0} continue @@ -180,7 +181,7 @@ test foreach-4.2 {continue tests} { } set a } {a c d} -test foreach-4.3 {continue tests} { +test foreach-5.3 {continue tests} { set a {} foreach i {a b c d} { if {[string compare $i "b"] != 0} continue @@ -188,16 +189,16 @@ test foreach-4.3 {continue tests} { } set a } {b} -test foreach-4.4 {continue tests} {catch {continue foo} msg} 1 -test foreach-4.5 {continue tests} { +test foreach-5.4 {continue tests} {catch {continue foo} msg} 1 +test foreach-5.5 {continue tests} { catch {continue foo} msg set msg } {wrong # args: should be "continue"} # Check "break". -test foreach-5.1 {break tests} {catch break} 3 -test foreach-5.2 {break tests} { +test foreach-6.1 {break tests} {catch break} 3 +test foreach-6.2 {break tests} { set a {} foreach i {a b c d} { if {[string compare $i "c"] == 0} break @@ -205,15 +206,23 @@ test foreach-5.2 {break tests} { } set a } {a b} -test foreach-5.3 {break tests} {catch {break foo} msg} 1 -test foreach-5.4 {break tests} { +test foreach-6.3 {break tests} {catch {break foo} msg} 1 +test foreach-6.4 {break tests} { catch {break foo} msg set msg } {wrong # args: should be "break"} +# Check for bug #406709 +test foreach-6.5 {break tests} { + proc a {} { + set a 1 + foreach b b {list [concat a; break]; incr a} + incr a + } + a +} {2} # Test for incorrect "double evaluation" semantics - -test foreach-6.1 {delayed substitution of body} {knownBug} { +test foreach-7.1 {delayed substitution of body} { proc foo {} { set a 0 foreach a [list 1 2 3] " @@ -224,20 +233,62 @@ test foreach-6.1 {delayed substitution of body} {knownBug} { foo } {0} -# cleanup -catch {unset a} -catch {unset x} -::tcltest::cleanupTests -return - - - - - - - +# Test for [Bug 1189274]; crash on failure +test foreach-8.1 {empty list handling} { + proc crash {} { + rename crash {} + set a "x y z" + set b "" + foreach aa $a bb $b { set x "aa = $aa bb = $bb" } + } + crash +} {} +# [Bug 1671138]; infinite loop with empty var list in bytecompiled version +test foreach-9.1 {compiled empty var list} { + proc foo {} { + foreach {} x { + error "reached body" + } + } + list [catch { foo } msg] $msg +} {1 {foreach varlist is empty}} +test foreach-9.2 {line numbers} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + foreach x y {*}{ + } {return [incr n -[linenumber]]} + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 +test foreach-10.1 {foreach: [Bug 1671087]} -setup { + proc demo {} { + set vals {1 2 3 4} + trace add variable x write {string length $vals ;# } + foreach {x y} $vals {format $y} + } +} -body { + demo +} -cleanup { + rename demo {} +} -result {} +test foreach-11.1 {error then dereference loop var (dev bug)} { + catch { foreach a 0 b {1 2 3} { error x } } + set a +} 0 +test foreach-11.2 {error then dereference loop var (dev bug)} { + catch { foreach a 0 b {1 2 3} { incr a $b; error x } } + set a +} 1 +# cleanup +catch {unset a} +catch {unset x} +catch {rename foo {}} +::tcltest::cleanupTests +return |