event.test: Fix test on Haiku
[jimtcl.git] / tests / tailcall.test
blobeaa48ccda43797b81b9cae50cdcdb0bf8f00dcd5
1 # vim:se syntax=tcl:
3 source [file dirname [info script]]/testing.tcl
5 needs cmd tailcall
6 needs cmd try tclcompat
8 test tailcall-1.1 {Basic tailcall} {
9         # Demo -- a tail-recursive factorial function
10         proc fac {x {val 1}} {
11                 if {$x <= 2} {
12                         expr {$x * $val}
13                 } else {
14                         tailcall fac [expr {$x -1}] [expr {$x * $val}]
15                 }
16         }
17         fac 10
18 } {3628800}
20 test tailcall-1.2 {Tailcall in try} {
21         set x 0
22         proc a {} { upvar x x; incr x }
23         proc b {} { upvar x x; incr x 4; try { tailcall a } finally { incr x 8 }}
24         b
25         set x
26 } {13}
28 test tailcall-1.3 {Tailcall does return} {
29         set x 0
30         proc a {} { upvar x x; incr x }
31         proc b {} { upvar x x; incr x 4; tailcall a; incr x 8}
32         b
33         set x
34 } {5}
36 test tailcall-1.5 {interaction of uplevel and tailcall} {
37         proc a {cmd} {
38                 tailcall $cmd
39         }
40         proc b {} {
41                 lappend result [uplevel 1 a c]
42                 lappend result [uplevel 1 a c]
43         }
44         proc c {} {
45                 return c
46         }
47         a b
48 } {c c}
50 test tailcall-1.6 {tailcall pass through return} {
51         proc a {script} {
52                 # return from $script should pass through back to the caller
53                 tailcall foreach i {1 2 3} $script
54         }
55         proc b {} {
56                 a {return ok}
57                 # Should not get here
58                 return bad
59         }
60         b
61 } {ok}
63 test tailcall-1.7 {tailcall with namespaces} jim {
64         proc a::b {} {
65                 proc c {} {
66                         return 1
67                 }
68                 set d [local lambda {} { c }]
69                 # $d should resolve in namespace 'a', not ""
70                 tailcall $d
71         }
72         a::b
73 } 1
75 test tailcall-1.8 {tailcall with local} jim {
76         proc a {} {
77                 tailcall [local proc b {} { return c }]
78         }
79         a
80 } {c}
82 test tailcall-1.9 {tailcall with large number of invocations} {
83         proc a {n} {
84                 if {$n == 0} {
85                         return 1
86                 }
87                 incr n -1
88                 tailcall a $n
89         }
90         a 1000
91 } 1
93 test tailcall-1.10 {tailcall through uplevel} {
94         proc a {} { tailcall b }
95         proc b {} { uplevel 1 c }
96         proc c {} { tailcall d }
97         proc d {} { return [info level] }
98         a
99 } 1
101 test tailcall-1.11 {chained tailcall} {
102         proc a {} { b }
103         proc b {} { tailcall tailcall c }
104         proc c {} { return [info level] }
105         a
106 } 1
108 test tailcall-1.12 {uplevel tailcall} {
109         proc a {} { b }
110         proc b {} { uplevel 1 tailcall c }
111         proc c {} { return [info level] }
112         a
113 } 1
115 testreport