1# Commands covered:  proc, apply, [interp alias], [namespce import]
2#
3# This file contains a collection of tests for the non-recursive executor that
4# avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the
5# actual command functionality is tested in the specific test file.
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	namespace path ::tcl::mathop
30	#
31	# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
32	# cmdFrame level, callFrame level, tosPtr and callback depth
33	#
34	variable last [testnrelevels]
35	proc depthDiff {} {
36	    variable last
37	    set depth [testnrelevels]
38	    set res {}
39	    foreach t $depth l $last {
40		lappend res [expr {$t-$l}]
41	    }
42	    set last $depth
43	    return $res
44	}
45	proc setabs {} {
46	    variable abs [- [lindex [testnrelevels] 0]]
47	}
48
49	variable body0 {
50	    set x [depthDiff]
51	    if {[incr i] > 10} {
52		namespace upvar [namespace qualifiers \
53			[namespace origin depthDiff]] abs abs
54		incr abs [lindex [testnrelevels] 0]
55		return [list [lrange $x 0 3] $abs]
56	    }
57	}
58	proc makebody txt {
59	    variable body0
60	    return "$body0; $txt"
61	}
62	namespace export *
63    }
64    namespace import testnre::*
65}
66
67test nre-0.1 {levels while unwinding} -body {
68    testnreunwind
69} -constraints {
70    testnrelevels
71} -result {0 0 0}
72
73test nre-1.1 {self-recursive procs} -setup {
74    proc a i [makebody {a $i}]
75} -body {
76    setabs
77    a 0
78} -cleanup {
79    rename a {}
80} -constraints {
81    testnrelevels
82} -result {{0 1 1 1} 0}
83test nre-1.2 {self-recursive lambdas} -setup {
84    set a [list i [makebody {apply $::a $i}]]
85} -body {
86    setabs
87    apply $a 0
88} -cleanup {
89    unset a
90} -constraints {
91    testnrelevels
92} -result {{0 1 1 1} 0}
93test nre-1.3 {mutually recursive procs and lambdas} -setup {
94    proc a i {
95	apply $::b [incr i]
96    }
97    set b [list i [makebody {a $i}]]
98} -body {
99    setabs
100    a 0
101} -cleanup {
102    rename a {}
103    unset b
104} -constraints {
105    testnrelevels
106} -result {{0 2 2 2} 0}
107
108#
109# Test that aliases are non-recursive
110#
111
112test nre-2.1 {alias is not recursive} -setup {
113    proc a i [makebody {b $i}]
114    interp alias {} b {} a
115} -body {
116    setabs
117    a 0
118} -cleanup {
119    rename a {}
120    rename b {}
121} -constraints {
122    testnrelevels
123} -result {{0 2 1 1} 0}
124
125#
126# Test that imports are non-recursive
127#
128
129test nre-3.1 {imports are not recursive} -setup {
130    namespace eval foo {
131	setabs
132	namespace export a
133    }
134    proc foo::a i [makebody {::a $i}]
135    namespace import foo::a
136} -body {
137    a 0
138} -cleanup {
139    rename a {}
140    namespace delete ::foo
141} -constraints {
142    testnrelevels
143} -result {{0 2 1 1} 0}
144
145test nre-4.1 {ensembles are not recursive} -setup {
146    proc a i [makebody {b foo $i}]
147    namespace ensemble create \
148	-command b \
149	-map [list foo a]
150} -body {
151    setabs
152    a 0
153} -cleanup {
154    rename a {}
155    rename b {}
156} -constraints {
157    testnrelevels
158} -result {{0 2 1 1} 0}
159
160test nre-4.2 {(compiled) ensembles do not break tailcall} -setup {
161    # Fix Bug d87cb18205
162    proc b {} {
163	tailcall append result first
164    }
165    set map [namespace ensemble configure ::dict -map]
166    dict set map a b
167    namespace ensemble configure ::dict -map $map
168    proc demo {} {
169	dict a
170	append result second
171    }
172} -body {
173    demo
174} -cleanup {
175    rename demo {}
176    namespace ensemble configure ::dict -map [dict remove $map a]
177    unset map
178    rename b {}
179} -result firstsecond
180
181test nre-5.1 {[namespace eval] is not recursive} -setup {
182    namespace eval ::foo {
183	setabs
184    }
185    proc foo::a i [makebody {namespace eval ::foo [list a $i]}]
186} -body {
187    ::foo::a 0
188} -cleanup {
189    namespace delete ::foo
190} -constraints {
191    testnrelevels
192} -result {{0 2 2 2} 0}
193test nre-5.2 {[namespace eval] is not recursive} -setup {
194    namespace eval ::foo {
195	setabs
196    }
197    proc foo::a i [makebody {namespace eval ::foo "set x $i; a $i"}]
198} -body {
199    foo::a 0
200} -cleanup {
201    namespace delete ::foo
202} -constraints {
203    testnrelevels
204} -result {{0 2 2 2} 0}
205
206test nre-6.1 {[uplevel] is not recursive} -setup {
207    proc a i [makebody {uplevel 1 [list a $i]}]
208} -body {
209    setabs
210    a 0
211} -cleanup {
212    rename a {}
213} -constraints {
214    testnrelevels
215} -result {{0 2 2 0} 0}
216test nre-6.2 {[uplevel] is not recursive} -setup {
217    setabs
218    proc a i [makebody {uplevel 1 "set x $i; a $i"}]
219} -body {
220    a 0
221} -cleanup {
222    rename a {}
223} -constraints {
224    testnrelevels
225} -result {{0 2 2 0} 0}
226
227test nre-7.1 {[catch] is not recursive} -setup {
228    setabs
229    proc a i [makebody {uplevel 1 "catch {a $i} msg; set msg"}]
230} -body {
231    a 0
232} -cleanup {
233    rename a {}
234} -constraints {
235    testnrelevels
236} -result {{0 3 3 0} 0}
237test nre-7.2 {[if] is not recursive} -setup {
238    setabs
239    proc a i [makebody {uplevel 1 "if 1 {a $i}"}]
240} -body {
241    a 0
242} -cleanup {
243    rename a {}
244} -constraints {
245    testnrelevels
246} -result {{0 2 2 0} 0}
247test nre-7.3 {[while] is not recursive} -setup {
248    setabs
249    proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}]
250} -body {
251    a 0
252} -cleanup {
253    rename a {}
254} -constraints {
255    testnrelevels
256} -result {{0 2 2 0} 0}
257test nre-7.4 {[for] is not recursive} -setup {
258    setabs
259    proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}]
260} -body {
261    a 0
262} -cleanup {
263    rename a {}
264} -constraints {
265    testnrelevels
266} -result {{0 2 2 0} 0}
267test nre-7.5 {[foreach] is not recursive} -setup {
268    #
269    # Enable once [foreach] is NR-enabled
270    #
271    setabs
272    proc a i [makebody {uplevel 1 "foreach j {1 2 3 4 5 6} {set res \[a $i\]; break}; set res"}]
273} -body {
274    a 0
275} -cleanup {
276    rename a {}
277} -constraints {
278    testnrelevels
279} -result {{0 3 3 0} 0}
280test nre-7.6 {[eval] is not recursive} -setup {
281    proc a i [makebody {eval [list a $i]}]
282} -body {
283    setabs
284    a 0
285} -cleanup {
286    rename a {}
287} -constraints {
288    testnrelevels
289} -result {{0 2 2 1} 0}
290test nre-7.7 {[eval] is not recursive} -setup {
291    proc a i [makebody {eval "a $i"}]
292} -body {
293    setabs
294    a 0
295} -cleanup {
296    rename a {}
297} -constraints {
298    testnrelevels
299} -result {{0 2 2 1} 0}
300test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup {
301    proc foo args {}
302    foo
303    coroutine bar apply {{} {
304	yield
305	proc foo args {return ok}
306	while 1 {
307	    yield [incr i]
308	    foo
309	}
310    }}
311} -body {
312    # if switching to plain eval is not nre aware, this will cause a "cannot
313    # yield" error
314    list [bar] [bar] [bar]
315} -cleanup {
316    rename bar {}
317    rename foo {}
318} -result {1 2 3}
319
320test nre-8.1 {nre and {*}} -body {
321    # force an expansion that grows the evaluation stack, check that nre
322    # adapts the TEBCdataPtr. This crashes on failure.
323    proc inner {} {
324	set long [lrepeat 1000000 1]
325	list {*}$long
326    }
327    proc outer {} inner
328    lrange [outer] 0 2
329} -cleanup {
330    rename inner {}
331    rename outer {}
332} -result {1 1 1}
333test nre-8.2 {nre and {*}, [Bug 2415422]} -body {
334    # force an expansion that grows the evaluation stack, check that nre
335    # adapts the bcFramePtr. This causes an NRE assertion to fail if it is not
336    # done properly.
337    proc nop {} {}
338    proc crash {} {
339	foreach val [list {*}[lrepeat 100000 x]] {
340	    nop
341	}
342    }
343    crash
344} -cleanup {
345    rename nop {}
346    rename crash {}
347}
348
349#
350#  Basic TclOO tests
351#
352
353test nre-oo.1 {really deep calls in oo - direct} -setup {
354    oo::object create foo
355    oo::objdefine foo method bar i [makebody {foo bar $i}]
356} -body {
357    setabs
358    foo bar 0
359} -cleanup {
360    foo destroy
361} -constraints {
362    testnrelevels
363} -result {{0 1 1 1} 0}
364test nre-oo.2 {really deep calls in oo - call via [self]} -setup {
365    oo::object create foo
366    oo::objdefine foo method bar i [makebody {[self] bar $i}]
367} -body {
368    setabs
369    foo bar 0
370} -cleanup {
371    foo destroy
372} -constraints {
373    testnrelevels
374} -result {{0 1 1 1} 0}
375test nre-oo.3 {really deep calls in oo - private calls} -setup {
376    oo::object create foo
377    oo::objdefine foo method bar i [makebody {my bar $i}]
378} -body {
379    setabs
380    foo bar 0
381} -cleanup {
382    foo destroy
383} -constraints {
384    testnrelevels
385} -result {{0 1 1 1} 0}
386test nre-oo.4 {really deep calls in oo - overriding} -setup {
387    oo::class create foo {
388	method bar i [makebody {my bar $i}]
389    }
390    oo::class create boo {
391	superclass foo
392	method bar i [makebody {next $i}]
393    }
394} -body {
395    setabs
396    [boo new] bar 0
397} -cleanup {
398    foo destroy
399} -constraints {
400    testnrelevels
401} -result {{0 1 1 1} 0}
402test nre-oo.5 {really deep calls in oo - forwards} -setup {
403    oo::object create foo
404    set body [makebody {my boo $i}]
405    oo::objdefine foo "
406	method bar i {$body}
407	forward boo ::foo bar
408    "
409} -body {
410    setabs
411    foo bar 0
412} -cleanup {
413    foo destroy
414} -constraints {
415    testnrelevels
416} -result {{0 2 1 1} 0}
417
418#
419# NASTY BUG found by tcllib's interp package
420#
421
422test nre-X.1 {eval in wrong interp} -setup {
423    set i [interp create]
424    $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}}
425} -body {
426    $i eval {
427	set x {namespace children ::}
428	set y [list namespace children ::]
429	namespace delete {*}[filter [{*}$y]]
430	set j [interp create]
431	$j alias filter filter
432	$j eval {namespace delete {*}[filter [namespace children ::]]}
433	namespace eval foo {}
434	list [filter [eval $x]] [filter [eval $y]] [filter [$j eval $x]] [filter [$j eval $y]]
435    }
436} -cleanup {
437    interp delete $i
438} -result {::foo ::foo {} {}}
439
440# cleanup
441::tcltest::cleanupTests
442
443if {[testConstraint testnrelevels]} {
444    namespace forget testnre::*
445    namespace delete testnre
446}
447
448return
449
450# Local Variables:
451# mode: tcl
452# fill-column: 78
453# End:
454