1# Commands covered:  tailcall
2#
3# This file contains a collection of tests for experimental commands that are
4# found in ::tcl::unsupported. The tests will migrate to normal test files
5# if/when the commands find their way into the core.
6#
7# Copyright © 2008 Miguel Sofer.
8#
9# See the file "license.terms" for information on usage and redistribution
10# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
11
12if {"::tcltest" ni [namespace children]} {
13    package require tcltest 2.5
14    namespace import -force ::tcltest::*
15}
16
17::tcltest::loadTestedCommands
18catch [list package require -exact tcl::test [info patchlevel]]
19
20testConstraint testnrelevels [llength [info commands testnrelevels]]
21
22#
23# The tests that risked blowing the C stack on failure have been removed: we
24# can now actually measure using testnrelevels.
25#
26
27if {[testConstraint testnrelevels]} {
28    namespace eval testnre {
29	#
30	# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
31	# cmdFrame level, callFrame level, tosPtr and callback depth
32	#
33	variable last [testnrelevels]
34	proc depthDiff {} {
35	    variable last
36	    set depth [testnrelevels]
37	    set res {}
38	    foreach t $depth l $last {
39		lappend res [expr {$t-$l}]
40	    }
41	    set last $depth
42	    return $res
43	}
44	namespace export *
45    }
46    namespace import testnre::*
47}
48
49proc errorcode options {
50    dict get [dict merge {-errorcode NONE} $options] -errorcode
51}
52
53test tailcall-0.1 {tailcall is constant space} -constraints testnrelevels -setup {
54    proc a i {
55	#
56	# NOTE: there may be a diff in callback depth with the first call
57	# ($i==0) due to the fact that the first is from an eval. Successive
58	# calls should add nothing to any stack depths.
59	#
60	if {$i == 1} {
61	    depthDiff
62	}
63	if {[incr i] > 10} {
64	    return [depthDiff]
65	}
66	tailcall a $i
67    }
68} -body {
69    a 0
70} -cleanup {
71    rename a {}
72} -result {0 0 0 0 0 0}
73
74test tailcall-0.2 {tailcall is constant space} -constraints testnrelevels -setup {
75    set a { i {
76	if {$i == 1} {
77	    depthDiff
78	}
79	if {[incr i] > 10} {
80	    return [depthDiff]
81	}
82	upvar 1 a a
83	tailcall apply $a $i
84    }}
85} -body {
86    apply $a 0
87} -cleanup {
88    unset a
89} -result {0 0 0 0 0 0}
90
91test tailcall-0.3 {tailcall is constant space} -constraints testnrelevels -setup {
92    proc a i {
93	if {$i == 1} {
94	    depthDiff
95	}
96	if {[incr i] > 10} {
97	    return [depthDiff]
98	}
99	tailcall b $i
100    }
101    interp alias {} b {} a
102} -body {
103    b 0
104} -cleanup {
105    rename a {}
106    rename b {}
107} -result {0 0 0 0 0 0}
108
109test tailcall-0.4 {tailcall is constant space} -constraints testnrelevels -setup {
110    namespace eval ::ns {
111	namespace export *
112    }
113    proc ::ns::a i {
114	if {$i == 1} {
115	    depthDiff
116	}
117	if {[incr i] > 10} {
118	    return [depthDiff]
119	}
120	set b [uplevel 1 [list namespace which b]]
121	tailcall $b $i
122    }
123    namespace import ::ns::a
124    rename a b
125} -body {
126    b 0
127} -cleanup {
128    rename b {}
129    namespace delete ::ns
130} -result {0 0 0 0 0 0}
131
132test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup {
133    proc b i {
134	if {$i == 1} {
135	    depthDiff
136	}
137	if {[incr i] > 10} {
138	    return [depthDiff]
139	}
140	tailcall a b $i
141    }
142    namespace ensemble create -command a -map {b b}
143} -body {
144    a b 0
145} -cleanup {
146    rename a {}
147    rename b {}
148} -result {0 0 0 0 0 0}
149
150test tailcall-0.5.1 {tailcall is constant space} -constraints testnrelevels -setup {
151    #
152    # This test is related to [bug d87cb182053fd79b3]: the fix to that bug was
153    # to remove a call to TclSkipTailcall, which caused a violation of the
154    # constant-space property of tailcall in that particular
155    # configuration. This test was added to detect that, and insure that the
156    # problem is fixed.
157    #
158
159    proc b i {
160	if {$i == 1} {
161	    depthDiff
162	}
163	if {[incr i] > 10} {
164	    return [depthDiff]
165	}
166	tailcall dict b $i
167    }
168    set map0 [namespace ensemble configure dict -map]
169    set map $map0
170    dict set map b b
171    namespace ensemble configure dict -map $map
172} -body {
173    dict b 0
174} -cleanup {
175    rename b {}
176    namespace ensemble configure dict -map $map0
177    unset map map0
178} -result {0 0 0 0 0 0}
179
180test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels knownBug} -setup {
181    #
182    # This test fails because ns-unknown is not NR-enabled
183    #
184    proc c i {
185	if {$i == 1} {
186	    depthDiff
187	}
188	if {[incr i] > 10} {
189	    return [depthDiff]
190	}
191	tailcall a b $i
192    }
193    proc d {ens sub args} {
194	return [list $ens c]
195    }
196    namespace ensemble create -command a -unknown d
197} -body {
198    a b 0
199} -cleanup {
200    rename a {}
201    rename c {}
202    rename d {}
203} -result {0 0 0 0 0 0}
204
205test tailcall-0.7 {tailcall is constant space} -constraints testnrelevels -setup {
206    catch {rename foo {}}
207    oo::class create foo {
208	method b i {
209	    if {$i == 1} {
210		depthDiff
211	    }
212	    if {[incr i] > 10} {
213		return [depthDiff]
214	    }
215	    tailcall [self] b $i
216	}
217    }
218} -body {
219    foo create a
220    a b 0
221} -cleanup {
222    rename a {}
223    rename foo {}
224} -result {0 0 0 0 0 0}
225
226test tailcall-1 {tailcall} -body {
227    namespace eval a {
228	variable x *::a
229	proc xset {} {
230	    set tmp {}
231	    set ns {[namespace current]}
232	    set level [info level]
233	    for {set i 0} {$i <= [info level]} {incr i} {
234		uplevel #$i "set x $i$ns"
235		lappend tmp "$i [info level $i]"
236	    }
237	    lrange $tmp 1 end
238	}
239	proc foo {} {tailcall xset; set x noreach}
240    }
241    namespace eval b {
242	variable x *::b
243	proc xset args {error b::xset}
244	proc moo {} {set x 0; variable y [::a::foo]; set x}
245    }
246    variable x *::
247    proc xset args {error ::xset}
248    list [::b::moo] | $x $a::x $b::x | $::b::y
249} -cleanup {
250    unset x
251    rename xset {}
252    namespace delete a b
253} -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}}
254
255
256test tailcall-2 {tailcall in non-proc} -body {
257    namespace eval a [list tailcall set x 1]
258} -match glob -result *tailcall* -returnCodes error
259
260test tailcall-3 {tailcall falls off tebc} -body {
261    unset -nocomplain x
262    proc foo {} {tailcall set x 1}
263    list [catch foo msg] $msg [set x]
264} -cleanup {
265    rename foo {}
266    unset x
267} -result {0 1 1}
268
269test tailcall-4 {tailcall falls off tebc} -body {
270    set x 2
271    proc foo {} {tailcall set x 1}
272    foo
273    set x
274} -cleanup {
275    rename foo {}
276    unset x
277} -result 1
278
279test tailcall-5 {tailcall falls off tebc} -body {
280    set x 2
281    namespace eval bar {
282	variable x 3
283	proc foo {} {tailcall set x 1}
284    }
285    bar::foo
286    list $x $bar::x
287} -cleanup {
288    unset x
289    namespace delete bar
290} -result {1 3}
291
292test tailcall-6 {tailcall does remove callframes} -body {
293    proc foo {} {info level}
294    proc moo {} {tailcall foo}
295    proc boo {} {expr {[moo] - [info level]}}
296    boo
297} -cleanup {
298    rename foo {}
299    rename moo {}
300    rename boo {}
301} -result 1
302
303test tailcall-7 {tailcall does return} -setup {
304    namespace eval ::foo {
305	variable res {}
306	proc a {} {
307	    variable res
308	    append res a
309	    tailcall set x 1
310	    append res a
311	}
312	proc b {} {
313	    variable res
314	    append res b
315	    a
316	    append res b
317	}
318	proc c {} {
319	    variable res
320	    append res c
321	    b
322	    append res c
323	}
324    }
325} -body {
326    namespace eval ::foo c
327} -cleanup {
328    namespace delete ::foo
329} -result cbabc
330
331test tailcall-8 {tailcall tailcall} -setup {
332    namespace eval ::foo {
333	variable res {}
334	proc a {} {
335	    variable res
336	    append res a
337	    tailcall tailcall set x 1
338	    append res a
339	}
340	proc b {} {
341	    variable res
342	    append res b
343	    a
344	    append res b
345	}
346	proc c {} {
347	    variable res
348	    append res c
349	    b
350	    append res c
351	}
352    }
353} -body {
354    namespace eval ::foo c
355} -cleanup {
356    namespace delete ::foo
357} -result cbac
358
359test tailcall-9 {tailcall factorial} -setup {
360    proc fact {n {b 1}} {
361	if {$n == 1} {
362	    return $b
363	}
364	tailcall fact [expr {$n-1}] [expr {$n*$b}]
365    }
366} -body {
367    list [fact 1] [fact 5] [fact 10] [fact 15]
368} -cleanup {
369    rename fact {}
370} -result {1 120 3628800 1307674368000}
371
372test tailcall-10a {tailcall and eval} -setup {
373    set ::x 0
374    proc a {} {
375	eval [list tailcall lappend ::x 2]
376	set ::x 1
377    }
378} -body {
379    list [a] $::x
380} -cleanup {
381    unset -nocomplain ::x
382} -result {{0 2} {0 2}}
383
384test tailcall-10b {tailcall and eval} -setup {
385    set ::x 0
386    proc a {} {
387	eval {tailcall lappend ::x 2}
388	set ::x 1
389    }
390} -body {
391    list [a] $::x
392} -cleanup {
393    unset -nocomplain ::x
394} -result {{0 2} {0 2}}
395
396test tailcall-11a {tailcall and uplevel} -setup {
397    proc a {} {
398	uplevel 1 [list tailcall set ::x 2]
399	set ::x 1
400    }
401} -body {
402    list [a] $::x
403} -cleanup {
404    unset -nocomplain ::x
405} -match glob -result *tailcall* -returnCodes error
406
407test tailcall-11b {tailcall and uplevel} -setup {
408    proc a {} {
409	uplevel 1 {tailcall set ::x 2}
410	set ::x 1
411    }
412} -body {
413    list [a] $::x
414} -cleanup {
415    unset -nocomplain ::x
416} -match glob -result *tailcall* -returnCodes error
417
418test tailcall-11c {tailcall and uplevel} -setup {
419    proc a {} {
420	uplevel 1 {tailcall lappend ::x 2}
421	set ::x 1
422    }
423    proc b {} {set ::x 0; a; lappend ::x 3}
424} -body {
425    list [b] $::x
426} -cleanup {
427    rename a {}
428    rename b {}
429    unset -nocomplain ::x
430} -result {{0 3 2} {0 3 2}}
431
432test tailcall-12.1 {[Bug 2649975]} -setup {
433    proc dump {{text {}}} {
434	set text [uplevel 1 [list subst $text]]
435	set l [expr {[info level] -1}]
436	if {$text eq {}} {
437	    set text [info level $l]
438	}
439	puts "$l: $text"
440    }
441    # proc dump args {}
442    proc bravo {} {
443	upvar 1 v w
444	dump {inside bravo, v -> $w}
445	set v "procedure bravo"
446	#uplevel 1 [list delta ::betty]
447	uplevel 1 {delta ::betty}
448	return $::resolution
449    }
450    proc delta name {
451	upvar 1 v w
452	dump {inside delta, v -> $w}
453	set v "procedure delta"
454	tailcall foxtrot
455    }
456    proc foxtrot {} {
457	upvar 1 v w
458	dump {inside foxtrot, v -> $w}
459	global resolution
460	set ::resolution $w
461    }
462    set v "global level"
463} -body {
464    set result [bravo]
465    if {$result ne $v} {
466	puts "v should have been found at $v but was found in $result"
467    }
468} -cleanup {
469    unset v
470    rename dump {}
471    rename bravo {}
472    rename delta {}
473    rename foxtrot {}
474} -output {1: inside bravo, v -> global level
4751: inside delta, v -> global level
4761: inside foxtrot, v -> global level
477}
478
479test tailcall-12.2 {[Bug 2649975]} -setup {
480    proc dump {{text {}}} {
481	set text [uplevel 1 [list subst $text]]
482	set l [expr {[info level] -1}]
483	if {$text eq {}} {
484	    set text [info level $l]
485	}
486	puts "$l: $text"
487    }
488    # proc dump args {}
489    set v "global level"
490    oo::class create foo { # like connection
491	method alpha {} {  # like connections 'tables' method
492	    dump
493	    upvar 1 v w
494	    dump {inside foo's alpha, v resolves to $w}
495	    set v "foo's method alpha"
496	    dump {foo's alpha is calling [self] bravo - v should resolve at global level}
497	    set result [uplevel 1 [list [self] bravo]]
498	    dump {exiting from foo's alpha}
499	    return $result
500	}
501	method bravo {} {  # like connections 'foreach' method
502	    dump
503	    upvar 1 v w
504	    dump {inside foo's bravo, v resolves to $w}
505	    set v "foo's method bravo"
506	    dump {foo's bravo is calling charlie to create barney}
507	    set barney [my charlie ::barney]
508	    dump {foo's bravo is calling bravo on $barney}
509	    dump {v should resolve at global scope there}
510	    set result [uplevel 1 [list $barney bravo]]
511	    dump {exiting from foo's bravo}
512	    return $result
513	}
514	method charlie {name} {  # like tdbc prepare
515	    dump
516	    set v "foo's method charlie"
517	    dump {tailcalling bar's constructor}
518	    tailcall ::bar create $name
519	}
520    }
521    oo::class create bar { # like statement
522	method  bravo {} {   # like statement foreach method
523	    dump
524	    upvar 1 v w
525	    dump {inside bar's bravo, v is resolving to $w}
526	    set v "bar's method bravo"
527	    dump {calling delta to construct betty - v should resolve global there}
528	    uplevel 1 [list [self] delta ::betty]
529	    dump {exiting from bar's bravo}
530	    return [::betty whathappened]
531	}
532	method delta {name} {    # like statement execute method
533	    dump
534	    upvar 1 v w
535	    dump {inside bar's delta, v is resolving to $w}
536	    set v "bar's method delta"
537	    dump {tailcalling to construct $name as instance of grill}
538	    dump {v should resolve at global level in grill's constructor}
539	    dump {grill's constructor should run at level [info level]}
540	    tailcall grill create $name
541	}
542    }
543    oo::class create grill {
544	variable resolution
545	constructor {} {
546	    dump
547	    upvar 1 v w
548	    dump "in grill's constructor, v resolves to $w"
549	    set resolution $w
550	}
551	method whathappened {} {
552	    return $resolution
553	}
554    }
555    foo create fred
556} -body {
557    set result [fred alpha]
558    if {$result ne "global level"} {
559	puts "v should have been found at global level but was found in $result"
560    }
561} -cleanup {
562    unset result
563    rename fred {}
564    rename dump {}
565    rename foo {}
566    rename bar {}
567    rename grill {}
568} -output {1: fred alpha
5691: inside foo's alpha, v resolves to global level
5701: foo's alpha is calling ::fred bravo - v should resolve at global level
5711: ::fred bravo
5721: inside foo's bravo, v resolves to global level
5731: foo's bravo is calling charlie to create barney
5742: my charlie ::barney
5752: tailcalling bar's constructor
5761: foo's bravo is calling bravo on ::barney
5771: v should resolve at global scope there
5781: ::barney bravo
5791: inside bar's bravo, v is resolving to global level
5801: calling delta to construct betty - v should resolve global there
5811: ::barney delta ::betty
5821: inside bar's delta, v is resolving to global level
5831: tailcalling to construct ::betty as instance of grill
5841: v should resolve at global level in grill's constructor
5851: grill's constructor should run at level 1
5861: grill create ::betty
5871: in grill's constructor, v resolves to global level
5881: exiting from bar's bravo
5891: exiting from foo's bravo
5901: exiting from foo's alpha
591}
592
593test tailcall-12.3a0 {[Bug 2695587]} -body {
594    apply {{} {
595	catch [list tailcall foo]
596    }}
597} -returnCodes 1 -result {invalid command name "foo"}
598
599test tailcall-12.3a1 {[Bug 2695587]} -body {
600    apply {{} {
601	catch [list tailcall foo]
602	tailcall
603    }}
604} -result {}
605
606test tailcall-12.3a2 {[Bug 2695587]} -body {
607    apply {{} {
608	catch [list tailcall foo]
609	tailcall moo
610    }}
611} -returnCodes 1 -result {invalid command name "moo"}
612
613test tailcall-12.3a3 {[Bug 2695587]} -body {
614    set x 0
615    apply {{} {
616	catch [list tailcall foo]
617	tailcall lappend x 1
618    }}
619    set x
620} -cleanup {
621    unset x
622} -result {0 1}
623
624test tailcall-12.3b0 {[Bug 2695587]} -body {
625    apply {{} {
626	set catch catch
627	$catch [list tailcall foo]
628    }}
629} -returnCodes 1 -result {invalid command name "foo"}
630
631test tailcall-12.3b1 {[Bug 2695587]} -body {
632    apply {{} {
633	set catch catch
634	$catch [list tailcall foo]
635	tailcall
636    }}
637} -result {}
638
639test tailcall-12.3b2 {[Bug 2695587]} -body {
640    apply {{} {
641	set catch catch
642	$catch [list tailcall foo]
643	tailcall moo
644    }}
645} -returnCodes 1 -result {invalid command name "moo"}
646
647test tailcall-12.3b3 {[Bug 2695587]} -body {
648    set x 0
649    apply {{} {
650	set catch catch
651	$catch [list tailcall foo]
652	tailcall lappend x 1
653    }}
654    set x
655} -cleanup {
656    unset x
657} -result {0 1}
658
659# MORE VARIANTS MISSING: bc'ed caught script vs (bc'ed, not-bc'ed)
660# catch. Actually superfluous now, as tailcall just returns TCL_RETURN so that
661# standard catch behaviour is required.
662
663test tailcall-13.1 {directly tailcalling the tailcall command is ok} {
664    list [catch {
665	apply {{} {
666	    apply {{} {
667		tailcall tailcall subst ok
668		subst b
669	    }}
670	    subst c
671	}}
672    } msg opt] $msg [errorcode $opt]
673} {0 ok NONE}
674test tailcall-13.2 {indirectly tailcalling the tailcall command is ok} {
675    list [catch {
676	apply {{} {
677	    apply {{} {
678		tailcall eval tailcall subst ok
679		subst b
680	    }}
681	    subst c
682	}}
683    } msg opt] $msg [errorcode $opt]
684} {0 ok NONE}
685
686if {[testConstraint testnrelevels]} {
687    namespace forget testnre::*
688    namespace delete testnre
689}
690
691test tailcall-14.1 {in a deleted namespace} -body {
692    namespace eval ns {
693	proc p args {
694	    tailcall [namespace current] $args
695	}
696	namespace delete [namespace current]
697	p
698    }
699} -returnCodes 1 -result {namespace "::ns" not found}
700
701test tailcall-14.1-bc {{in a deleted namespace} {byte compiled}} -body {
702    namespace eval ns {
703	proc p args {
704	    tailcall [namespace current] {*}$args
705	}
706	namespace delete [namespace current]
707	p
708    }
709} -returnCodes 1 -result {namespace "::ns" not found}
710
711# cleanup
712::tcltest::cleanupTests
713
714# Local Variables:
715# mode: tcl
716# End:
717