diff options
Diffstat (limited to 'tcl8.6/tests/coroutine.test')
| -rw-r--r-- | tcl8.6/tests/coroutine.test | 753 |
1 files changed, 0 insertions, 753 deletions
diff --git a/tcl8.6/tests/coroutine.test b/tcl8.6/tests/coroutine.test deleted file mode 100644 index 205da67..0000000 --- a/tcl8.6/tests/coroutine.test +++ /dev/null @@ -1,753 +0,0 @@ -# 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: |