* generic/tcl.h:

	* generic/tclInt.h:
	* generic/tclBasic.c:
	* generic/tclExecute.c:
	* generic/tclNamesp.c (Tcl_PopCallFrame): Rewritten tailcall
	implementation, ::unsupported::atProcExit is (temporarily?)
	gone. The new approach is much simpler, and also closer to being
	correct. This commit fixes [Bug 2649975] and [Bug 2695587].

	* tests/coroutine.test:    Moved the tests to their own files,
	* tests/tailcall.test:     removed the unsupported.test. Added
	* tests/unsupported.test:  tests for the fixed bugs.

2 files changed, 458 insertions, 400 deletions

diff --git a/tests/unsupported.test b/tests/coroutine.test
index 0c706b8..fd3a3a1 100644
--- a/tests/unsupported.test
+++ b/tests/coroutine.test
@@ -1,4 +1,4 @@
-# Commands covered:  tailcall, atProcExit, coroutine, yield
+# Commands covered:  coroutine, yield, [info coroutine]
 #
 # This file contains a collection of tests for experimental commands that are
 # found in ::tcl::unsupported. The tests will migrate to normal test files
@@ -9,7 +9,7 @@
 # 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.15 2008/10/14 18:49:47 dgp Exp $
+# RCS: @(#) $Id: coroutine.test,v 1.1 2009/03/19 23:31:37 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -17,17 +17,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 }
 
 testConstraint testnrelevels [llength [info commands testnrelevels]]
-testConstraint atProcExit [llength [info commands ::tcl::unsupported::atProcExit]]
-
-if {[namespace exists tcl::unsupported]} {
-    namespace eval tcl::unsupported namespace export *
-    namespace import tcl::unsupported::*
-}
-
-#
-# 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 {
@@ -67,361 +56,6 @@ if {[testConstraint testnrelevels]} {
     namespace import testnre::*
 }
 
