summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2008-08-02 14:12:55 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2008-08-02 14:12:55 (GMT)
commit1f4b86be27a81175aae9c86e7847149de4442ff6 (patch)
tree2e70b0c3f572a0d3d6d0d4f46265ff6f16f1e4dd /tests
parente8eb91c8acb09e341223b15de621f7ef1c8131f9 (diff)
downloadtcl-1f4b86be27a81175aae9c86e7847149de4442ff6.zip
tcl-1f4b86be27a81175aae9c86e7847149de4442ff6.tar.gz
tcl-1f4b86be27a81175aae9c86e7847149de4442ff6.tar.bz2
* 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.
Diffstat (limited to 'tests')
-rw-r--r--tests/NRE.test476
-rw-r--r--tests/nre.test295
-rw-r--r--tests/unsupported.test248
3 files changed, 543 insertions, 476 deletions
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