diff options
Diffstat (limited to 'tests/unsupported.test')
-rw-r--r-- | tests/unsupported.test | 914 |
1 files changed, 914 insertions, 0 deletions
diff --git a/tests/unsupported.test b/tests/unsupported.test new file mode 100644 index 0000000..0c706b8 --- /dev/null +++ b/tests/unsupported.test @@ -0,0 +1,914 @@ +# Commands covered: tailcall, atProcExit, coroutine, yield +# +# 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.15 2008/10/14 18:49:47 dgp Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +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 { + # + # [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 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 + set imax $stop + yield + + while {$i < $imax} { + yield [expr {$i*$stop}] + incr i + } +}] + + +test unsupported-C.1.1 {coroutine basic} -setup { + coroutine foo ::apply $lambda + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo] + } + set res +} -cleanup { + rename foo {} + unset res +} -result {0 10 20} + +test unsupported-C.1.2 {coroutine basic} -setup { + coroutine foo ::apply $lambda 2 8 + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo] + } + set res +} -cleanup { + rename foo {} + unset res +} -result {16 24 32} + +test unsupported-C.1.3 {yield returns new arg} -setup { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + set stop [yield [expr {$i*$stop}]] + incr i + } + } + coroutine foo ::apply [list {{start 2} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo $k] + } + set res +} -cleanup { + rename foo {} + unset res +} -result {20 6 12} + +test unsupported-C.1.4 {yield in nested proc} -setup { + proc moo {} { + upvar 1 i i stop stop + yield [expr {$i*$stop}] + } + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + moo + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo $k] + } + set res +} -cleanup { + rename foo {} + rename moo {} + unset body res +} -result {0 10 20} + +test unsupported-C.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 { + 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 { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + uplevel 0 [list yield [expr {$i*$stop}]] + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [eval foo $k] + } + set res +} -cleanup { + rename foo {} + unset body res +} -result {0 10 20} + +test unsupported-C.1.8 {yield in nested uplevel} -setup { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + uplevel 0 yield [expr {$i*$stop}] + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [eval foo $k] + } + set res +} -cleanup { + rename foo {} + unset body res +} -result {0 10 20} + +test unsupported-C.1.9 {yield in nested eval} -setup { + proc moo {} { + upvar 1 i i stop stop + yield [expr {$i*$stop}] + } + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + eval moo + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo $k] + } + set res +} -cleanup { + rename moo {} + unset body res +} -result {0 10 20} + +test unsupported-C.1.10 {yield in nested eval} -setup { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + eval yield [expr {$i*$stop}] + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [eval foo $k] + } + set res +} -cleanup { + unset body res +} -result {0 10 20} + +test unsupported-C.1.11 {yield outside coroutine} -setup { + proc moo {} { + upvar 1 i i stop stop + yield [expr {$i*$stop}] + } +} -body { + variable i 5 stop 6 + moo +} -cleanup { + rename moo {} + unset i stop +} -returnCodes error -result {yield can only be called in a coroutine} + +test unsupported-C.1.12 {proc as coroutine} -setup { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + uplevel 0 [list yield [expr {$i*$stop}]] + incr i + } + } + proc moo {{start 0} {stop 10}} $body + coroutine foo moo 2 8 +} -body { + list [foo] [foo] +} -cleanup { + unset body + rename moo {} + rename foo {} +} -result {16 24} + +test unsupported-C.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 { + 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 { + 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 { + 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 { + 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 { + 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 { + proc a {} {while 1 {yield [info level]}} + proc b {} foo +} -body { + # note that coroutines execute in uplevel #0 + set l0 [coroutine foo a] + set l1 [foo] + set l2 [b] + list $l0 $l1 $l2 +} -cleanup { + rename a {} + rename b {} +} -result {1 1 1} + +test unsupported-C.3.2 {info frame computation} -setup { + proc a {} {while 1 {yield [info frame]}} + proc b {} foo +} -body { + set l0 [coroutine foo a] + set l1 [foo] + set l2 [b] + expr {$l2 - $l1} +} -cleanup { + rename a {} + rename b {} +} -result 1 + +test unsupported-C.3.3 {info coroutine} -setup { + proc a {} {info coroutine} + proc b {} a +} -body { + b +} -cleanup { + rename a {} + rename b {} +} -result {} + +test unsupported-C.3.4 {info coroutine} -setup { + proc a {} {info coroutine} + proc b {} a +} -body { + coroutine foo b +} -cleanup { + rename a {} + rename b {} +} -result ::foo + +test unsupported-C.3.5 {info coroutine} -setup { + proc a {} {info coroutine} + proc b {} {rename [info coroutine] {}; a} +} -body { + coroutine foo b +} -cleanup { + rename a {} + rename b {} +} -result {} + + +test unsupported-C.4.1 {bug #2093188} -setup { + proc foo {} { + set v 1 + trace add variable v {write unset} bar + yield + set v 2 + yield + set v 3 + } + proc bar args {lappend ::res $args} + coroutine a foo +} -body { + list [a] [a] $::res +} -cleanup { + rename foo {} + rename bar {} + unset ::res +} -result {{} 3 {{v {} write} {v {} write} {v {} unset}}} + +test unsupported-C.4.2 {bug #2093188} -setup { + proc foo {} { + set v 1 + trace add variable v {read unset} bar + yield + set v 2 + set v + yield + set v 3 + } + proc bar args {lappend ::res $args} + coroutine a foo +} -body { + list [a] [a] $::res +} -cleanup { + rename foo {} + rename bar {} + unset ::res +} -result {{} 3 {{v {} read} {v {} unset}}} + +test unsupported-C.4.3 {bug #2093947} -setup { + proc foo {} { + set v 1 + trace add variable v {write unset} bar + yield + set v 2 + yield + set v 3 + } + proc bar args {lappend ::res $args} +} -body { + coroutine a foo + a + a + coroutine a foo + a + rename a {} + set ::res +} -cleanup { + rename foo {} + rename bar {} + 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} \ +-setup { + proc nestedYield {{val {}}} { + yield $val + } + proc getNumLevel {} { + # remove the level for this proc's call + expr {[lindex [testnrelevels] 1] - 1} + } + proc relativeLevel base { + # remove the level for this proc's call + expr {[getNumLevel] - $base - 1} + } + proc foo {} { + while 1 { + nestedYield + } + } + set res {} +} -body { + set base [getNumLevel] + lappend res [relativeLevel $base] + eval {coroutine a foo} + + # back to base level + lappend res [relativeLevel $base] + a + lappend res [relativeLevel $base] + eval a + lappend res [relativeLevel $base] + eval {eval a} + lappend res [relativeLevel $base] + rename a {} + lappend res [relativeLevel $base] + set res +} -cleanup { + rename foo {} + rename nestedYield {} + rename getNumLevel {} + rename relativeLevel {} + unset res +} -result {0 0 0 0 0 0} + +test unsupported-C.5.2 {right numLevels within coro} -constraints {testnrelevels} \ +-setup { + proc nestedYield {{val {}}} { + yield $val + } + proc getNumLevel {} { + # remove the level for this proc's call + expr {[lindex [testnrelevels] 1] - 1} + } + proc relativeLevel base { + # remove the level for this proc's call + expr {[getNumLevel] - $base - 1} + } + proc foo base { + while 1 { + set base [nestedYield [relativeLevel $base]] + } + } + set res {} +} -body { + lappend res [eval {coroutine a foo [getNumLevel]}] + lappend res [a [getNumLevel]] + lappend res [eval {a [getNumLevel]}] + lappend res [eval {eval {a [getNumLevel]}}] + set base [lindex $res 0] + foreach x $res[set res {}] { + lappend res [expr {$x-$base}] + } + set res +} -cleanup { + rename a {} + rename foo {} + rename nestedYield {} + rename getNumLevel {} + rename relativeLevel {} + unset res +} -result {0 0 0 0} + + + +# cleanup +::tcltest::cleanupTests + + +unset -nocomplain lambda + +if {[testConstraint atProcExit]} { + namespace forget tcl::unsupported::atProcExit +} + +if {[testConstraint testnrelevels]} { + namespace forget testnre::* + namespace delete testnre +} + +return |