blob: 1973477e5ef4a3380fb74231da81958b5999c2fe (
plain)
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
|
source testing.tcl
# Test that control structures can be implemented in a proc
proc control {cond code} {
set iscond [uplevel 1 expr $cond]
#puts "$cond -> $iscond"
if {$iscond} {
set rc [catch [list uplevel 1 $code] error]
#puts "$code -> rc=$rc, error=$error"
return -code $rc $error
}
}
test control-1.1 "False case" {
control 0 bogus
} {}
test control-1.2 "Simple case" {
control 1 {return result}
} {result}
test control-1.3 "Break from proc" {
set result {}
foreach i {1 2 3 4 5} {
control {$i == 4} {break}
lappend result $i
}
set result
} {1 2 3}
test control-1.4 "Return from proc" {
foreach i {1 2 3 4 5} {
control {$i == 3} {return $i}
}
} {3}
test control-1.5 "Continue from proc" {
set result {}
foreach i {1 2 3 4 5} {
control {$i == 2} {continue}
lappend result $i
}
set result
} {1 3 4 5}
# case is a proc, but it should be able
# to cause a return in do_case
proc do_case {var} {
case $var in {
1 {
return one
}
2 {
return two
}
3 {
return 33
}
4 {
continue
}
5 {
break
}
6 {
return six
}
}
return zero
}
test control-2.1 "Return from case" {
set result {}
foreach i {0 1 2 3 4 5 6} {
lappend result [do_case $i]
}
set result
} {zero one two 33}
|
