116 lines
2.0 KiB
Tcl
116 lines
2.0 KiB
Tcl
# vim:se syntax=tcl:
|
|
|
|
source [file dirname [info script]]/testing.tcl
|
|
|
|
needs cmd tailcall
|
|
needs cmd try tclcompat
|
|
|
|
test tailcall-1.1 {Basic tailcall} {
|
|
# Demo -- a tail-recursive factorial function
|
|
proc fac {x {val 1}} {
|
|
if {$x <= 2} {
|
|
expr {$x * $val}
|
|
} else {
|
|
tailcall fac [expr {$x -1}] [expr {$x * $val}]
|
|
}
|
|
}
|
|
fac 10
|
|
} {3628800}
|
|
|
|
test tailcall-1.2 {Tailcall in try} {
|
|
set x 0
|
|
proc a {} { upvar x x; incr x }
|
|
proc b {} { upvar x x; incr x 4; try { tailcall a } finally { incr x 8 }}
|
|
b
|
|
set x
|
|
} {13}
|
|
|
|
test tailcall-1.3 {Tailcall does return} {
|
|
set x 0
|
|
proc a {} { upvar x x; incr x }
|
|
proc b {} { upvar x x; incr x 4; tailcall a; incr x 8}
|
|
b
|
|
set x
|
|
} {5}
|
|
|
|
test tailcall-1.5 {interaction of uplevel and tailcall} {
|
|
proc a {cmd} {
|
|
tailcall $cmd
|
|
}
|
|
proc b {} {
|
|
lappend result [uplevel 1 a c]
|
|
lappend result [uplevel 1 a c]
|
|
}
|
|
proc c {} {
|
|
return c
|
|
}
|
|
a b
|
|
} {c c}
|
|
|
|
test tailcall-1.6 {tailcall pass through return} {
|
|
proc a {script} {
|
|
# return from $script should pass through back to the caller
|
|
tailcall foreach i {1 2 3} $script
|
|
}
|
|
proc b {} {
|
|
a {return ok}
|
|
# Should not get here
|
|
return bad
|
|
}
|
|
b
|
|
} {ok}
|
|
|
|
test tailcall-1.7 {tailcall with namespaces} jim {
|
|
proc a::b {} {
|
|
proc c {} {
|
|
return 1
|
|
}
|
|
set d [local lambda {} { c }]
|
|
# $d should resolve in namespace 'a', not ""
|
|
tailcall $d
|
|
}
|
|
a::b
|
|
} 1
|
|
|
|
test tailcall-1.8 {tailcall with local} jim {
|
|
proc a {} {
|
|
tailcall [local proc b {} { return c }]
|
|
}
|
|
a
|
|
} {c}
|
|
|
|
test tailcall-1.9 {tailcall with large number of invocations} {
|
|
proc a {n} {
|
|
if {$n == 0} {
|
|
return 1
|
|
}
|
|
incr n -1
|
|
tailcall a $n
|
|
}
|
|
a 100000
|
|
} 1
|
|
|
|
test tailcall-1.10 {tailcall through uplevel} {
|
|
proc a {} { tailcall b }
|
|
proc b {} { uplevel 1 c }
|
|
proc c {} { tailcall d }
|
|
proc d {} { return [info level] }
|
|
a
|
|
} 1
|
|
|
|
test tailcall-1.11 {chained tailcall} {
|
|
proc a {} { b }
|
|
proc b {} { tailcall tailcall c }
|
|
proc c {} { return [info level] }
|
|
a
|
|
} 1
|
|
|
|
test tailcall-1.12 {uplevel tailcall} {
|
|
proc a {} { b }
|
|
proc b {} { uplevel 1 tailcall c }
|
|
proc c {} { return [info level] }
|
|
a
|
|
} 1
|
|
|
|
testreport
|