undo subtree

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: