1# This file contains a collection of tests for Tcl's built-in object system.
2# Sourcing this file into Tcl runs the tests and generates output for errors.
3# No output means no errors were found.
4#
5# Copyright © 2006-2011 Donal K. Fellows
6#
7# See the file "license.terms" for information on usage and redistribution of
8# this file, and for a DISCLAIMER OF ALL WARRANTIES.
9
10package require tcl::oo 1.0.3
11if {"::tcltest" ni [namespace children]} {
12    package require tcltest 2.5
13    namespace import -force ::tcltest::*
14}
15
16testConstraint memory [llength [info commands memory]]
17if {[testConstraint memory]} {
18    proc getbytes {} {
19	set lines [split [memory info] \n]
20	return [lindex $lines 3 3]
21    }
22    proc leaktest {script {iterations 3}} {
23	set end [getbytes]
24	for {set i 0} {$i < $iterations} {incr i} {
25	    uplevel 1 $script
26	    set tmp $end
27	    set end [getbytes]
28	}
29	return [expr {$end - $tmp}]
30    }
31}
32
33test oo-nextto-1.1 {basic nextto functionality} -setup {
34    oo::class create root
35} -body {
36    oo::class create A {
37	superclass root
38	method x args {
39	    lappend ::result ==A== $args
40	}
41    }
42    oo::class create B {
43	superclass A
44	method x args {
45	    lappend ::result ==B== $args
46	    nextto A B -> A {*}$args
47	}
48    }
49    oo::class create C {
50	superclass A
51	method x args {
52	    lappend ::result ==C== $args
53	    nextto A C -> A {*}$args
54	}
55    }
56    oo::class create D {
57	superclass B C
58	method x args {
59	    lappend ::result ==D== $args
60	    next foo
61	    nextto C bar
62	}
63    }
64    set ::result {}
65    [D new] x
66    return $::result
67} -cleanup {
68    root destroy
69} -result {==D== {} ==B== foo ==A== {B -> A foo} ==C== bar ==A== {C -> A bar}}
70test oo-nextto-1.2 {basic nextto functionality} -setup {
71    oo::class create root
72} -body {
73    oo::class create A {
74	superclass root
75	method x args {
76	    lappend ::result ==A== $args
77	}
78    }
79    oo::class create B {
80	superclass A
81	method x args {
82	    lappend ::result ==B== $args
83	    nextto A B -> A {*}$args
84	}
85    }
86    oo::class create C {
87	superclass A
88	method x args {
89	    lappend ::result ==C== $args
90	    nextto A C -> A {*}$args
91	}
92    }
93    oo::class create D {
94	superclass B C
95	method x args {
96	    lappend ::result ==D== $args
97	    nextto B foo {*}$args
98	    nextto C bar {*}$args
99	}
100    }
101    set ::result {}
102    [D new] x 123
103    return $::result
104} -cleanup {
105    root destroy
106} -result {==D== 123 ==B== {foo 123} ==A== {B -> A foo 123} ==C== {bar 123} ==A== {C -> A bar 123}}
107test oo-nextto-1.3 {basic nextto functionality: constructors} -setup {
108    oo::class create root
109} -body {
110    oo::class create A {
111	superclass root
112	variable result
113	constructor {a c} {
114	    lappend result ==A== a=$a,c=$c
115	}
116    }
117    oo::class create B {
118	superclass root
119	variable result
120	constructor {b} {
121	    lappend result ==B== b=$b
122	}
123    }
124    oo::class create C {
125	superclass A B
126	variable result
127	constructor {p q r} {
128	    lappend result ==C== p=$p,q=$q,r=$r
129	    # Route arguments to superclasses, in non-trival pattern
130	    nextto B $q
131	    nextto A $p $r
132	}
133	method result {} {return $result}
134    }
135    [C new x y z] result
136} -cleanup {
137    root destroy
138} -result {==C== p=x,q=y,r=z ==B== b=y ==A== a=x,c=z}
139test oo-nextto-1.4 {basic nextto functionality: destructors} -setup {
140    oo::class create root {destructor return}
141} -body {
142    oo::class create A {
143	superclass root
144	destructor {
145	    lappend ::result ==A==
146	    next
147	}
148    }
149    oo::class create B {
150	superclass root
151	destructor {
152	    lappend ::result ==B==
153	    next
154	}
155    }
156    oo::class create C {
157	superclass A B
158	destructor {
159	    lappend ::result ==C==
160	    lappend ::result |
161	    nextto B
162	    lappend ::result |
163	    nextto A
164	    lappend ::result |
165	    next
166	}
167    }
168    set ::result ""
169    [C new] destroy
170    return $::result
171} -cleanup {
172    root destroy
173} -result {==C== | ==B== | ==A== ==B== | ==A== ==B==}
174
175test oo-nextto-2.1 {errors in nextto} -setup {
176    oo::class create root
177} -body {
178    oo::class create A {
179	superclass root
180	method x y {error $y}
181    }
182    oo::class create B {
183	superclass A
184	method x y {nextto A $y}
185    }
186    [B new] x boom
187} -cleanup {
188    root destroy
189} -result boom -returnCodes error
190test oo-nextto-2.2 {errors in nextto} -setup {
191    oo::class create root
192} -body {
193    oo::class create A {
194	superclass root
195	method x y {error $y}
196    }
197    oo::class create B {
198	superclass root
199	method x y {nextto A $y}
200    }
201    [B new] x boom
202} -returnCodes error -cleanup {
203    root destroy
204} -result {method has no non-filter implementation by "A"}
205test oo-nextto-2.3 {errors in nextto} -setup {
206    oo::class create root
207} -body {
208    oo::class create A {
209	superclass root
210	method x y {nextto $y}
211    }
212    oo::class create B {
213	superclass A
214	method x y {nextto A $y}
215    }
216    [B new] x B
217} -returnCodes error -cleanup {
218    root destroy
219} -result {method implementation by "B" not reachable from here}
220test oo-nextto-2.4 {errors in nextto} -setup {
221    oo::class create root
222} -body {
223    oo::class create A {
224	superclass root
225	method x y {nextto $y}
226    }
227    oo::class create B {
228	superclass A
229	method x y {nextto}
230    }
231    [B new] x B
232} -returnCodes error -cleanup {
233    root destroy
234} -result {wrong # args: should be "nextto class ?arg...?"}
235test oo-nextto-2.5 {errors in nextto} -setup {
236    oo::class create root
237} -body {
238    oo::class create A {
239	superclass root
240	method x y {nextto $y}
241    }
242    oo::class create B {
243	superclass A
244	method x y {nextto $y $y $y}
245    }
246    [B new] x A
247} -cleanup {
248    root destroy
249} -result {wrong # args: should be "nextto A y"} -returnCodes error
250test oo-nextto-2.6 {errors in nextto} -setup {
251    oo::class create root
252} -body {
253    oo::class create A {
254	superclass root
255	method x y {nextto $y}
256    }
257    oo::class create B {
258	superclass A
259	method x y {nextto $y $y $y}
260    }
261    [B new] x [root create notAClass]
262} -cleanup {
263    root destroy
264} -result {"::notAClass" is not a class} -returnCodes error
265test oo-nextto-2.7 {errors in nextto} -setup {
266    oo::class create root
267} -body {
268    oo::class create A {
269	superclass root
270	method x y {nextto $y}
271    }
272    oo::class create B {
273	superclass A
274	filter Y
275	method Y args {next {*}$args}
276    }
277    oo::class create C {
278	superclass B
279	method x y {nextto $y $y $y}
280    }
281    [C new] x B
282} -returnCodes error -cleanup {
283    root destroy
284} -result {method has no non-filter implementation by "B"}
285
286test oo-call-1.1 {object call introspection} -setup {
287    oo::class create root
288} -body {
289    oo::class create ::A {
290	superclass root
291	method x {} {}
292    }
293    A create y
294    info object call y x
295} -cleanup {
296    root destroy
297} -result {{method x ::A method}}
298test oo-call-1.2 {object call introspection} -setup {
299    oo::class create root
300} -body {
301    oo::class create ::A {
302	superclass root
303	method x {} {}
304    }
305    oo::class create ::B {
306	superclass A
307	method x {} {}
308    }
309    B create y
310    info object call y x
311} -cleanup {
312    root destroy
313} -result {{method x ::B method} {method x ::A method}}
314test oo-call-1.3 {object call introspection} -setup {
315    oo::class create root
316} -body {
317    oo::class create ::A {
318	superclass root
319	method x {} {}
320    }
321    A create y
322    oo::objdefine y method x {} {}
323    info object call y x
324} -cleanup {
325    root destroy
326} -result {{method x object method} {method x ::A method}}
327test oo-call-1.4 {object object call introspection - unknown} -setup {
328    oo::class create root
329} -body {
330    oo::class create ::A {
331	superclass root
332	method x {} {}
333    }
334    A create y
335    info object call y z
336} -cleanup {
337    root destroy
338} -result {{unknown unknown ::oo::object {core method: "unknown"}}}
339test oo-call-1.5 {object call introspection - filters} -setup {
340    oo::class create root
341} -body {
342    oo::class create ::A {
343	superclass root
344	method x {} {}
345	method y {} {}
346	filter y
347    }
348    A create y
349    info object call y x
350} -cleanup {
351    root destroy
352} -result {{filter y ::A method} {method x ::A method}}
353test oo-call-1.6 {object call introspection - filters} -setup {
354    oo::class create root
355} -body {
356    oo::class create ::A {
357	superclass root
358	method x {} {}
359	method y {} {}
360	filter y
361    }
362    oo::class create ::B {
363	superclass A
364	method x {} {}
365    }
366    B create y
367    info object call y x
368} -cleanup {
369    root destroy
370} -result {{filter y ::A method} {method x ::B method} {method x ::A method}}
371test oo-call-1.7 {object call introspection - filters} -setup {
372    oo::class create root
373} -body {
374    oo::class create ::A {
375	superclass root
376	method x {} {}
377	method y {} {}
378	filter y
379    }
380    oo::class create ::B {
381	superclass A
382	method x {} {}
383	method y {} {}
384    }
385    B create y
386    info object call y x
387} -cleanup {
388    root destroy
389} -result {{filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}}
390test oo-call-1.8 {object call introspection - filters} -setup {
391    oo::class create root
392} -body {
393    oo::class create ::A {
394	superclass root
395	method x {} {}
396	method y {} {}
397	filter y
398    }
399    oo::class create ::B {
400	superclass A
401	method x {} {}
402	method y {} {}
403	method z {} {}
404	filter z
405    }
406    B create y
407    info object call y x
408} -cleanup {
409    root destroy
410} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}}
411test oo-call-1.9 {object call introspection - filters} -setup {
412    oo::class create root
413} -body {
414    oo::class create ::A {
415	superclass root
416	method x {} {}
417	method y {} {}
418	filter y
419    }
420    oo::class create ::B {
421	superclass A
422	method x {} {}
423	method y {} {}
424	method z {} {}
425	filter z
426    }
427    B create y
428    info object call y y
429} -cleanup {
430    root destroy
431} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method y ::B method} {method y ::A method}}
432test oo-call-1.10 {object call introspection - filters + unknown} -setup {
433    oo::class create root
434} -body {
435    oo::class create ::A {
436	superclass root
437	method y {} {}
438	filter y
439    }
440    oo::class create ::B {
441	superclass A
442	method y {} {}
443	method unknown {} {}
444    }
445    B create y
446    info object call y x
447} -cleanup {
448    root destroy
449} -result {{filter y ::B method} {filter y ::A method} {unknown unknown ::B method} {unknown unknown ::oo::object {core method: "unknown"}}}
450test oo-call-1.11 {object call introspection - filters + unknown} -setup {
451    oo::class create root
452} -body {
453    oo::class create ::A {
454	superclass root
455	method y {} {}
456	filter y
457    }
458    A create y
459    oo::objdefine y method unknown {} {}
460    info object call y x
461} -cleanup {
462    root destroy
463} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}}
464test oo-call-1.12 {object call introspection - filters + unknown} -setup {
465    oo::class create root
466} -body {
467    oo::class create ::A {
468	superclass root
469	method y {} {}
470    }
471    A create y
472    oo::objdefine y {
473	method unknown {} {}
474	filter y
475    }
476    info object call y x
477} -cleanup {
478    root destroy
479} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}}
480test oo-call-1.13 {object call introspection - filters + unknown} -setup {
481    oo::class create root
482} -body {
483    oo::class create ::A {
484	superclass root
485	method y {} {}
486    }
487    A create y
488    oo::objdefine y {
489	method unknown {} {}
490	method x {} {}
491	filter y
492    }
493    info object call y x
494} -cleanup {
495    root destroy
496} -result {{filter y ::A method} {method x object method}}
497test oo-call-1.14 {object call introspection - errors} -body {
498    info object call
499} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
500test oo-call-1.15 {object call introspection - errors} -body {
501    info object call a
502} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
503test oo-call-1.16 {object call introspection - errors} -body {
504    info object call a b c
505} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
506test oo-call-1.17 {object call introspection - errors} -body {
507    info object call notanobject x
508} -returnCodes error -result {notanobject does not refer to an object}
509test oo-call-1.18 {object call introspection - memory leaks} -body {
510    leaktest {
511	info object call oo::object destroy
512    }
513} -constraints memory -result 0
514test oo-call-1.19 {object call introspection - memory leaks} -setup {
515    oo::class create leaktester { method foo {} {dummy} }
516} -body {
517    leaktest {
518	set lt [leaktester new]
519	oo::objdefine $lt method foobar {} {dummy}
520	list [info object call $lt destroy] \
521	    [info object call $lt foo] \
522	    [info object call $lt bar] \
523	    [info object call $lt foobar] \
524	    [$lt destroy]
525    }
526} -cleanup {
527    leaktester destroy
528} -constraints memory -result 0
529test oo-call-1.20 {object call introspection - complex case} -setup {
530    oo::class create root
531} -body {
532    oo::class create ::A {
533	superclass root
534	method x {} {}
535    }
536    oo::class create ::B {
537	superclass A
538	method x {} {}
539    }
540    oo::class create ::C {
541	superclass root
542	method x {} {}
543	mixin B
544    }
545    oo::class create ::D {
546	superclass C
547	method x {} {}
548    }
549    oo::class create ::E {
550	superclass root
551	method x {} {}
552    }
553    oo::class create ::F {
554	superclass E
555	method x {} {}
556    }
557    oo::class create ::G {
558	superclass root
559	method x {} {}
560    }
561    oo::class create ::H {
562	superclass G
563	method x {} {}
564    }
565    oo::define F mixin H
566    F create y
567    oo::objdefine y {
568	method x {} {}
569	mixin D
570    }
571    info object call y x
572} -cleanup {
573    root destroy
574} -result {{method x ::D method} {method x ::B method} {method x ::A method} {method x ::C method} {method x ::H method} {method x ::G method} {method x object method} {method x ::F method} {method x ::E method}}
575test oo-call-1.21 {object call introspection - complex case} -setup {
576    oo::class create root
577} -body {
578    oo::class create ::A {
579	superclass root
580	method y {} {}
581	filter y
582    }
583    oo::class create ::B {
584	superclass A
585	method y {} {}
586    }
587    oo::class create ::C {
588	superclass root
589	method x {} {}
590	mixin B
591    }
592    oo::class create ::D {
593	superclass C
594	filter x
595    }
596    oo::class create ::E {
597	superclass root
598	method y {} {}
599	method x {} {}
600    }
601    oo::class create ::F {
602	superclass E
603	method z {} {}
604	method q {} {}
605    }
606    F create y
607    oo::objdefine y {
608	method unknown {} {}
609	mixin D
610	filter q
611    }
612    info object call y z
613} -cleanup {
614    root destroy
615} -result {{filter x ::C method} {filter x ::E method} {filter y ::B method} {filter y ::A method} {filter y ::E method} {filter q ::F method} {method z ::F method}}
616
617test oo-call-2.1 {class call introspection} -setup {
618    oo::class create root
619} -body {
620    oo::class create ::A {
621	superclass root
622	method x {} {}
623    }
624    info class call A x
625} -cleanup {
626    root destroy
627} -result {{method x ::A method}}
628test oo-call-2.2 {class call introspection} -setup {
629    oo::class create root
630} -body {
631    oo::class create ::A {
632	superclass root
633	method x {} {}
634    }
635    oo::class create ::B {
636	superclass A
637	method x {} {}
638    }
639    list [info class call A x] [info class call B x]
640} -cleanup {
641    root destroy
642} -result {{{method x ::A method}} {{method x ::B method} {method x ::A method}}}
643test oo-call-2.3 {class call introspection} -setup {
644    oo::class create root
645} -body {
646    oo::class create ::A {
647	superclass root
648	method x {} {}
649    }
650    oo::class create ::B {
651	superclass A
652	method x {} {}
653    }
654    oo::class create ::C {
655	superclass A
656	method x {} {}
657    }
658    oo::class create ::D {
659	superclass C B
660	method x {} {}
661    }
662    info class call D x
663} -cleanup {
664    root destroy
665} -result {{method x ::D method} {method x ::C method} {method x ::B method} {method x ::A method}}
666test oo-call-2.4 {class call introspection - mixin} -setup {
667    oo::class create root
668} -body {
669    oo::class create ::A {
670	superclass root
671	method x {} {}
672    }
673    oo::class create ::B {
674	superclass A
675	method x {} {}
676    }
677    oo::class create ::C {
678	superclass A
679	method x {} {}
680    }
681    oo::class create ::D {
682	superclass C
683	mixin B
684	method x {} {}
685    }
686    info class call D x
687} -cleanup {
688    root destroy
689} -result {{method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}}
690test oo-call-2.5 {class call introspection - mixin + filter} -setup {
691    oo::class create root
692} -body {
693    oo::class create ::A {
694	superclass root
695	method x {} {}
696    }
697    oo::class create ::B {
698	superclass A
699	method x {} {}
700	method y {} {}
701	filter y
702    }
703    oo::class create ::C {
704	superclass A
705	method x {} {}
706	method y {} {}
707    }
708    oo::class create ::D {
709	superclass C
710	mixin B
711	method x {} {}
712    }
713    info class call D x
714} -cleanup {
715    root destroy
716} -result {{filter y ::B method} {filter y ::C method} {method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}}
717test oo-call-2.6 {class call introspection - mixin + filter + unknown} -setup {
718    oo::class create root
719} -body {
720    oo::class create ::A {
721	superclass root
722	method x {} {}
723	method unknown {} {}
724    }
725    oo::class create ::B {
726	superclass A
727	method x {} {}
728	method y {} {}
729	filter y
730    }
731    oo::class create ::C {
732	superclass A
733	method x {} {}
734	method y {} {}
735    }
736    oo::class create ::D {
737	superclass C
738	mixin B
739	method x {} {}
740	method unknown {} {}
741    }
742    info class call D z
743} -cleanup {
744    root destroy
745} -result {{filter y ::B method} {filter y ::C method} {unknown unknown ::D method} {unknown unknown ::A method} {unknown unknown ::oo::object {core method: "unknown"}}}
746test oo-call-2.7 {class call introspection - mixin + filter + unknown} -setup {
747    oo::class create root
748} -body {
749    oo::class create ::A {
750	superclass root
751	method x {} {}
752    }
753    oo::class create ::B {
754	superclass A
755	method x {} {}
756	filter x
757    }
758    info class call B x
759} -cleanup {
760    root destroy
761} -result {{filter x ::B method} {filter x ::A method} {method x ::B method} {method x ::A method}}
762test oo-call-2.8 {class call introspection - errors} -body {
763    info class call
764} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
765test oo-call-2.9 {class call introspection - errors} -body {
766    info class call a
767} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
768test oo-call-2.10 {class call introspection - errors} -body {
769    info class call a b c
770} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
771test oo-call-2.11 {class call introspection - errors} -body {
772    info class call notaclass x
773} -returnCodes error -result {notaclass does not refer to an object}
774test oo-call-2.12 {class call introspection - errors} -setup {
775    oo::class create root
776} -body {
777    root create notaclass
778    info class call notaclass x
779} -returnCodes error -cleanup {
780    root destroy
781} -result {"notaclass" is not a class}
782test oo-call-2.13 {class call introspection - memory leaks} -body {
783    leaktest {
784	info class call oo::class destroy
785    }
786} -constraints memory -result 0
787test oo-call-2.14 {class call introspection - memory leaks} -body {
788    leaktest {
789	oo::class create leaktester { method foo {} {dummy} }
790	[leaktester new] destroy
791	list [info class call leaktester destroy] \
792	    [info class call leaktester foo] \
793	    [info class call leaktester bar] \
794	    [leaktester destroy]
795    }
796} -constraints memory -result 0
797
798test oo-call-3.1 {current call introspection} -setup {
799    oo::class create root
800} -body {
801    oo::class create A {
802	superclass root
803	method x {} {lappend ::result [self call]}
804    }
805    oo::class create B {
806	superclass A
807	method x {} {lappend ::result [self call];next}
808    }
809    B create y
810    oo::objdefine y method x {} {lappend ::result [self call];next}
811    set ::result {}
812    y x
813} -cleanup {
814    root destroy
815} -result {{{{method x object method} {method x ::B method} {method x ::A method}} 0} {{{method x object method} {method x ::B method} {method x ::A method}} 1} {{{method x object method} {method x ::B method} {method x ::A method}} 2}}
816test oo-call-3.2 {current call introspection} -setup {
817    oo::class create root
818} -constraints memory -body {
819    oo::class create A {
820	superclass root
821	method x {} {self call}
822    }
823    oo::class create B {
824	superclass A
825	method x {} {self call;next}
826    }
827    B create y
828    oo::objdefine y method x {} {self call;next}
829    leaktest {
830	y x
831    }
832} -cleanup {
833    root destroy
834} -result 0
835test oo-call-3.3 {current call introspection: in constructors} -setup {
836    oo::class create root
837} -body {
838    oo::class create A {
839	superclass root
840	constructor {} {lappend ::result [self call]}
841    }
842    oo::class create B {
843	superclass A
844	constructor {} {lappend ::result [self call]; next}
845    }
846    set ::result {}
847    [B new] destroy
848    return $::result
849} -cleanup {
850    root destroy
851} -result {{{{method <constructor> ::B method} {method <constructor> ::A method}} 0} {{{method <constructor> ::B method} {method <constructor> ::A method}} 1}}
852test oo-call-3.4 {current call introspection: in destructors} -setup {
853    oo::class create root
854} -body {
855    oo::class create A {
856	superclass root
857	destructor {lappend ::result [self call]}
858    }
859    oo::class create B {
860	superclass A
861	destructor {lappend ::result [self call]; next}
862    }
863    set ::result {}
864    [B new] destroy
865    return $::result
866} -cleanup {
867    root destroy
868} -result {{{{method <destructor> ::B method} {method <destructor> ::A method}} 0} {{{method <destructor> ::B method} {method <destructor> ::A method}} 1}}
869
870# Contributed tests from aspect, related to [0f42ff7871]
871#
872# dkf's "Principles Leading to a Fix"
873#
874#   A method ought to work "the same" whether or not it has been overridden by
875#   a subclass. A tailcalled command ought to have as parent stack the same
876#   thing you'd get with uplevel 1. A subclass will often expect the
877#   superclass's result to be the result that would be returned if the
878#   subclass was not there.
879
880# Common setup:
881#	any invocation of bar should emit "abc\nhi\n" then return to its
882#	caller
883set testopts {
884    -setup {
885	oo::class create Parent
886	oo::class create Foo {
887	    superclass Parent
888	    method bar {} {
889		puts abc
890		tailcall puts hi
891		puts xyz
892	    }
893	}
894	oo::class create Foo2 {
895	    superclass Parent
896	}
897    }
898    -cleanup {
899	Parent destroy
900    }
901}
902
903# these succeed, showing that without [next] the bug doesn't fire
904test next-tailcall-simple-1 "trivial case with one method" {*}$testopts -body {
905    [Foo create foo] bar
906} -output [join {abc hi} \n]\n
907test next-tailcall-simple-2 "my bar" {*}$testopts -body {
908    oo::define Foo method baz {} {
909	puts a
910	my bar
911	puts b
912    }
913    [Foo create foo] baz
914} -output [join {a abc hi b} \n]\n
915test next-tailcall-simple-3 "\[self\] bar" {*}$testopts -body {
916    oo::define Foo method baz {} {
917	puts a
918	[self] bar
919	puts b
920    }
921    [Foo create foo] baz
922} -output [join {a abc hi b} \n]\n
923test next-tailcall-simple-4 "foo bar" {*}$testopts -body {
924    oo::define Foo method baz {} {
925	puts a
926	foo bar
927	puts b
928    }
929    [Foo create foo] baz
930} -output [join {a abc hi b} \n]\n
931
932# everything from here on uses [next], and fails on 8.6.4 with compilation
933test next-tailcall-superclass-1 "next superclass" {*}$testopts -body {
934    oo::define Foo2 {
935	superclass Foo
936	method bar {} {
937	    puts a
938	    next
939	    puts b
940	}
941    }
942    [Foo2 create foo] bar
943} -output [join {a abc hi b} \n]\n
944test next-tailcall-superclass-2 "nextto superclass" {*}$testopts -body {
945    oo::define Foo2 {
946	superclass Foo
947	method bar {} {
948	    puts a
949	    nextto Foo
950	    puts b
951	}
952    }
953    [Foo2 create foo] bar
954} -output [join {a abc hi b} \n]\n
955
956test next-tailcall-mixin-1 "class mixin" {*}$testopts -body {
957    oo::define Foo2 {
958	method Bar {} {
959	    puts a
960	    next
961	    puts b
962	}
963	filter Bar
964    }
965    oo::define Foo mixin Foo2
966    Foo create foo
967    foo bar
968} -output [join {a abc hi b} \n]\n
969
970test next-tailcall-objmixin-1 "object mixin" {*}$testopts -body {
971    oo::define Foo2 {
972	method Bar {} {
973	    puts a
974	    next
975	    puts b
976	}
977	filter Bar
978    }
979    Foo create foo
980    oo::objdefine foo mixin Foo2
981    foo bar
982} -output [join {a abc hi b} \n]\n
983
984test next-tailcall-filter-1 "filter method" {*}$testopts -body {
985    oo::define Foo method Filter {} {
986	puts a
987	next
988	puts b
989    }
990    oo::define Foo filter Filter
991    [Foo new] bar
992} -output [join {a abc hi b} \n]\n
993
994test next-tailcall-forward-1 "forward method" {*}$testopts -body {
995    proc foobar {} {
996	puts "abc"
997	tailcall puts "hi"
998	puts "xyz"
999    }
1000    oo::define Foo forward foobar foobar
1001    oo::define Foo2 {
1002	superclass Foo
1003	method foobar {} {
1004	    puts a
1005	    next
1006	    puts b
1007	}
1008    }
1009    [Foo2 new] foobar
1010} -output [join {a abc hi b} \n]\n
1011
1012test next-tailcall-constructor-1 "next in constructor" -body {
1013    oo::class create Foo {
1014	constructor {} {
1015	    puts abc
1016	    tailcall puts hi
1017	    puts xyz
1018	}
1019    }
1020    oo::class create Foo2 {
1021	superclass Foo
1022	constructor {} {
1023	    puts a
1024	    next
1025	    puts b
1026	}
1027    }
1028    list [Foo new] [Foo2 new]
1029    return ""
1030} -cleanup {
1031    Foo destroy
1032} -output [join {abc hi a abc hi b} \n]\n
1033
1034test next-tailcall-destructor-1 "next in destructor" -body {
1035    oo::class create Foo {
1036	destructor {
1037	    puts abc
1038	    tailcall puts hi
1039	    puts xyz
1040	}
1041    }
1042    oo::class create Foo2 {
1043	superclass Foo
1044	destructor {
1045	    puts a
1046	    next
1047	    puts b
1048	}
1049    }
1050    Foo create foo
1051    Foo2 create foo2
1052    foo destroy
1053    foo2 destroy
1054} -output [join {abc hi a abc hi b} \n]\n -cleanup {
1055    Foo destroy
1056}
1057
1058unset testopts
1059
1060cleanupTests
1061return
1062
1063# Local Variables:
1064# mode: tcl
1065# End:
1066