path: root/tests/coroutine.test

# Commands covered:  coroutine, yield, [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.
#
# RCS: @(#) $Id: coroutine.test,v 1.1 2009/03/19 23:31:37 msofer Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint testnrelevels [llength [info commands testnrelevels]]

if {[testConstraint testnrelevels]} {
    namespace eval testnre {
	#
	# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
	# cmdFrame level, callFrame level, tosPtr and callback depth 
	#
	variable last [testnrelevels] 
	proc depthDiff {} {
	    variable last
	    set depth [testnrelevels]
	    set res {}
	    foreach t $depth l $last {
		lappend res [expr {$t-$l}]
	    }
	    set last $depth
	    return $res
	}
	proc setabs {} {
	    uplevel 1 variable abs -[lindex [testnrelevels] 0]
	}

	variable body0 {
	    set x [depthDiff]
	    if {[incr i] > 10} {
		variable abs
		incr abs [lindex [testnrelevels] 0]
		return [list [lrange $x 0 3] $abs]
	    }
	}
	proc makebody txt {
	    variable body0
	    return "$body0; $txt"
	}
	namespace export *
    }
    namespace import testnre::*
}

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-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-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-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}



# cleanup
::tcltest::cleanupTests


unset -nocomplain lambda

if {[testConstraint testnrelevels]} {
    namespace forget testnre::*
    namespace delete testnre
}

return