summaryrefslogtreecommitdiffstats
path: root/tests/coroutine.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/coroutine.test')
-rw-r--r--tests/coroutine.test792
1 files changed, 792 insertions, 0 deletions
diff --git a/tests/coroutine.test b/tests/coroutine.test
new file mode 100644
index 0000000..07feb53
--- /dev/null
+++ b/tests/coroutine.test
@@ -0,0 +1,792 @@
+# 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 {}
+
+test coroutine-8.0.0 {coro inject executed} -body {
+ coroutine demo apply {{} { foreach i {1 2} yield }}
+ demo
+ set ::result none
+ tcl::unsupported::inject demo set ::result inject-executed
+ demo
+ set ::result
+} -result {inject-executed}
+test coroutine-8.0.1 {coro inject after error} -body {
+ coroutine demo apply {{} { foreach i {1 2} yield; error test }}
+ demo
+ set ::result none
+ tcl::unsupported::inject demo set ::result inject-executed
+ lappend ::result [catch {demo} err] $err
+} -result {inject-executed 1 test}
+test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body {
+ interp create slave
+ slave eval {
+ coroutine demo apply {{} { while {1} yield }}
+ demo
+ tcl::unsupported::inject demo set ::result inject-executed
+ }
+ interp delete slave
+} -result {}
+test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body {
+ interp create slave
+ slave eval {
+ coroutine demo apply {{} { while {1} yield }}
+ demo
+ tcl::unsupported::inject demo set ::result inject-executed
+ }
+ slave eval demo
+ set result [slave eval {set ::result}]
+
+ interp delete slave
+ set result
+} -result {inject-executed}
+
+
+
+# cleanup
+unset lambda
+::tcltest::cleanupTests
+
+return
+
+# Local Variables:
+# mode: tcl
+# End:
generated by cgit v0.12 at 2024-06-29 01:07:12 (GMT)