diff options
Diffstat (limited to 'tcl8.6/tests/coroutine.test')
| -rw-r--r-- | tcl8.6/tests/coroutine.test | 753 |
1 files changed, 753 insertions, 0 deletions
diff --git a/tcl8.6/tests/coroutine.test b/tcl8.6/tests/coroutine.test new file mode 100644 index 0000000..205da67 --- /dev/null +++ b/tcl8.6/tests/coroutine.test @@ -0,0 +1,753 @@ +# Commands covered: coroutine, yield, yieldto, [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 +# 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. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +testConstraint testnrelevels [llength [info commands testnrelevels]] +testConstraint memory [llength [info commands memory]] + +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 coroutine-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 coroutine-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 coroutine-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 coroutine-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 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 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 coroutine-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 coroutine-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 coroutine-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 coroutine-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 coroutine-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 coroutine-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 coroutine-1.13 {subst as coroutine: literal} { + list [coroutine foo eval {subst {>>[yield a],[yield b]<<}}] [foo x] [foo y] +} {a b >>x,y<<} +test coroutine-1.14 {subst as coroutine: in variable} { + set pattern {>>[yield c],[yield d]<<} + list [coroutine foo eval {subst $pattern}] [foo p] [foo q] +} {c d >>p,q<<} + +test coroutine-2.1 {self deletion on return} -body { + coroutine foo set x 3 + foo +} -returnCodes error -result {invalid command name "foo"} +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 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 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 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 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 coroutine-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 coroutine-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 coroutine-3.3 {info coroutine} -setup { + proc a {} {info coroutine} + proc b {} a +} -body { + b +} -cleanup { + rename a {} + rename b {} +} -result {} +test coroutine-3.4 {info coroutine} -setup { + proc a {} {info coroutine} + proc b {} a +} -body { + coroutine foo b +} -cleanup { + rename a {} + rename b {} +} -result ::foo +test coroutine-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 coroutine-3.6 {info frame, bug #2910094} -setup { + proc stack {} { + set res [list "LEVEL:[set lev [info frame]]"] + for {set i 1} {$i < $lev} {incr i} { + lappend res [info frame $i] + } + set res + # the precise command depends on line numbers and such, is likely not + # to be stable: just check that the test completes! + return + } + proc a {} stack +} -body { + coroutine aa a +} -cleanup { + rename stack {} + rename a {} +} -result {} +test coroutine-3.7 {bug 0b874c344d} { + dict get [coroutine X coroutine Y info frame 0] cmd +} {coroutine X coroutine Y info frame 0} + +test coroutine-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 coroutine-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 coroutine-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 coroutine-4.4 {bug #2917627: cmd resolution} -setup { + proc a {} {return global} + namespace eval b {proc a {} {return local}} +} -body { + namespace eval b {coroutine foo a} +} -cleanup { + rename a {} + namespace delete b +} -result local + +test coroutine-4.5 {bug #2724403} -constraints {memory} \ +-setup { + proc getbytes {} { + set lines [split [memory info] "\n"] + lindex $lines 3 3 + } +} -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + set ns ::y$i + namespace eval $ns {} + proc ${ns}::start {} {yield; puts hello} + coroutine ${ns}::run ${ns}::start + namespace delete $ns + set start $end + set end [getbytes] + } + set leakedBytes [expr {$end - $start}] +} -cleanup { + rename getbytes {} + unset i ns start end +} -result 0 + +test coroutine-4.6 {compile context, bug #3282869} -setup { + unset -nocomplain ::x + proc f x { + coroutine D eval {yield X$x;yield Y} + } +} -body { + f 12 +} -cleanup { + rename f {} +} -returnCodes error -match glob -result {can't read *} + +test coroutine-4.7 {compile context, bug #3282869} -setup { + proc f x { + coroutine D eval {yield X$x;yield Y$x} + } +} -body { + set ::x 15 + set ::x [f 12] + D +} -cleanup { + D + unset ::x + rename f {} +} -result YX15 + +test coroutine-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 coroutine-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} + +test coroutine-6.1 {coroutine nargs} -body { + coroutine a ::apply $lambda + a +} -cleanup { + rename a {} +} -result 0 +test coroutine-6.2 {coroutine nargs} -body { + coroutine a ::apply $lambda + a a +} -cleanup { + rename a {} +} -result 0 +test coroutine-6.3 {coroutine nargs} -body { + coroutine a ::apply $lambda + a a a +} -cleanup { + rename a {} +} -returnCodes error -result {wrong # args: should be "a ?arg?"} + +test coroutine-7.1 {yieldto} -body { + coroutine c apply {{} { + yield + yieldto return -level 0 -code 1 quux + return quuy + }} + set res [list [catch c msg] $msg] + lappend res [catch c msg] $msg + lappend res [catch c msg] $msg +} -cleanup { + unset res +} -result [list 1 quux 0 quuy 1 {invalid command name "c"}] +test coroutine-7.2 {multi-argument yielding with yieldto} -body { + proc corobody {} { + set a 1 + while 1 { + set a [yield $a] + set a [yieldto return -level 0 $a] + lappend a [llength $a] + } + } + coroutine a corobody + coroutine b corobody + list [a x] [a y z] [a \{p] [a \{q r] [a] [a] [rename a {}] \ + [b ok] [rename b {}] +} -cleanup { + rename corobody {} +} -result {x {y z 2} \{p {\{q r 2} {} 0 {} ok {}} +test coroutine-7.3 {yielding between coroutines} -body { + proc juggler {target {value ""}} { + if {$value eq ""} { + set value [yield [info coroutine]] + } + while {[llength $value]} { + lappend ::result $value [info coroutine] + set value [lrange $value 0 end-1] + lassign [yieldto $target $value] value + } + # Clear nested collection of coroutines + catch $target + } + set result "" + coroutine j1 juggler [coroutine j2 juggler [coroutine j3 juggler j1]]\ + {a b c d e} + list $result [info command j1] [info command j2] [info command j3] +} -cleanup { + catch {rename juggler ""} +} -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}} +test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { + proc foo {a b} {catch yield; return 1} +} -cleanup { + rename foo {} +} -body { + coroutine demo lsort -command foo {a b} +} -result {b a} +test coroutine-7.5 {return codes} { + set result {} + foreach code {0 1 2 3 4 5} { + lappend result [catch {coroutine demo return -level 0 -code $code}] + } + set result +} {0 1 2 3 4 5} +test coroutine-7.6 {Early yield crashes} { + proc foo args {} + trace add execution foo enter {catch yield} + coroutine demo foo + rename foo {} +} {} +test coroutine-7.7 {Bug 2486550} -setup { + interp hide {} yield +} -body { + coroutine demo interp invokehidden {} yield ok +} -cleanup { + demo + interp expose {} yield +} -result ok +test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + lappend ::result a + yield OUT + lappend ::result b + yieldto ::return -level 0 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + namespace delete cotest + namespace eval cotest {} + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.9 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + set y ::yieldto + lappend ::result a + yield OUT + lappend ::result b + $y ::return -level 0 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + namespace delete cotest + namespace eval cotest {} + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.10 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + lappend ::result a + yield OUT + lappend ::result b + yieldto ::return -level 0 -cotest [namespace delete ::cotest] 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + set y ::yieldto + lappend ::result a + yield OUT + lappend ::result b + $y ::return -level 0 -cotest [namespace delete ::cotest] 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.12 {coro floor above street level #3008307} -body { + proc c {} { + yield + } + proc cc {} { + coroutine C c + } + proc boom {} { + cc ; # coro created at level 2 + C ; # and called at level 1 + } + boom ; # does not crash: the coro floor is a good insulator + list +} -result {} + + +# cleanup +unset lambda +::tcltest::cleanupTests + +return + +# Local Variables: +# mode: tcl +# End: |