diff options
Diffstat (limited to 'tests/coroutine.test')
| -rw-r--r-- | tests/coroutine.test | 228 |
1 files changed, 222 insertions, 6 deletions
diff --git a/tests/coroutine.test b/tests/coroutine.test index c60b568..c3023f7 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -4,7 +4,7 @@ # 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. +# 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. @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testnrelevels [llength [info commands testnrelevels]] testConstraint memory [llength [info commands memory]] @@ -755,6 +755,77 @@ test coroutine-7.12 {coro floor above street level #3008307} -body { 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 + yieldto try {yieldto c1} on error {} [list after 0 [list [info coroutine]]] + yieldto try {yieldto c1} on error {} [list after 0 [list [info coroutine]]] + 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 + after 0 [list [namespace which c1]] + vwait [namespace current]::done1 + } [namespace current]] + + coroutine c1 ::apply [list {} { + variable done1 + yield + yieldto try "yieldto [list [info coroutine]]" on error {} " + ::set [list [namespace current]]::done1 failure + ::set [list [namespace current]]::done0 failure + " + set done1 success + + } [namespace current]] + after 1 [list [namespace which c0]] + vwait [namespace current]::done0 + if {[namespace which [namespace current]::c1] ne {}} { + # prior to the fix for 5106fddd4400e5b9, the nested yieldto turned into a + # tailcall which was eventutally activated, causing control to return to + # c1. After the fix, that doesn't happen, so if c1 still exists call it + # one final time to allow it to finish and clean up + rename c1 {} + } + 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 @@ -793,7 +864,152 @@ test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { set result } -result {inject-executed} -test coroutine-9.1 {coro type} { +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" @@ -803,19 +1019,19 @@ test coroutine-9.1 {coro type} { list [demo] [::tcl::unsupported::corotype demo] \ [demo] [::tcl::unsupported::corotype demo] [demo] } {{PHASE 1} yield {PHASE 2} yieldto active} -test coroutine-9.2 {coro type} -setup { +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-9.3 {coro type} -returnCodes error -body { +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-10.1 {coroutine general introspection} -setup { +test coroutine-12.1 {coroutine general introspection} -setup { set i [interp create] } -body { $i eval { |