1# Commands covered:  while
2#
3# This file contains a collection of tests for one or more of the Tcl built-in
4# commands.  Sourcing this file into Tcl runs the tests and generates output
5# for errors.  No output means no errors were found.
6#
7# Copyright © 1996 Sun Microsystems, Inc.
8# Copyright © 1998-1999 Scriptics Corporation.
9#
10# See the file "license.terms" for information on usage and redistribution of
11# this file, and for a DISCLAIMER OF ALL WARRANTIES.
12
13if {"::tcltest" ni [namespace children]} {
14    package require tcltest 2.5
15    namespace import -force ::tcltest::*
16}
17
18# Basic "while" operation.
19
20catch {unset i}
21catch {unset a}
22
23test while-1.1 {TclCompileWhileCmd: missing test expression} -body {
24    while
25} -returnCodes error -result {wrong # args: should be "while test command"}
26test while-1.2 {TclCompileWhileCmd: error in test expression} -body {
27    set i 0
28    catch {while {$i<} break}
29    return $::errorInfo
30} -cleanup {
31    unset i
32} -match glob -result {*"while {$i<} break"}
33test while-1.3 {TclCompileWhileCmd: error in test expression} -body {
34    while {"a"+"b"} {error "loop aborted"}
35} -returnCodes error -result {can't use non-numeric string as operand of "+"}
36test while-1.4 {TclCompileWhileCmd: multiline test expr} -body {
37    set value 1
38    while {($tcl_platform(platform) != "foobar1") && \
39	    ($tcl_platform(platform) != "foobar2")} {
40        incr value
41        break
42    }
43    return $value
44} -cleanup {
45    unset value
46} -result {2}
47test while-1.5 {TclCompileWhileCmd: non-numeric boolean test expr} -body {
48    set value 1
49    while {"true"} {
50	incr value;
51	if {$value > 5} {
52	    break;
53	}
54    }
55    return $value
56} -cleanup {
57    unset value
58} -result 6
59test while-1.6 {TclCompileWhileCmd: test expr is enclosed in quotes} {
60    set i 0
61    while "$i > 5" {}
62} {}
63test while-1.7 {TclCompileWhileCmd: missing command body} -body {
64    set i 0
65    while {$i < 5}
66} -returnCodes error -result {wrong # args: should be "while test command"}
67test while-1.8 {TclCompileWhileCmd: error compiling command body} -body {
68    set i 0
69    catch {while {$i < 5} {set}}
70    return $::errorInfo
71} -match glob -cleanup {
72    unset i
73} -result {wrong # args: should be "set varName ?newValue?"
74    while *ing
75"set"*}
76test while-1.9 {TclCompileWhileCmd: simple command body} -body {
77    set a {}
78    set i 1
79    while {$i<6} {
80	if {$i==4} break
81	set a [concat $a $i]
82        incr i
83    }
84    return $a
85} -cleanup {
86    unset a i
87} -result {1 2 3}
88test while-1.10 {TclCompileWhileCmd: command body in quotes} -body {
89    set a {}
90    set i 1
91    while {$i<6} "append a x; incr i"
92    return $a
93} -cleanup {
94    unset a i
95} -result {xxxxx}
96test while-1.11 {TclCompileWhileCmd: computed command body} -setup {
97    catch {unset x1}
98    catch {unset bb}
99    catch {unset x2}
100} -body {
101    set x1 {append a x1; }
102    set bb {break}
103    set x2 {; append a x2; incr i}
104    set a {}
105    set i 1
106    while {$i<6} $x1$bb$x2
107    return $a
108} -cleanup {
109    unset x1 bb x2 a i
110} -result {x1}
111test while-1.12 {TclCompileWhileCmd: long command body} -body {
112    set a {}
113    set i 1
114    while {$i<6} {
115	if {$i==4} break
116	if {$i>5} continue
117	if {$i>6 && $tcl_platform(machine)=="xxx"} {
118	    catch {set a $a} msg
119	    catch {incr i 5} msg
120	    catch {incr i -5} msg
121	}
122	if {$i>6 && $tcl_platform(machine)=="xxx"} {
123	    catch {set a $a} msg
124	    catch {incr i 5} msg
125	    catch {incr i -5} msg
126	}
127	if {$i>6 && $tcl_platform(machine)=="xxx"} {
128	    catch {set a $a} msg
129	    catch {incr i 5} msg
130	    catch {incr i -5} msg
131	}
132	if {$i>6 && $tcl_platform(machine)=="xxx"} {
133	    catch {set a $a} msg
134	    catch {incr i 5} msg
135	    catch {incr i -5} msg
136	}
137	if {$i>6 && $tcl_platform(machine)=="xxx"} {
138	    catch {set a $a} msg
139	    catch {incr i 5} msg
140	    catch {incr i -5} msg
141	}
142	set a [concat $a $i]
143        incr i
144    }
145    return $a
146} -cleanup {
147    unset a i
148} -result {1 2 3}
149test while-1.13 {TclCompileWhileCmd: while command result} -body {
150    set i 0
151    set a [while {$i < 5} {incr i}]
152    return $a
153} -cleanup {
154    unset a i
155} -result {}
156test while-1.14 {TclCompileWhileCmd: while command result} -body {
157    set i 0
158    set a [while {$i < 5} {if {$i==3} break; incr i}]
159    return $a
160} -cleanup {
161    unset a i
162} -result {}
163
164# Check "while" and "continue".
165
166test while-2.1 {continue tests} -body {
167    set a {}
168    set i 1
169    while {$i <= 4} {
170        incr i
171	if {$i == 3} continue
172	set a [concat $a $i]
173    }
174    return $a
175} -cleanup {
176    unset a i
177} -result {2 4 5}
178test while-2.2 {continue tests} -body {
179    set a {}
180    set i 1
181    while {$i <= 4} {
182        incr i
183	if {$i != 2} continue
184	set a [concat $a $i]
185    }
186    return $a
187} -cleanup {
188    unset a i
189} -result {2}
190test while-2.3 {continue tests, nested loops} -body {
191    set msg {}
192    set i 1
193    while {$i <= 4} {
194        incr i
195        set a 1
196	while {$a <= 2} {
197            incr a
198            if {$i>=3 && $a>=3} continue
199            set msg [concat $msg "$i.$a"]
200        }
201    }
202    return $msg
203} -cleanup {
204    unset a i msg
205} -result {2.2 2.3 3.2 4.2 5.2}
206test while-2.4 {continue tests, long command body} -body {
207    set a {}
208    set i 1
209    while {$i<6} {
210	if {$i==2} {incr i; continue}
211	if {$i==4} break
212	if {$i>5} continue
213	if {$i>6 && $tcl_platform(machine)=="xxx"} {
214	    catch {set a $a} msg
215	    catch {incr i 5} msg
216	    catch {incr i -5} msg
217	}
218	if {$i>6 && $tcl_platform(machine)=="xxx"} {
219	    catch {set a $a} msg
220	    catch {incr i 5} msg
221	    catch {incr i -5} msg
222	}
223	if {$i>6 && $tcl_platform(machine)=="xxx"} {
224	    catch {set a $a} msg
225	    catch {incr i 5} msg
226	    catch {incr i -5} msg
227	}
228	if {$i>6 && $tcl_platform(machine)=="xxx"} {
229	    catch {set a $a} msg
230	    catch {incr i 5} msg
231	    catch {incr i -5} msg
232	}
233	if {$i>6 && $tcl_platform(machine)=="xxx"} {
234	    catch {set a $a} msg
235	    catch {incr i 5} msg
236	    catch {incr i -5} msg
237	}
238	set a [concat $a $i]
239        incr i
240    }
241    return $a
242} -cleanup {
243    unset a i
244} -result {1 3}
245
246# Check "while" and "break".
247
248test while-3.1 {break tests} -body {
249    set a {}
250    set i 1
251    while {$i <= 4} {
252	if {$i == 3} break
253	set a [concat $a $i]
254        incr i
255    }
256    return $a
257} -cleanup {
258    unset a i
259} -result {1 2}
260test while-3.2 {break tests, nested loops} -body {
261    set msg {}
262    set i 1
263    while {$i <= 4} {
264        set a 1
265	while {$a <= 2} {
266            if {$i>=2 && $a>=2} break
267            set msg [concat $msg "$i.$a"]
268            incr a
269        }
270        incr i
271    }
272    return $msg
273} -cleanup {
274    unset a i msg
275} -result {1.1 1.2 2.1 3.1 4.1}
276test while-3.3 {break tests, long command body} -body {
277    set a {}
278    set i 1
279    while {$i<6} {
280	if {$i==2} {incr i; continue}
281	if {$i==5} break
282	if {$i>5} continue
283	if {$i>6 && $tcl_platform(machine)=="xxx"} {
284	    catch {set a $a} msg
285	    catch {incr i 5} msg
286	    catch {incr i -5} msg
287	}
288	if {$i>6 && $tcl_platform(machine)=="xxx"} {
289	    catch {set a $a} msg
290	    catch {incr i 5} msg
291	    catch {incr i -5} msg
292	}
293	if {$i>6 && $tcl_platform(machine)=="xxx"} {
294	    catch {set a $a} msg
295	    catch {incr i 5} msg
296	    catch {incr i -5} msg
297	}
298	if {$i==4} break
299	if {$i>6 && $tcl_platform(machine)=="xxx"} {
300	    catch {set a $a} msg
301	    catch {incr i 5} msg
302	    catch {incr i -5} msg
303	}
304	if {$i>6 && $tcl_platform(machine)=="xxx"} {
305	    catch {set a $a} msg
306	    catch {incr i 5} msg
307	    catch {incr i -5} msg
308	}
309	set a [concat $a $i]
310        incr i
311    }
312    return $a
313} -cleanup {
314    unset a i
315} -result {1 3}
316
317# Check "while" with computed command names.
318
319test while-4.1 {while and computed command names} -body {
320    set i 0
321    set z while
322    $z {$i < 10} {
323        incr i
324    }
325    return $i
326} -cleanup {
327    unset i z
328} -result 10
329test while-4.2 {while (not compiled): missing test expression} -body {
330    set z while
331    $z
332} -returnCodes error -cleanup {
333    unset z
334} -result {wrong # args: should be "while test command"}
335test while-4.3 {while (not compiled): error in test expression} -body {
336    set i 0
337    set z while
338    catch {$z {$i<} {set x 1}}
339    return $::errorInfo
340} -match glob -cleanup {
341    unset i z
342} -result {*"$z {$i<} {set x 1}"}
343test while-4.4 {while (not compiled): error in test expression} -body {
344    set z while
345    $z {"a"+"b"} {error "loop aborted"}
346} -returnCodes error -result {can't use non-numeric string as operand of "+"}
347test while-4.5 {while (not compiled): multiline test expr} -body {
348    set value 1
349    set z while
350    $z {($tcl_platform(platform) != "foobar1") && \
351	    ($tcl_platform(platform) != "foobar2")} {
352        incr value
353        break
354    }
355    return $value
356} -cleanup {
357    unset value z
358} -result {2}
359test while-4.6 {while (not compiled): non-numeric boolean test expr} -body {
360    set value 1
361    set z while
362    $z {"true"} {
363	incr value;
364	if {$value > 5} {
365	    break;
366	}
367    }
368    return $value
369} -cleanup {
370    unset value z
371} -result 6
372test while-4.7 {while (not compiled): test expr is enclosed in quotes} -body {
373    set i 0
374    set z while
375    $z "$i > 5" {}
376} -cleanup {
377    unset i z
378} -result {}
379test while-4.8 {while (not compiled): missing command body} -body {
380    set i 0
381    set z while
382    $z {$i < 5}
383} -returnCodes error -cleanup {
384    unset i z
385} -result {wrong # args: should be "while test command"}
386test while-4.9 {while (not compiled): error compiling command body} -body {
387    set i 0
388    set z while
389    catch {$z {$i < 5} {set}}
390    set ::errorInfo
391} -match glob -cleanup {
392    unset i z
393} -result {wrong # args: should be "set varName ?newValue?"
394    while *ing
395"set"
396    ("while" body line 1)
397    invoked from within
398"$z {$i < 5} {set}"}
399test while-4.10 {while (not compiled): simple command body} -body {
400    set a {}
401    set i 1
402    set z while
403    $z {$i<6} {
404	if {$i==4} break
405	set a [concat $a $i]
406        incr i
407    }
408    return $a
409} -cleanup {
410    unset a i z
411} -result {1 2 3}
412test while-4.11 {while (not compiled): command body in quotes} -body {
413    set a {}
414    set i 1
415    set z while
416    $z {$i<6} "append a x; incr i"
417    return $a
418} -cleanup {
419    unset a i z
420} -result {xxxxx}
421test while-4.12 {while (not compiled): computed command body} -setup {
422    catch {unset x1}
423    catch {unset bb}
424    catch {unset x2}
425} -body {
426    set z while
427    set x1 {append a x1; }
428    set bb {break}
429    set x2 {; append a x2; incr i}
430    set a {}
431    set i 1
432    $z {$i<6} $x1$bb$x2
433    return $a
434} -cleanup {
435    unset z x1 bb x2 a i
436} -result {x1}
437test while-4.13 {while (not compiled): long command body} -body {
438    set a {}
439    set z while
440    set i 1
441    $z {$i<6} {
442	if {$i==4} break
443	if {$i>5} continue
444	if {$i>6 && $tcl_platform(machine)=="xxx"} {
445	    catch {set a $a} msg
446	    catch {incr i 5} msg
447	    catch {incr i -5} msg
448	}
449	if {$i>6 && $tcl_platform(machine)=="xxx"} {
450	    catch {set a $a} msg
451	    catch {incr i 5} msg
452	    catch {incr i -5} msg
453	}
454	if {$i>6 && $tcl_platform(machine)=="xxx"} {
455	    catch {set a $a} msg
456	    catch {incr i 5} msg
457	    catch {incr i -5} msg
458	}
459	if {$i>6 && $tcl_platform(machine)=="xxx"} {
460	    catch {set a $a} msg
461	    catch {incr i 5} msg
462	    catch {incr i -5} msg
463	}
464	if {$i>6 && $tcl_platform(machine)=="xxx"} {
465	    catch {set a $a} msg
466	    catch {incr i 5} msg
467	    catch {incr i -5} msg
468	}
469	set a [concat $a $i]
470        incr i
471    }
472    return $a
473} -cleanup {
474    unset a i z
475} -result {1 2 3}
476test while-4.14 {while (not compiled): while command result} -body {
477    set i 0
478    set z while
479    set a [$z {$i < 5} {incr i}]
480    return $a
481} -cleanup {
482    unset a i z
483} -result {}
484test while-4.15 {while (not compiled): while command result} -body {
485    set i 0
486    set z while
487    set a [$z {$i < 5} {if {$i==3} break; incr i}]
488    return $a
489} -cleanup {
490    unset a i z
491} -result {}
492
493# Check "break" with computed command names.
494
495test while-5.1 {break and computed command names} -body {
496    set i 0
497    set z break
498    while 1 {
499        if {$i > 10} $z
500        incr i
501    }
502    return $i
503} -cleanup {
504    unset i z
505} -result 11
506test while-5.2 {break tests with computed command names} -body {
507    set a {}
508    set i 1
509    set z break
510    while {$i <= 4} {
511	if {$i == 3} $z
512	set a [concat $a $i]
513        incr i
514    }
515    return $a
516} -cleanup {
517    unset a i z
518} -result {1 2}
519test while-5.3 {break tests, nested loops with computed command names} -body {
520    set msg {}
521    set i 1
522    set z break
523    while {$i <= 4} {
524        set a 1
525	while {$a <= 2} {
526            if {$i>=2 && $a>=2} $z
527            set msg [concat $msg "$i.$a"]
528            incr a
529        }
530        incr i
531    }
532    return $msg
533} -cleanup {
534    unset a i z msg
535} -result {1.1 1.2 2.1 3.1 4.1}
536test while-5.4 {break tests, long command body with computed command names} -body {
537    set a {}
538    set i 1
539    set z break
540    while {$i<6} {
541	if {$i==2} {incr i; continue}
542	if {$i==5} $z
543	if {$i>5} continue
544	if {$i>6 && $tcl_platform(machine)=="xxx"} {
545	    catch {set a $a} msg
546	    catch {incr i 5} msg
547	    catch {incr i -5} msg
548	}
549	if {$i>6 && $tcl_platform(machine)=="xxx"} {
550	    catch {set a $a} msg
551	    catch {incr i 5} msg
552	    catch {incr i -5} msg
553	}
554	if {$i>6 && $tcl_platform(machine)=="xxx"} {
555	    catch {set a $a} msg
556	    catch {incr i 5} msg
557	    catch {incr i -5} msg
558	}
559	if {$i==4} $z
560	if {$i>6 && $tcl_platform(machine)=="xxx"} {
561	    catch {set a $a} msg
562	    catch {incr i 5} msg
563	    catch {incr i -5} msg
564	}
565	if {$i>6 && $tcl_platform(machine)=="xxx"} {
566	    catch {set a $a} msg
567	    catch {incr i 5} msg
568	    catch {incr i -5} msg
569	}
570	set a [concat $a $i]
571        incr i
572    }
573    return $a
574} -cleanup {
575    unset a i z
576} -result {1 3}
577
578# Check "continue" with computed command names.
579
580test while-6.1 {continue and computed command names} -body {
581    set i 0
582    set z continue
583    while 1 {
584        incr i
585        if {$i < 10} $z
586        break
587    }
588    return $i
589} -cleanup {
590    unset i z
591} -result 10
592test while-6.2 {continue tests} -body {
593    set a {}
594    set i 1
595    set z continue
596    while {$i <= 4} {
597        incr i
598	if {$i == 3} $z
599	set a [concat $a $i]
600    }
601    return $a
602} -cleanup {
603    unset a i z
604} -result {2 4 5}
605test while-6.3 {continue tests with computed command names} -body {
606    set a {}
607    set i 1
608    set z continue
609    while {$i <= 4} {
610        incr i
611	if {$i != 2} $z
612	set a [concat $a $i]
613    }
614    return $a
615} -cleanup {
616    unset a i z
617} -result {2}
618test while-6.4 {continue tests, nested loops with computed command names} -body {
619    set msg {}
620    set i 1
621    set z continue
622    while {$i <= 4} {
623        incr i
624        set a 1
625	while {$a <= 2} {
626            incr a
627            if {$i>=3 && $a>=3} $z
628            set msg [concat $msg "$i.$a"]
629        }
630    }
631    return $msg
632} -cleanup {
633    unset a i z msg
634} -result {2.2 2.3 3.2 4.2 5.2}
635test while-6.5 {continue tests, long command body with computed command names} -body {
636    set a {}
637    set i 1
638    set z continue
639    while {$i<6} {
640	if {$i==2} {incr i; continue}
641	if {$i==4} break
642	if {$i>5} $z
643	if {$i>6 && $tcl_platform(machine)=="xxx"} {
644	    catch {set a $a} msg
645	    catch {incr i 5} msg
646	    catch {incr i -5} msg
647	}
648	if {$i>6 && $tcl_platform(machine)=="xxx"} {
649	    catch {set a $a} msg
650	    catch {incr i 5} msg
651	    catch {incr i -5} msg
652	}
653	if {$i>6 && $tcl_platform(machine)=="xxx"} {
654	    catch {set a $a} msg
655	    catch {incr i 5} msg
656	    catch {incr i -5} msg
657	}
658	if {$i>6 && $tcl_platform(machine)=="xxx"} {
659	    catch {set a $a} msg
660	    catch {incr i 5} msg
661	    catch {incr i -5} msg
662	}
663	if {$i>6 && $tcl_platform(machine)=="xxx"} {
664	    catch {set a $a} msg
665	    catch {incr i 5} msg
666	    catch {incr i -5} msg
667	}
668	set a [concat $a $i]
669        incr i
670    }
671    return $a
672} -cleanup {
673    unset a i z
674} -result {1 3}
675
676# Test for incorrect "double evaluation" semantics
677
678test while-7.1 {delayed substitution of body} -body {
679    set i 0
680    while {[incr i] < 10} "
681       set result $i
682    "
683    proc p {} {
684	set i 0
685	while {[incr i] < 10} "
686	    set result $i
687	"
688	return $result
689    }
690    append result [p]
691} -cleanup {
692    unset result i
693} -result {00}
694
695# cleanup
696::tcltest::cleanupTests
697return
698
699# Local Variables:
700# mode: tcl
701# fill-column: 78
702# End:
703