From 1f4b86be27a81175aae9c86e7847149de4442ff6 Mon Sep 17 00:00:00 2001
From: Miguel Sofer <miguel.sofer@gmail.com>
Date: Sat, 2 Aug 2008 14:12:55 +0000
Subject: 	* 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.
---
 ChangeLog              |   9 +
 tests/NRE.test         | 476 -------------------------------------------------
 tests/nre.test         | 295 ++++++++++++++++++++++++++++++
 tests/unsupported.test | 248 ++++++++++++++++++++++++++
 4 files changed, 552 insertions(+), 476 deletions(-)
 create mode 100644 tests/nre.test
 create mode 100644 tests/unsupported.test

diff --git a/ChangeLog b/ChangeLog
index 617788e..5327945 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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
-- 
cgit v0.12