diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | tests/NRE.test | 476 | ||||
| -rw-r--r-- | tests/nre.test | 295 | ||||
| -rw-r--r-- | tests/unsupported.test | 248 |
4 files changed, 552 insertions, 476 deletions
@@ -1,3 +1,12 @@ +2008-08-02 Miguel Sofer <msofer@users.sf.net> + + * tests/NRE.test: made empty, waiting for removal until das does + his thing in macosx/Tcl.xcodeproj/project.pbxproj + + * tests/nre.test: migrated tests to standard locations, + * tests/unsupported.test: separating core functionality from the + experimental commands. These are new files. + 2008-08-01 Jeff Hobbs <jeffh@ActiveState.com> * doc/Exit.3: do not call Tcl_Finalize implicitly diff --git a/tests/NRE.test b/tests/NRE.test index 4a279bc..e69de29 100644 --- a/tests/NRE.test +++ b/tests/NRE.test @@ -1,476 +0,0 @@ -# Commands covered: proc, apply, [interp alias], [namespce import], tailcall -# -# This file contains a collection of tests for the non-recursive executor that -# avoids recursive calls to TEBC. -# -# Copyright (c) 2008 by Miguel Sofer. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: NRE.test,v 1.10 2008/08/01 00:44:05 msofer Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} - -testConstraint tailcall [llength [info commands ::tcl::unsupported::tailcall]] -testConstraint testnrelevels [llength [info commands testnrelevels]] - -# -# The tests that risked blowing the C stack on failure have been removed: we -# can now actually measure using testnrelevels. -# - -if {[testConstraint testnrelevels]} { - namespace eval testnre { - # - # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, - # cmdFrame level, callFrame level, tosPtr and callback depth - # - variable last [testnrelevels] - proc depthDiff {} { - variable last - set depth [testnrelevels] - set res {} - foreach t $depth l $last { - lappend res [expr {$t-$l}] - } - set last $depth - return $res - } - proc setabs {} { - uplevel 1 variable abs -[lindex [testnrelevels] 0] - } - - variable body0 { - set x [depthDiff] - if {[incr i] > 10} { - variable abs - incr abs [lindex [testnrelevels] 0] - return [list [lrange $x 0 3] $abs] - } - } - proc makebody txt { - variable body0 - return "$body0; $txt" - } - namespace export * - } - namespace import testnre::* -} - -test NRE-1.1 {self-recursive procs} -setup { - proc a i [makebody {a $i}] -} -body { - setabs - a 0 -} -cleanup { - rename a {} - unset abs -} -result {{0 1 1 1} 0} - -test NRE-1.2 {self-recursive lambdas} -setup { - set a [list i [makebody {apply $::a $i}]] -} -body { - setabs - apply $a 0 -} -cleanup { - unset a abs -} -result {{0 1 1 1} 0} - -test NRE-1.3 {mutually recursive procs and lambdas} -setup { - proc a i { - apply $::b [incr i] - } - set b [list i [makebody {a $i}]] -} -body { - setabs - a 0 -} -cleanup { - rename a {} - unset b abs -} -result {{0 2 2 2} 0} - -# -# Test that aliases are non-recursive -# - -test NRE-2.1 {alias is not recursive} -setup { - proc a i [makebody {b $i}] - interp alias {} b {} a -} -body { - setabs - a 0 -} -cleanup { - rename a {} - rename b {} - unset abs -} -result {{0 2 1 1} 0} - -# -# Test that imports are non-recursive -# - -test NRE-3.1 {imports are not recursive} -setup { - namespace eval foo { - setabs - namespace export a - } - proc foo::a i [makebody {::a $i}] - namespace import foo::a -} -body { - a 0 -} -cleanup { - rename a {} - namespace delete ::foo -} -result {{0 2 1 1} 0} - -test NRE-4.1 {ensembles are not recursive} -setup { - proc a i [makebody {b foo $i}] - namespace ensemble create \ - -command b \ - -map [list foo a] -} -body { - setabs - a 0 -} -cleanup { - rename a {} - rename b {} - unset abs -} -result {{0 2 1 1} 0} - -test NRE-5.1 {[namespace eval] is not recursive} -setup { - namespace eval ::foo { - setabs - } - proc foo::a i [makebody {namespace eval ::foo [list a $i]}] -} -body { - ::foo::a 0 -} -cleanup { - namespace delete ::foo -} -result {{0 2 2 2} 0} - -test NRE-5.2 {[namespace eval] is not recursive} -setup { - namespace eval ::foo { - setabs - } - proc foo::a i [makebody {namespace eval ::foo "set x $i; a $i"}] -} -body { - foo::a 0 -} -cleanup { - namespace delete ::foo -} -result {{0 2 2 2} 0} - -test NRE-6.1 {[uplevel] is not recursive} -setup { - proc a i [makebody {uplevel 1 [list a $i]}] -} -body { - setabs - a 0 -} -cleanup { - rename a {} - unset abs -} -result {{0 2 2 0} 0} - -test NRE-6.2 {[uplevel] is not recursive} -setup { - setabs - proc a i [makebody {uplevel 1 "set x $i; a $i"}] -} -body { - a 0 -} -cleanup { - rename a {} - unset abs -} -result {{0 2 2 0} 0} - -test NRE-7.1 {[catch] is not recursive} -setup { - setabs - proc a i [makebody {uplevel 1 "catch {a $i} msg; set msg"}] -} -body { - a 0 -} -cleanup { - rename a {} - unset x abs -} -result {{0 3 3 0} 0} - -# -# Basic TclOO tests -# - -test NRE-oo.1 {really deep calls in oo - direct} -setup { - oo::object create foo - oo::objdefine foo method bar i [makebody {foo bar $i}] -} -body { - setabs - foo bar 0 -} -cleanup { - foo destroy - unset abs -} -result {{0 1 1 1} 0} - -test NRE-oo.2 {really deep calls in oo - call via [self]} -setup { - oo::object create foo - oo::objdefine foo method bar i [makebody {[self] bar $i}] -} -body { - setabs - foo bar 0 -} -cleanup { - foo destroy - unset abs -} -result {{0 1 1 1} 0} - -test NRE-oo.3 {really deep calls in oo - private calls} -setup { - oo::object create foo - oo::objdefine foo method bar i [makebody {my bar $i}] -} -body { - setabs - foo bar 0 -} -cleanup { - foo destroy - unset abs -} -result {{0 1 1 1} 0} - -test NRE-oo.4 {really deep calls in oo - overriding} -setup { - oo::class create foo { - method bar i [makebody {my bar $i}] - } - oo::class create boo { - superclass foo - method bar i [makebody {next $i}] - } -} -body { - setabs - [boo new] bar 0 -} -cleanup { - foo destroy - unset abs -} -result {{0 1 1 1} 0} - -test NRE-oo.5 {really deep calls in oo - forwards} -setup { - oo::object create foo - set body [makebody {my boo $i}] - oo::objdefine foo " - method bar i {$body} - forward boo ::foo bar - " -} -body { - setabs - foo bar 0 -} -cleanup { - foo destroy - unset abs -} -result {{0 2 1 1} 0} - - -# -# NASTY BUG found by tcllib's interp package -# - -test NRE-X.1 {eval in wrong interp} { - set i [interp create] - set res [$i eval { - set x {namespace children ::} - set y [list namespace children ::] - namespace delete {*}[{*}$y] - set j [interp create] - $j eval {namespace delete {*}[namespace children ::]} - namespace eval foo {} - set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]] - interp delete $j - set res - }] - interp delete $i - set res -} {::foo ::foo {} {}} - -# -# Test tailcalls -# - -if {[testConstraint tailcall]} { - namespace eval tcl::unsupported namespace export tailcall - namespace import tcl::unsupported::tailcall -} - -test NRE-T.0 {tailcall is constant space} -constraints {tailcall} -setup { - proc a i { - if {[incr i] > 10} { - return [depthDiff] - } - depthDiff - tailcall a $i - } -} -body { - a 0 -} -cleanup { - rename a {} -} -result {0 0 0 0 0 0} - -test NRE-T.1 {tailcall} -constraints {tailcall} -body { - namespace eval a { - variable x *::a - proc xset {} { - set tmp {} - set ns {[namespace current]} - set level [info level] - for {set i 0} {$i <= [info level]} {incr i} { - uplevel #$i "set x $i$ns" - lappend tmp "$i [info level $i]" - } - lrange $tmp 1 end - } - proc foo {} {tailcall xset; set x noreach} - } - namespace eval b { - variable x *::b - proc xset args {error b::xset} - proc moo {} {set x 0; variable y [::a::foo]; set x} - } - variable x *:: - proc xset args {error ::xset} - list [::b::moo] | $x $a::x $b::x | $::b::y -} -cleanup { - unset x - rename xset {} - namespace delete a b -} -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}} - - -test NRE-T.2 {tailcall in non-proc} -constraints {tailcall} -body { - list [catch {namespace eval a [list tailcall set x 1]} msg] $msg -} -result {1 {tailcall can only be called from a proc or lambda}} - -test NRE-T.3 {tailcall falls off tebc} -constraints {tailcall} -body { - unset -nocomplain x - proc foo {} {tailcall set x 1} - list [catch foo msg] $msg [set x] -} -cleanup { - rename foo {} - unset x -} -result {0 1 1} - -test NRE-T.4 {tailcall falls off tebc} -constraints {tailcall} -body { - set x 2 - proc foo {} {tailcall set x 1} - foo - set x -} -cleanup { - rename foo {} - unset x -} -result 1 - -test NRE-T.5 {tailcall falls off tebc} -constraints {tailcall} -body { - set x 2 - namespace eval bar { - variable x 3 - proc foo {} {tailcall set x 1} - } - bar::foo - list $x $bar::x -} -cleanup { - unset x - namespace delete bar -} -result {1 3} - -test NRE-T.6 {tailcall does remove callframes} -constraints {tailcall} -body { - proc foo {} {info level} - proc moo {} {tailcall foo} - proc boo {} {expr {[moo] - [info level]}} - boo -} -cleanup { - rename foo {} - rename moo {} - rename boo {} -} -result 1 - -test NRE-T.7 {tailcall does return} -constraints {tailcall} -setup { - namespace eval ::foo { - variable res {} - proc a {} { - variable res - append res a - tailcall set x 1 - append res a - } - proc b {} { - variable res - append res b - a - append res b - } - proc c {} { - variable res - append res c - b - append res c - } - } -} -body { - namespace eval ::foo c -} -cleanup { - namespace delete ::foo -} -result cbabc - -test NRE-T.8 {tailcall tailcall} -constraints {tailcall} -setup { - namespace eval ::foo { - variable res {} - proc a {} { - variable res - append res a - tailcall tailcall set x 1 - append res a - } - proc b {} { - variable res - append res b - a - append res b - } - proc c {} { - variable res - append res c - b - append res c - } - } -} -body { - namespace eval ::foo c -} -cleanup { - namespace delete ::foo -} -match glob -result *tailcall* -returnCodes error - -test NRE-T.9 {tailcall factorial} -constraints {tailcall} -setup { - proc fact {n {b 1}} { - if {$n == 1} { - return $b - } - tailcall fact [expr {$n-1}] [expr {$n*$b}] - } -} -body { - list [fact 1] [fact 5] [fact 10] [fact 15] -} -cleanup { - rename fact {} -} -result {1 120 3628800 1307674368000} - - -namespace forget tcl::unsupported::tailcall - -# -# Test that ensembles are non-recursive -# - - - -# cleanup -::tcltest::cleanupTests - -if {[testConstraint testnrelevels]} { - namespace forget testnre::* - namespace delete testnre -} - -if {[testConstraint tailcall]} { - namespace forget tcl::unsupported::tailcall -} - -return diff --git a/tests/nre.test b/tests/nre.test new file mode 100644 index 0000000..c926de5 --- /dev/null +++ b/tests/nre.test @@ -0,0 +1,295 @@ +# Commands covered: proc, apply, [interp alias], [namespce import] +# +# This file contains a collection of tests for the non-recursive executor that +# avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the +# actual command functionality is tested in the specific test file. +# +# Copyright (c) 2008 by Miguel Sofer. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: nre.test,v 1.1 2008/08/02 14:12:56 msofer Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +testConstraint testnrelevels [llength [info commands testnrelevels]] + +# +# The tests that risked blowing the C stack on failure have been removed: we +# can now actually measure using testnrelevels. +# + +if {[testConstraint testnrelevels]} { + namespace eval testnre { + # + # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, + # cmdFrame level, callFrame level, tosPtr and callback depth + # + variable last [testnrelevels] + proc depthDiff {} { + variable last + set depth [testnrelevels] + set res {} + foreach t $depth l $last { + lappend res [expr {$t-$l}] + } + set last $depth + return $res + } + proc setabs {} { + uplevel 1 variable abs -[lindex [testnrelevels] 0] + } + + variable body0 { + set x [depthDiff] + if {[incr i] > 10} { + variable abs + incr abs [lindex [testnrelevels] 0] + return [list [lrange $x 0 3] $abs] + } + } + proc makebody txt { + variable body0 + return "$body0; $txt" + } + namespace export * + } + namespace import testnre::* +} + +test nre-1.1 {self-recursive procs} -setup { + proc a i [makebody {a $i}] +} -body { + setabs + a 0 +} -cleanup { + rename a {} + unset abs +} -result {{0 1 1 1} 0} + +test nre-1.2 {self-recursive lambdas} -setup { + set a [list i [makebody {apply $::a $i}]] +} -body { + setabs + apply $a 0 +} -cleanup { + unset a abs +} -result {{0 1 1 1} 0} + +test nre-1.3 {mutually recursive procs and lambdas} -setup { + proc a i { + apply $::b [incr i] + } + set b [list i [makebody {a $i}]] +} -body { + setabs + a 0 +} -cleanup { + rename a {} + unset b abs +} -result {{0 2 2 2} 0} + +# +# Test that aliases are non-recursive +# + +test nre-2.1 {alias is not recursive} -setup { + proc a i [makebody {b $i}] + interp alias {} b {} a +} -body { + setabs + a 0 +} -cleanup { + rename a {} + rename b {} + unset abs +} -result {{0 2 1 1} 0} + +# +# Test that imports are non-recursive +# + +test nre-3.1 {imports are not recursive} -setup { + namespace eval foo { + setabs + namespace export a + } + proc foo::a i [makebody {::a $i}] + namespace import foo::a +} -body { + a 0 +} -cleanup { + rename a {} + namespace delete ::foo +} -result {{0 2 1 1} 0} + +test nre-4.1 {ensembles are not recursive} -setup { + proc a i [makebody {b foo $i}] + namespace ensemble create \ + -command b \ + -map [list foo a] +} -body { + setabs + a 0 +} -cleanup { + rename a {} + rename b {} + unset abs +} -result {{0 2 1 1} 0} + +test nre-5.1 {[namespace eval] is not recursive} -setup { + namespace eval ::foo { + setabs + } + proc foo::a i [makebody {namespace eval ::foo [list a $i]}] +} -body { + ::foo::a 0 +} -cleanup { + namespace delete ::foo +} -result {{0 2 2 2} 0} + +test nre-5.2 {[namespace eval] is not recursive} -setup { + namespace eval ::foo { + setabs + } + proc foo::a i [makebody {namespace eval ::foo "set x $i; a $i"}] +} -body { + foo::a 0 +} -cleanup { + namespace delete ::foo +} -result {{0 2 2 2} 0} + +test nre-6.1 {[uplevel] is not recursive} -setup { + proc a i [makebody {uplevel 1 [list a $i]}] +} -body { + setabs + a 0 +} -cleanup { + rename a {} + unset abs +} -result {{0 2 2 0} 0} + +test nre-6.2 {[uplevel] is not recursive} -setup { + setabs + proc a i [makebody {uplevel 1 "set x $i; a $i"}] +} -body { + a 0 +} -cleanup { + rename a {} + unset abs +} -result {{0 2 2 0} 0} + +test nre-7.1 {[catch] is not recursive} -setup { + setabs + proc a i [makebody {uplevel 1 "catch {a $i} msg; set msg"}] +} -body { + a 0 +} -cleanup { + rename a {} + unset x abs +} -result {{0 3 3 0} 0} + +# +# Basic TclOO tests +# + +test nre-oo.1 {really deep calls in oo - direct} -setup { + oo::object create foo + oo::objdefine foo method bar i [makebody {foo bar $i}] +} -body { + setabs + foo bar 0 +} -cleanup { + foo destroy + unset abs +} -result {{0 1 1 1} 0} + +test nre-oo.2 {really deep calls in oo - call via [self]} -setup { + oo::object create foo + oo::objdefine foo method bar i [makebody {[self] bar $i}] +} -body { + setabs + foo bar 0 +} -cleanup { + foo destroy + unset abs +} -result {{0 1 1 1} 0} + +test nre-oo.3 {really deep calls in oo - private calls} -setup { + oo::object create foo + oo::objdefine foo method bar i [makebody {my bar $i}] +} -body { + setabs + foo bar 0 +} -cleanup { + foo destroy + unset abs +} -result {{0 1 1 1} 0} + +test nre-oo.4 {really deep calls in oo - overriding} -setup { + oo::class create foo { + method bar i [makebody {my bar $i}] + } + oo::class create boo { + superclass foo + method bar i [makebody {next $i}] + } +} -body { + setabs + [boo new] bar 0 +} -cleanup { + foo destroy + unset abs +} -result {{0 1 1 1} 0} + +test nre-oo.5 {really deep calls in oo - forwards} -setup { + oo::object create foo + set body [makebody {my boo $i}] + oo::objdefine foo " + method bar i {$body} + forward boo ::foo bar + " +} -body { + setabs + foo bar 0 +} -cleanup { + foo destroy + unset abs +} -result {{0 2 1 1} 0} + + +# +# NASTY BUG found by tcllib's interp package +# + +test nre-X.1 {eval in wrong interp} { + set i [interp create] + set res [$i eval { + set x {namespace children ::} + set y [list namespace children ::] + namespace delete {*}[{*}$y] + set j [interp create] + $j eval {namespace delete {*}[namespace children ::]} + namespace eval foo {} + set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]] + interp delete $j + set res + }] + interp delete $i + set res +} {::foo ::foo {} {}} + + +# cleanup +::tcltest::cleanupTests + +if {[testConstraint testnrelevels]} { + namespace forget testnre::* + namespace delete testnre +} + +return diff --git a/tests/unsupported.test b/tests/unsupported.test new file mode 100644 index 0000000..7d09558 --- /dev/null +++ b/tests/unsupported.test @@ -0,0 +1,248 @@ +# Commands covered: proc, apply, [interp alias], [namespce import], tailcall +# +# This file contains a collection of tests for experimental commands that are +# found in ::tcl::unsupported. The tests will migrate to normal test files +# if/when the commands find their way into the core. +# +# Copyright (c) 2008 by Miguel Sofer. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: unsupported.test,v 1.1 2008/08/02 14:12:56 msofer Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +testConstraint testnrelevels [llength [info commands testnrelevels]] + +# +# The tests that risked blowing the C stack on failure have been removed: we +# can now actually measure using testnrelevels. +# + +if {[testConstraint testnrelevels]} { + namespace eval testnre { + # + # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, + # cmdFrame level, callFrame level, tosPtr and callback depth + # + variable last [testnrelevels] + proc depthDiff {} { + variable last + set depth [testnrelevels] + set res {} + foreach t $depth l $last { + lappend res [expr {$t-$l}] + } + set last $depth + return $res + } + proc setabs {} { + uplevel 1 variable abs -[lindex [testnrelevels] 0] + } + + variable body0 { + set x [depthDiff] + if {[incr i] > 10} { + variable abs + incr abs [lindex [testnrelevels] 0] + return [list [lrange $x 0 3] $abs] + } + } + proc makebody txt { + variable body0 + return "$body0; $txt" + } + namespace export * + } + namespace import testnre::* +} + +# +# Test tailcalls +# + +testConstraint tailcall [llength [info commands ::tcl::unsupported::tailcall]] + +if {[testConstraint tailcall]} { + namespace eval tcl::unsupported namespace export tailcall + namespace import tcl::unsupported::tailcall +} + +test unsupported-T.0 {tailcall is constant space} -constraints {tailcall} -setup { + proc a i { + if {[incr i] > 10} { + return [depthDiff] + } + depthDiff + tailcall a $i + } +} -body { + a 0 +} -cleanup { + rename a {} +} -result {0 0 0 0 0 0} + +test unsupported-T.1 {tailcall} -constraints {tailcall} -body { + namespace eval a { + variable x *::a + proc xset {} { + set tmp {} + set ns {[namespace current]} + set level [info level] + for {set i 0} {$i <= [info level]} {incr i} { + uplevel #$i "set x $i$ns" + lappend tmp "$i [info level $i]" + } + lrange $tmp 1 end + } + proc foo {} {tailcall xset; set x noreach} + } + namespace eval b { + variable x *::b + proc xset args {error b::xset} + proc moo {} {set x 0; variable y [::a::foo]; set x} + } + variable x *:: + proc xset args {error ::xset} + list [::b::moo] | $x $a::x $b::x | $::b::y +} -cleanup { + unset x + rename xset {} + namespace delete a b +} -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}} + + +test unsupported-T.2 {tailcall in non-proc} -constraints {tailcall} -body { + list [catch {namespace eval a [list tailcall set x 1]} msg] $msg +} -result {1 {tailcall can only be called from a proc or lambda}} + +test unsupported-T.3 {tailcall falls off tebc} -constraints {tailcall} -body { + unset -nocomplain x + proc foo {} {tailcall set x 1} + list [catch foo msg] $msg [set x] +} -cleanup { + rename foo {} + unset x +} -result {0 1 1} + +test unsupported-T.4 {tailcall falls off tebc} -constraints {tailcall} -body { + set x 2 + proc foo {} {tailcall set x 1} + foo + set x +} -cleanup { + rename foo {} + unset x +} -result 1 + +test unsupported-T.5 {tailcall falls off tebc} -constraints {tailcall} -body { + set x 2 + namespace eval bar { + variable x 3 + proc foo {} {tailcall set x 1} + } + bar::foo + list $x $bar::x +} -cleanup { + unset x + namespace delete bar +} -result {1 3} + +test unsupported-T.6 {tailcall does remove callframes} -constraints {tailcall} -body { + proc foo {} {info level} + proc moo {} {tailcall foo} + proc boo {} {expr {[moo] - [info level]}} + boo +} -cleanup { + rename foo {} + rename moo {} + rename boo {} +} -result 1 + +test unsupported-T.7 {tailcall does return} -constraints {tailcall} -setup { + namespace eval ::foo { + variable res {} + proc a {} { + variable res + append res a + tailcall set x 1 + append res a + } + proc b {} { + variable res + append res b + a + append res b + } + proc c {} { + variable res + append res c + b + append res c + } + } +} -body { + namespace eval ::foo c +} -cleanup { + namespace delete ::foo +} -result cbabc + +test unsupported-T.8 {tailcall tailcall} -constraints {tailcall} -setup { + namespace eval ::foo { + variable res {} + proc a {} { + variable res + append res a + tailcall tailcall set x 1 + append res a + } + proc b {} { + variable res + append res b + a + append res b + } + proc c {} { + variable res + append res c + b + append res c + } + } +} -body { + namespace eval ::foo c +} -cleanup { + namespace delete ::foo +} -match glob -result *tailcall* -returnCodes error + +test unsupported-T.9 {tailcall factorial} -constraints {tailcall} -setup { + proc fact {n {b 1}} { + if {$n == 1} { + return $b + } + tailcall fact [expr {$n-1}] [expr {$n*$b}] + } +} -body { + list [fact 1] [fact 5] [fact 10] [fact 15] +} -cleanup { + rename fact {} +} -result {1 120 3628800 1307674368000} + + +if {[testConstraint tailcall]} { + namespace forget tcl::unsupported::tailcall +} + +# cleanup +::tcltest::cleanupTests + +if {[testConstraint testnrelevels]} { + namespace forget testnre::* + namespace delete testnre +} + +return |