-#
-# Test atProcExit
-#
-
-test unsupported-A.1 {atProcExit works} -constraints {atProcExit} -setup {
-    variable x x y y
-    proc a {} {
-	variable x 0 y 0
-	atProcExit set ::x 1
-	set x 2
-	set y $x
-	set x 3
-    }
-    proc b {} a
-} -body {
-    list [b] $x $y 
-} -cleanup {
-    unset x y
-    rename a {}
-    rename b {}
-} -result {3 1 2}
-
-test unsupported-A.2 {atProcExit} -constraints {atProcExit} -setup {
-    variable x x y x
-    proc a {} {
-	variable x 0 y 0
-	atProcExit set ::x 1
-	set x 2
-	set y $x
-	set x 3
-    }
-} -body {
-    list [a] $x $y 
-} -cleanup {
-    unset x y
-    rename a {}
-} -result {3 1 2}
-
-test unsupported-A.3 {atProcExit} -constraints {atProcExit} -setup {
-    variable x x y y
-    proc a {} {
-	variable x 0 y 0
-	atProcExit lappend ::x 1
-	lappend x 2
-	atProcExit lappend ::x 3
-	lappend y $x
-	lappend x 4
-	return 5
-    }
-} -body {
-    list [a] $x $y 
-} -cleanup {
-    unset x y
-    rename a {}
-} -result {5 {0 2 4 3 1} {0 {0 2}}}
-
-test unsupported-A.4 {atProcExit errors} -constraints {atProcExit} -setup {
-    variable x x y y
-    proc a {} {
-	variable x 0 y 0
-	atProcExit lappend ::x 1
-	lappend x 2
-	atProcExit lappend ::x 3
-	lappend y $x
-	lappend x 4
-	error foo
-    }
-} -body {
-    list [a] $x $y 
-} -cleanup {
-    unset x y
-    rename a {}
-} -returnCodes error -result foo
-
-test unsupported-A.5 {atProcExit errors} -constraints {atProcExit} -setup {
-    variable x x y y
-    proc a {} {
-	variable x 0 y 0
-	atProcExit error foo
-	lappend x 2
-	atProcExit lappend ::x 3
-	lappend y $x
-	lappend x 4
-	return 5
-    }
-} -body {
-    list [a] $x $y 
-} -cleanup {
-    unset x y
-    rename a {}
-} -result {5 {0 2 4 3} {0 {0 2}}}
-
-test unsupported-A.6 {atProcExit errors} -constraints {atProcExit} -setup {
-    variable x x y y
-    proc a {} {
-	variable x 0 y 0
-	atProcExit lappend ::x 1
-	lappend x 2
-	atProcExit error foo
-	lappend y $x
-	lappend x 4
-	return 5
-    }
-} -body {
-    list [a] $x $y 
-} -cleanup {
-    unset x y
-    rename a {}
-} -result {5 {0 2 4} {0 {0 2}}}
-
-test unsupported-A.7 {atProcExit non-proc} -constraints {atProcExit} -body {
-    atProcExit set x 2
-    set x 1
-} -cleanup {
-    unset -nocomplain x
-} -match glob -result *atProcExit* -returnCodes error
-
-test unsupported-A.8 {atProcExit and eval} -constraints {knownBug atProcExit} -setup {
-    proc a {} {
-	eval atProcExit lappend ::x 2
-	set ::x 1
-    }
-} -body {
-    list [a] $::x
-} -cleanup {
-    unset -nocomplain ::x
-} -result {1 2}
-
-test unsupported-A9 {atProcExit and uplevel} -constraints {knownBug atProcExit} -setup {
-    proc a {} {
-	uplevel 1 [list atProcExit set ::x 2]
-	set ::x 1
-    }
-} -body {
-    list [a] $::x
-} -cleanup {
-    unset -nocomplain ::x
-} -result {1 2}
-
-
-#
-# Test tailcalls
-#
-
-test unsupported-T.0 {tailcall is constant space} -constraints testnrelevels -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} -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} -body {
-    namespace eval a [list tailcall set x 1]
-} -match glob -result *tailcall* -returnCodes error
-
-test unsupported-T.3 {tailcall falls off tebc} -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} -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} -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} -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} -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} -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} -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}
-
-test unsupported-T.10 {tailcall and eval} -constraints {knownBug atProcExit} -setup {
-    proc a {} {
-	eval [list tailcall lappend ::x 2]
-	set ::x 1
-    }
-} -body {
-    list [a] $::x
-} -cleanup {
-    unset -nocomplain ::x
-} -result {1 2}
-
-test unsupported-T.11 {tailcall and uplevel} -constraints {knownBug atProcExit} -setup {
-    proc a {} {
-	uplevel 1 [list tailcall set ::x 2]
-	set ::x 1
-    }
-} -body {
-    list [a] $::x
-} -cleanup {
-    unset -nocomplain ::x
-} -result {1 2}
-
-#
-#  Test both together
-#
-
-test unsupported-AT.1 {atProcExit and tailcall} -constraints {
-    atProcExit
-} -setup {
-    variable x x y y
-    proc a {} {
-	variable x 0 y 0
-	atProcExit lappend ::x 1
-	lappend x 2
-	atProcExit lappend ::x 3
-	tailcall lappend ::x 6
-	lappend y $x
-	lappend x 4
-	return 5
-    }
-} -body {
-    list [a] $x $y
-} -cleanup {
-    unset x y
-    rename a {}
-} -result {{0 2 3 1 6} {0 2 3 1 6} 0}
-
-#
-# Test coroutines
-#
-
 set lambda [list {{start 0} {stop 10}} {
     # init
     set i    $start
@@ -435,7 +69,7 @@ set lambda [list {{start 0} {stop 10}} {
 }]
 	
 
-test unsupported-C.1.1 {coroutine basic} -setup {
+test coroutine-1.1 {coroutine basic} -setup {
     coroutine foo ::apply $lambda
     set res {}
 } -body {
@@ -448,7 +82,7 @@ test unsupported-C.1.1 {coroutine basic} -setup {
     unset res
 } -result {0 10 20}
 
-test unsupported-C.1.2 {coroutine basic} -setup {
+test coroutine-1.2 {coroutine basic} -setup {
     coroutine foo ::apply $lambda 2 8
     set res {}
 } -body {
@@ -461,7 +95,7 @@ test unsupported-C.1.2 {coroutine basic} -setup {
     unset res
 } -result {16 24 32}
 
-test unsupported-C.1.3 {yield returns new arg} -setup {
+test coroutine-1.3 {yield returns new arg} -setup {
     set body {
 	# init
 	set i    $start
@@ -485,7 +119,7 @@ test unsupported-C.1.3 {yield returns new arg} -setup {
     unset res
 } -result {20 6 12}
 
-test unsupported-C.1.4 {yield in nested proc} -setup {
+test coroutine-1.4 {yield in nested proc} -setup {
     proc moo {} {
 	upvar 1 i i stop stop
 	yield [expr {$i*$stop}]
@@ -514,21 +148,21 @@ test unsupported-C.1.4 {yield in nested proc} -setup {
     unset body res
 } -result {0 10 20}
 
-test unsupported-C.1.5 {just yield} -body {
+test coroutine-1.5 {just yield} -body {
     coroutine foo yield
     list [foo] [catch foo msg] $msg
 } -cleanup {
     unset msg
 } -result {{} 1 {invalid command name "foo"}}
 
-test unsupported-C.1.6 {just yield} -body {
+test coroutine-1.6 {just yield} -body {
     coroutine foo [list yield]
     list [foo] [catch foo msg] $msg
 } -cleanup {
     unset msg
 } -result {{} 1 {invalid command name "foo"}}
 
-test unsupported-C.1.7 {yield in nested uplevel} -setup {
+test coroutine-1.7 {yield in nested uplevel} -setup {
     set body {
 	# init
 	set i    $start
@@ -552,7 +186,7 @@ test unsupported-C.1.7 {yield in nested uplevel} -setup {
     unset body res
 } -result {0 10 20}
 
-test unsupported-C.1.8 {yield in nested uplevel} -setup {
+test coroutine-1.8 {yield in nested uplevel} -setup {
     set body {
 	# init
 	set i    $start
@@ -576,7 +210,7 @@ test unsupported-C.1.8 {yield in nested uplevel} -setup {
     unset body res
 } -result {0 10 20}
 
-test unsupported-C.1.9 {yield in nested eval} -setup {
+test coroutine-1.9 {yield in nested eval} -setup {
     proc moo {} {
 	upvar 1 i i stop stop
 	yield [expr {$i*$stop}]
@@ -604,7 +238,7 @@ test unsupported-C.1.9 {yield in nested eval} -setup {
     unset body res
 } -result {0 10 20}
 
-test unsupported-C.1.10 {yield in nested eval} -setup {
+test coroutine-1.10 {yield in nested eval} -setup {
     set body {
 	# init
 	set i    $start
@@ -627,7 +261,7 @@ test unsupported-C.1.10 {yield in nested eval} -setup {
     unset body res
 } -result {0 10 20}
 
-test unsupported-C.1.11 {yield outside coroutine} -setup {
+test coroutine-1.11 {yield outside coroutine} -setup {
     proc moo {} {
 	upvar 1 i i stop stop
 	yield [expr {$i*$stop}]
@@ -640,7 +274,7 @@ test unsupported-C.1.11 {yield outside coroutine} -setup {
     unset i stop
 } -returnCodes error -result {yield can only be called in a coroutine}
 
-test unsupported-C.1.12 {proc as coroutine} -setup {
+test coroutine-1.12 {proc as coroutine} -setup {
     set body {
 	# init
 	set i    $start
@@ -662,37 +296,37 @@ test unsupported-C.1.12 {proc as coroutine} -setup {
     rename foo {}
 } -result {16 24}
 
-test unsupported-C.2.1 {self deletion on return} -body {
+test coroutine-2.1 {self deletion on return} -body {
     coroutine foo set x 3
     foo
 } -returnCodes error -result {invalid command name "foo"}
 
-test unsupported-C.2.2 {self deletion on return} -body {
+test coroutine-2.2 {self deletion on return} -body {
     coroutine foo ::apply [list {} {yield; yield 1; return 2}]
     list [foo] [foo] [catch foo msg] $msg
 } -result {1 2 1 {invalid command name "foo"}}
 
-test unsupported-C.2.3 {self deletion on error return} -body {
+test coroutine-2.3 {self deletion on error return} -body {
     coroutine foo ::apply [list {} {yield;yield 1; error ouch!}]
     list [foo] [catch foo msg] $msg [catch foo msg] $msg
 } -result {1 1 ouch! 1 {invalid command name "foo"}}
 
-test unsupported-C.2.4 {self deletion on other return} -body {
+test coroutine-2.4 {self deletion on other return} -body {
     coroutine foo ::apply [list {} {yield;yield 1; return -code 100 ouch!}]
     list [foo] [catch foo msg] $msg [catch foo msg] $msg
 } -result {1 100 ouch! 1 {invalid command name "foo"}}
 
-test unsupported-C.2.5 {deletion of suspended coroutine} -body {
+test coroutine-2.5 {deletion of suspended coroutine} -body {
     coroutine foo ::apply [list {} {yield; yield 1; return 2}]
     list [foo] [rename foo {}] [catch foo msg] $msg
 } -result {1 {} 1 {invalid command name "foo"}}
 
-test unsupported-C.2.6 {deletion of running coroutine} -body {
+test coroutine-2.6 {deletion of running coroutine} -body {
     coroutine foo ::apply [list {} {yield; rename foo {}; yield 1; return 2}]
     list [foo] [catch foo msg] $msg
 } -result {1 1 {invalid command name "foo"}}
 
-test unsupported-C.3.1 {info level computation} -setup {
+test coroutine-3.1 {info level computation} -setup {
     proc a {} {while 1 {yield [info level]}}
     proc b {} foo
 } -body {
@@ -706,7 +340,7 @@ test unsupported-C.3.1 {info level computation} -setup {
     rename b {}
 } -result {1 1 1}
 
-test unsupported-C.3.2 {info frame computation} -setup {
+test coroutine-3.2 {info frame computation} -setup {
     proc a {} {while 1 {yield [info frame]}}
     proc b {} foo
 } -body {
@@ -719,7 +353,7 @@ test unsupported-C.3.2 {info frame computation} -setup {
     rename b {}
 } -result 1
 
-test unsupported-C.3.3 {info coroutine} -setup {
+test coroutine-3.3 {info coroutine} -setup {
     proc a {} {info coroutine}
     proc b {} a
 } -body {
@@ -729,7 +363,7 @@ test unsupported-C.3.3 {info coroutine} -setup {
     rename b {}
 } -result {}
 
-test unsupported-C.3.4 {info coroutine} -setup {
+test coroutine-3.4 {info coroutine} -setup {
     proc a {} {info coroutine}
     proc b {} a
 } -body {
@@ -739,7 +373,7 @@ test unsupported-C.3.4 {info coroutine} -setup {
     rename b {}
 } -result ::foo
 
-test unsupported-C.3.5 {info coroutine} -setup {
+test coroutine-3.5 {info coroutine} -setup {
     proc a {} {info coroutine}
     proc b {} {rename [info coroutine] {}; a}
 } -body {
@@ -750,7 +384,7 @@ test unsupported-C.3.5 {info coroutine} -setup {
 } -result {}
 
 
-test unsupported-C.4.1 {bug #2093188} -setup {
+test coroutine-4.1 {bug #2093188} -setup {
     proc foo {} {
 	set v 1
 	trace add variable v {write unset} bar
@@ -769,7 +403,7 @@ test unsupported-C.4.1 {bug #2093188} -setup {
     unset ::res
 } -result {{} 3 {{v {} write} {v {} write} {v {} unset}}}
 
-test unsupported-C.4.2 {bug #2093188} -setup {
+test coroutine-4.2 {bug #2093188} -setup {
     proc foo {} {
 	set v 1
 	trace add variable v {read unset} bar
@@ -789,7 +423,7 @@ test unsupported-C.4.2 {bug #2093188} -setup {
     unset ::res
 } -result {{} 3 {{v {} read} {v {} unset}}}
 
-test unsupported-C.4.3 {bug #2093947} -setup {
+test coroutine-4.3 {bug #2093947} -setup {
     proc foo {} {
 	set v 1
 	trace add variable v {write unset} bar
@@ -813,7 +447,7 @@ test unsupported-C.4.3 {bug #2093947} -setup {
     unset ::res
 } -result {{v {} write} {v {} write} {v {} unset} {v {} write} {v {} unset}}
 
-test unsupported-C.5.1 {right numLevels on coro return} -constraints {testnrelevels} \
+test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels} \
 -setup {
     proc nestedYield {{val {}}} {
 	yield $val
@@ -856,7 +490,7 @@ test unsupported-C.5.1 {right numLevels on coro return} -constraints {testnrelev
     unset res
 } -result {0 0 0 0 0 0}
 
-test unsupported-C.5.2 {right numLevels within coro} -constraints {testnrelevels} \
+test coroutine-5.2 {right numLevels within coro} -constraints {testnrelevels} \
 -setup {
     proc nestedYield {{val {}}} {
 	yield $val
@@ -902,10 +536,6 @@ test unsupported-C.5.2 {right numLevels within coro} -constraints {testnrelevels
 
 unset -nocomplain lambda
 
-if {[testConstraint atProcExit]} {
-    namespace forget tcl::unsupported::atProcExit
-}
-
 if {[testConstraint testnrelevels]} {
     namespace forget testnre::*
     namespace delete testnre
diff --git a/tests/tailcall.test b/tests/tailcall.test
new file mode 100644
index 0000000..a3cf88e
--- /dev/null
+++ b/tests/tailcall.test
@@ -0,0 +1,428 @@
+# Commands covered:  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: tailcall.test,v 1.1 2009/03/19 23:31:37 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 tailcall-0 {tailcall is constant space} -constraints testnrelevels -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 tailcall-1 {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 tailcall-2 {tailcall in non-proc} -body {
+    namespace eval a [list tailcall set x 1]
+} -match glob -result *tailcall* -returnCodes error
+
+test tailcall-3 {tailcall falls off tebc} -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 tailcall-4 {tailcall falls off tebc} -body {
+    set x 2
+    proc foo {} {tailcall set x 1}
+    foo
+    set x
+} -cleanup {
+    rename foo {}
+    unset x
+} -result 1
+
+test tailcall-5 {tailcall falls off tebc} -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 tailcall-6 {tailcall does remove callframes} -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 tailcall-7 {tailcall does return} -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 tailcall-8 {tailcall 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 tailcall-9 {tailcall factorial} -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}
+
+test tailcall-10 {tailcall and eval} -constraints {knownBug} -setup {
+    proc a {} {
+	eval [list tailcall lappend ::x 2]
+	set ::x 1
+    }
+} -body {
+    list [a] $::x
+} -cleanup {
+    unset -nocomplain ::x
+} -result {1 2}
+
+test tailcall-11 {tailcall and uplevel} -constraints {knownBug} -setup {
+    proc a {} {
+	uplevel 1 [list tailcall set ::x 2]
+	set ::x 1
+    }
+} -body {
+    list [a] $::x
+} -cleanup {
+    unset -nocomplain ::x
+} -result {1 2}
+
+# cleanup
+::tcltest::cleanupTests
+
+
+test tailcall-12.1 {[Bug 2649975]} -setup {
+    proc dump {{text {}}} {
+	set text [uplevel 1 [list subst $text]]
+	set l [expr {[info level] -1}]
+	if {$text eq {}} {
+	    set text [info level $l]
+	}
+	puts "$l: $text"
+    }
+    # proc dump args {}
+    proc bravo {} {
+	upvar 1 v w
+	dump {inside bravo, v -> $w}
+	set v "procedure bravo"
+	#uplevel 1 [list delta ::betty]
+	uplevel 1 {delta ::betty}
+	return $::resolution
+    }
+    proc delta name {
+	upvar 1 v w
+	dump {inside delta, v -> $w}
+	set v "procedure delta"
+	tailcall foxtrot
+    }
+    proc foxtrot {} {
+	upvar 1 v w
+	dump {inside foxtrot, v -> $w}
+	global resolution
+	set ::resolution $w
+    }
+    set v "global level"
+} -body {
+    set result [bravo]
+    if {$result ne $v} {
+	puts "v should have been found at $v but was found in $result"
+    }
+} -cleanup {
+    unset v
+    rename dump {}
+    rename bravo {}
+    rename delta {}
+    rename foxtrot {}
+} -output {1: inside bravo, v -> global level
+1: inside delta, v -> global level
+1: inside foxtrot, v -> global level
+}
+
+test tailcall-12.2 {[Bug 2649975]} -setup {
+    proc dump {{text {}}} {
+	set text [uplevel 1 [list subst $text]]
+	set l [expr {[info level] -1}]
+	if {$text eq {}} {
+	    set text [info level $l]
+	}
+	puts "$l: $text"
+    }
+    # proc dump args {}
+    set v "global level"
+    oo::class create foo { # like connection
+	method alpha {} {  # like connections 'tables' method
+	    dump
+	    upvar 1 v w
+	    dump {inside foo's alpha, v resolves to $w}
+	    set v "foo's method alpha"
+	    dump {foo's alpha is calling [self] bravo - v should resolve at global level}
+	    set result [uplevel 1 [list [self] bravo]]
+	    dump {exiting from foo's alpha}
+	    return $result
+	}
+	method bravo {} {  # like connections 'foreach' method
+	    dump
+	    upvar 1 v w
+	    dump {inside foo's bravo, v resolves to $w}
+	    set v "foo's method bravo"
+	    dump {foo's bravo is calling charlie to create barney}
+	    set barney [my charlie ::barney]
+	    dump {foo's bravo is calling bravo on $barney}
+	    dump {v should resolve at global scope there}
+	    set result [uplevel 1 [list $barney bravo]]
+	    dump {exiting from foo's bravo}
+	    return $result
+	}
+	method charlie {name} {  # like tdbc prepare
+	    dump
+	    set v "foo's method charlie"
+	    dump {tailcalling bar's constructor}
+	    tailcall ::bar create $name
+	}
+    }
+    oo::class create bar { # like statement
+	method  bravo {} {   # like statement foreach method
+	    dump
+	    upvar 1 v w
+	    dump {inside bar's bravo, v is resolving to $w}
+	    set v "bar's method bravo"
+	    dump {calling delta to construct betty - v should resolve global there}
+	    uplevel 1 [list [self] delta ::betty]
+	    dump {exiting from bar's bravo}
+	    return [::betty whathappened]
+	}
+	method delta {name} {    # like statement execute method
+	    dump
+	    upvar 1 v w
+	    dump {inside bar's delta, v is resolving to $w}
+	    set v "bar's method delta"
+	    dump {tailcalling to construct $name as instance of grill}
+	    dump {v should resolve at global level in grill's constructor}
+	    dump {grill's constructor should run at level [info level]}
+	    tailcall grill create $name
+	}
+    }
+    oo::class create grill {
+	variable resolution
+	constructor {} {
+	    dump
+	    upvar 1 v w
+	    dump "in grill's constructor, v resolves to $w"
+	    set resolution $w
+	}
+	method whathappened {} {
+	    return $resolution
+	}
+    }
+    foo create fred
+} -body {
+    set result [fred alpha]
+    if {$result ne "global level"} {
+	puts "v should have been found at global level but was found in $result"
+    }
+} -cleanup {
+    unset result
+    rename fred {}
+    rename dump {}
+    rename foo {}
+    rename bar {}
+    rename grill {}
+} -output {1: fred alpha
+1: inside foo's alpha, v resolves to global level
+1: foo's alpha is calling ::fred bravo - v should resolve at global level
+1: ::fred bravo
+1: inside foo's bravo, v resolves to global level
+1: foo's bravo is calling charlie to create barney
+2: my charlie ::barney
+2: tailcalling bar's constructor
+1: foo's bravo is calling bravo on ::barney
+1: v should resolve at global scope there
+1: ::barney bravo
+1: inside bar's bravo, v is resolving to global level
+1: calling delta to construct betty - v should resolve global there
+1: ::barney delta ::betty
+1: inside bar's delta, v is resolving to global level
+1: tailcalling to construct ::betty as instance of grill
+1: v should resolve at global level in grill's constructor
+1: grill's constructor should run at level 1
+1: grill create ::betty
+1: in grill's constructor, v resolves to global level
+1: exiting from bar's bravo
+1: exiting from foo's bravo
+1: exiting from foo's alpha
+}
+
+test tailcall-12.3 {[Bug 2695587]} -setup {
+    proc a {} {
+	list [catch {tailcall foo} msg] $msg
+    }
+} -body {
+    a
+} -cleanup {
+    rename a {}
+} -result {1 {Tailcall called from within a catch environment}}
+
+
+if {[testConstraint testnrelevels]} {
+    namespace forget testnre::*
+    namespace delete testnre
+}
+
+# cleanup
+::tcltest::cleanupTests