diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/coroutine.test (renamed from tests/unsupported.test) | 430 | ||||
| -rw-r--r-- | tests/tailcall.test | 428 |
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 |