# 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 © 2008 Miguel Sofer. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [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} -setup { set i [interp create] } -body { # Force into a child interpreter [bug 60559fd4a6] $i eval { proc foo args {} trace add execution foo enter {catch yield} coroutine demo foo rename foo {} return ok } } -cleanup { interp delete $i } -result ok test coroutine-7.7 {Bug 2486550} -setup { set i [interp create] $i hide yield } -body { # Force into a child interpreter [bug 60559fd4a6] $i eval { coroutine demo interp invokehidden {} yield ok } } -cleanup { $i eval demo interp delete $i } -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 } -cleanup { rename boom {}; rename cc {}; rename c {} } -result {} test coroutine-7.13 { issue f9800d52bd61f240 vwait is not NRE-enabled, and yieldto cannot find the right splicing spot } -body { coroutine c0 apply [list {} { variable done yield yieldto c1 after 0 c2 vwait [namespace current]::done } [namespace current]] coroutine c1 apply [list {} { yield tailcall c0 } [namespace current]] coroutine c2 apply [list {} { variable done yield after 0 [list [info coroutine]] yieldto try {yieldto c1} after 0 [list [info coroutine]] yieldto try {yieldto c1} set done 1 } [namespace current]] after 0 [list [namespace which c0]] vwait [namespace current]::done return $done } -result 1 test coroutine-7.14 { issue 5106fddd4400e5b9 failure to yieldto is not the same thing as not calling yieldto in the first place } -body { variable done variable done1 coroutine c0 ::apply [list {} { yield variable done0 after 0 [list [namespace which c1]] vwait [namespace current]::done0 } [namespace current]] coroutine c1 ::apply [list {} { variable done0 yield yieldto try "yieldto [list [info coroutine]]" on error {} " ::set [list [namespace current]]::done1 failure ::set [list [namespace current]]::done0 failure " set done0 success } [namespace current]] after 1 [list [namespace which c0]] vwait [namespace current]::done0 return [list $done0 $done1] } -result {failure failure} 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 child child eval { coroutine demo apply {{} { while {1} yield }} demo tcl::unsupported::inject demo set ::result inject-executed } interp delete child } -result {} test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { interp create child child eval { coroutine demo apply {{} { while {1} yield }} demo tcl::unsupported::inject demo set ::result inject-executed } child eval demo set result [child eval {set ::result}] interp delete child set result } -result {inject-executed} test coroutine-9.1 {coroprobe with yield} -body { coroutine demo apply {{} { foreach i {1 2} yield }} list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo] } -cleanup { catch {rename demo {}} } -result {1 {} 2 {}} test coroutine-9.2 {coroprobe with yieldto} -body { coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }} list [coroprobe demo set i] [demo a b] [coroprobe demo set i] [demo c d] } -cleanup { catch {rename demo {}} } -result {1 {} 2 {{a b} {c d}}} test coroutine-9.3 {coroprobe errors} -setup { catch {rename demo {}} } -body { coroprobe demo set i } -returnCodes error -result {can only inject a probe command into a coroutine} test coroutine-9.4 {coroprobe errors} -body { proc demo {} { foreach i {1 2} yield } coroprobe demo set i } -returnCodes error -cleanup { catch {rename demo {}} } -result {can only inject a probe command into a coroutine} test coroutine-9.5 {coroprobe errors} -body { coroutine demo apply {{} { foreach i {1 2} yield }} coroprobe } -returnCodes error -cleanup { catch {rename demo {}} } -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"} test coroutine-9.6 {coroprobe errors} -body { coroutine demo apply {{} { foreach i {1 2} yield }} coroprobe demo } -returnCodes error -cleanup { catch {rename demo {}} } -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"} test coroutine-9.7 {coroprobe errors in probe command} -body { coroutine demo apply {{} { foreach i {1 2} yield }} coroprobe demo set } -returnCodes error -cleanup { catch {rename demo {}} } -result {wrong # args: should be "set varName ?newValue?"} test coroutine-9.8 {coroprobe errors in probe command} -body { coroutine demo apply {{} { foreach i {1 2} yield }} list [catch {coroprobe demo set}] [demo] [coroprobe demo set i] } -cleanup { catch {rename demo {}} } -result {1 {} 2} test coroutine-9.9 {coroprobe: advanced features} -setup { set i [interp create] } -body { $i eval { coroutine demo apply {{} { set f [info level],[info frame] foreach i {1 2} yield }} coroprobe demo apply {{} { upvar 1 f f list [info coroutine] [info level] [info frame] $f }} } } -cleanup { interp delete $i } -result {::demo 2 3 1,2} test coroutine-10.1 {coroinject with yield} -setup { set result {} } -body { coroutine demo apply {{} { lmap i {1 2} yield }} coroinject demo apply {{op val} {lappend ::result $op $val}} list $result [demo x] [demo y] $result } -cleanup { catch {rename demo {}} } -result {{} {} {{yield x} y} {yield x}} test coroutine-10.2 {coroinject stacking} -setup { set result {} } -body { coroutine demo apply {{} { lmap i {1 2} yield }} coroinject demo apply {{op val} {lappend ::result $op $val A;return $val}} coroinject demo apply {{op val} {lappend ::result $op $val B;return $val}} list $result [demo x] [demo y] $result } -cleanup { catch {rename demo {}} } -result {{} {} {x y} {yield x B yield x A}} test coroutine-10.3 {coroinject with yieldto} -setup { set result {} } -body { coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }} coroinject demo apply {{op val} {lappend ::result $op $val;return $val}} list $result [demo x mp] [demo y le] $result } -cleanup { catch {rename demo {}} } -result {{} {} {{x mp} {y le}} {yieldto {x mp}}} test coroutine-10.4 {coroinject errors} -setup { catch {rename demo {}} } -body { coroinject demo set i } -returnCodes error -result {can only inject a command into a coroutine} test coroutine-10.5 {coroinject errors} -body { proc demo {} { foreach i {1 2} yield } coroinject demo set i } -returnCodes error -cleanup { catch {rename demo {}} } -result {can only inject a command into a coroutine} test coroutine-10.6 {coroinject errors} -body { coroutine demo apply {{} { foreach i {1 2} yield }} coroinject } -returnCodes error -cleanup { catch {rename demo {}} } -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"} test coroutine-10.7 {coroinject errors} -body { coroutine demo apply {{} { foreach i {1 2} yield }} coroinject demo } -returnCodes error -cleanup { catch {rename demo {}} } -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"} test coroutine-10.8 {coroinject errors in injected command} -body { coroutine demo apply {{} { foreach i {1 2} yield }} coroinject demo apply {args {error "ERR: $args"}} list [catch demo msg] $msg [catch demo msg] $msg } -cleanup { catch {rename demo {}} } -result {1 {ERR: yield {}} 1 {invalid command name "demo"}} test coroutine-10.9 {coroinject: advanced features} -setup { set i [interp create] } -body { $i eval { coroutine demo apply {{} { set l [info level] set f [info frame] lmap i {1 2} yield }} coroinject demo apply {{arg op val} { global result upvar 1 f f l l lappend result [info coroutine] $arg $op $val lappend result [info level] $l [info frame] $f lappend result [yield $arg] return [string toupper $val] }} grill list [demo ABC] [demo pqr] [demo def] $result } } -cleanup { interp delete $i } -result {grill {} {ABC def} {::demo grill yield ABC 2 1 3 2 pqr}} test coroutine-11.1 {coro type} { coroutine demo eval { yield yield "PHASE 1" yieldto string cat "PHASE 2" ::tcl::unsupported::corotype [info coroutine] } list [demo] [::tcl::unsupported::corotype demo] \ [demo] [::tcl::unsupported::corotype demo] [demo] } {{PHASE 1} yield {PHASE 2} yieldto active} test coroutine-11.2 {coro type} -setup { catch {rename nosuchcommand ""} } -returnCodes error -body { ::tcl::unsupported::corotype nosuchcommand } -result {can only get coroutine type of a coroutine} test coroutine-11.3 {coro type} -returnCodes error -body { proc notacoroutine {} {} ::tcl::unsupported::corotype notacoroutine } -returnCodes error -cleanup { rename notacoroutine {} } -result {can only get coroutine type of a coroutine} test coroutine-12.1 {coroutine general introspection} -setup { set i [interp create] } -body { $i eval { # Make the introspection code namespace path tcl::unsupported proc probe {type var} { upvar 1 $var v set f [info frame] incr f -1 set result [list $v [dict get [info frame $f] proc]] if {$type eq "yield"} { tailcall yield $result } else { tailcall yieldto string cat $result } } proc pokecoro {c var} { inject $c probe [corotype $c] $var $c } # Coroutine implementations proc cbody1 {} { set val [info coroutine] set accum {} while {[set val [yield $val]] ne ""} { lappend accum $val set val ok } return $accum } proc cbody2 {} { set val [info coroutine] set accum {} while {[llength [set val [yieldto string cat $val]]]} { lappend accum {*}$val set val ok } return $accum } # Make the coroutines coroutine c1 cbody1 coroutine c2 cbody2 list [c1 abc] [c2 1 2 3] [pokecoro c1 accum] [pokecoro c2 accum] \ [c1 def] [c2 4 5 6] [pokecoro c1 accum] [pokecoro c2 accum] \ [c1] [c2] } } -cleanup { interp delete $i } -result {ok ok {abc ::cbody1} {{1 2 3} ::cbody2} ok ok {{abc def} ::cbody1} {{1 2 3 4 5 6} ::cbody2} {abc def} {1 2 3 4 5 6}} # cleanup unset lambda ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: