util/src/TclTk/tcl8.6.12/tests/coroutine.test

   1 # Commands covered:  coroutine, yield, yieldto, [info coroutine]
   2 #
   3 # This file contains a collection of tests for experimental commands that are
   4 # found in ::tcl::unsupported. The tests will migrate to normal test files
   5 # if/when the commands find their way into the core.
   6 #
   7 # Copyright (c) 2008 by Miguel Sofer.
   8 #
   9 # See the file "license.terms" for information on usage and redistribution
  10 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11
  12 if {"::tcltest" ni [namespace children]} {
  13     package require tcltest 2.5
  14     namespace import -force ::tcltest::*
  15 }
  16
  17 ::tcltest::loadTestedCommands
  18 catch [list package require -exact Tcltest [info patchlevel]]
  19
  20 testConstraint testnrelevels [llength [info commands testnrelevels]]
  21 testConstraint memory [llength [info commands memory]]
  22
  23 set lambda [list {{start 0} {stop 10}} {
  24     # init
  25     set i    $start
  26     set imax $stop
  27     yield
  28     while {$i < $imax} {
  29         yield [expr {$i*$stop}]
  30         incr i
  31     }
  32 }]
  33 \f
  34 test coroutine-1.1 {coroutine basic} -setup {
  35     coroutine foo ::apply $lambda
  36     set res {}
  37 } -body {
  38     for {set k 1} {$k < 4} {incr k} {
  39         lappend res [foo]
  40     }
  41     set res
  42 } -cleanup {
  43     rename foo {}
  44     unset res
  45 } -result {0 10 20}
  46 test coroutine-1.2 {coroutine basic} -setup {
  47     coroutine foo ::apply $lambda 2 8
  48     set res {}
  49 } -body {
  50     for {set k 1} {$k < 4} {incr k} {
  51         lappend res [foo]
  52     }
  53     set res
  54 } -cleanup {
  55     rename foo {}
  56     unset res
  57 } -result {16 24 32}
  58 test coroutine-1.3 {yield returns new arg} -setup {
  59     set body {
  60         # init
  61         set i    $start
  62         set imax $stop
  63         yield
  64         while {$i < $imax} {
  65             set stop [yield [expr {$i*$stop}]]
  66             incr i
  67         }
  68     }
  69     coroutine foo ::apply [list {{start 2} {stop 10}} $body]
  70     set res {}
  71 } -body {
  72     for {set k 1} {$k < 4} {incr k} {
  73         lappend res [foo $k]
  74     }
  75     set res
  76 } -cleanup {
  77     rename foo {}
  78     unset res
  79 } -result {20 6 12}
  80 test coroutine-1.4 {yield in nested proc} -setup {
  81     proc moo {} {
  82         upvar 1 i i stop stop
  83         yield [expr {$i*$stop}]
  84     }
  85     set body {
  86         # init
  87         set i    $start
  88         set imax $stop
  89         yield
  90         while {$i < $imax} {
  91             moo
  92             incr i
  93         }
  94     }
  95     coroutine foo ::apply [list {{start 0} {stop 10}} $body]
  96     set res {}
  97 } -body {
  98     for {set k 1} {$k < 4} {incr k} {
  99         lappend res [foo $k]
 100     }
 101     set res
 102 } -cleanup {
 103     rename foo {}
 104     rename moo {}
 105     unset body res
 106 } -result {0 10 20}
 107 test coroutine-1.5 {just yield} -body {
 108     coroutine foo yield
 109     list [foo] [catch foo msg] $msg
 110 } -cleanup {
 111     unset msg
 112 } -result {{} 1 {invalid command name "foo"}}
 113 test coroutine-1.6 {just yield} -body {
 114     coroutine foo [list yield]
 115     list [foo] [catch foo msg] $msg
 116 } -cleanup {
 117     unset msg
 118 } -result {{} 1 {invalid command name "foo"}}
 119 test coroutine-1.7 {yield in nested uplevel} -setup {
 120     set body {
 121         # init
 122         set i    $start
 123         set imax $stop
 124         yield
 125         while {$i < $imax} {
 126             uplevel 0 [list yield [expr {$i*$stop}]]
 127             incr i
 128         }
 129     }
 130     coroutine foo ::apply [list {{start 0} {stop 10}} $body]
 131     set res {}
 132 } -body {
 133     for {set k 1} {$k < 4} {incr k} {
 134         lappend res [eval foo $k]
 135     }
 136     set res
 137 } -cleanup {
 138     rename foo {}
 139     unset body res
 140 } -result {0 10 20}
 141 test coroutine-1.8 {yield in nested uplevel} -setup {
 142     set body {
 143         # init
 144         set i    $start
 145         set imax $stop
 146         yield
 147         while {$i < $imax} {
 148             uplevel 0 yield [expr {$i*$stop}]
 149             incr i
 150         }
 151     }
 152     coroutine foo ::apply [list {{start 0} {stop 10}} $body]
 153     set res {}
 154 } -body {
 155     for {set k 1} {$k < 4} {incr k} {
 156         lappend res [eval foo $k]
 157     }
 158     set res
 159 } -cleanup {
 160     rename foo {}
 161     unset body res
 162 } -result {0 10 20}
 163 test coroutine-1.9 {yield in nested eval} -setup {
 164     proc moo {} {
 165         upvar 1 i i stop stop
 166         yield [expr {$i*$stop}]
 167     }
 168     set body {
 169         # init
 170         set i    $start
 171         set imax $stop
 172         yield
 173         while {$i < $imax} {
 174             eval moo
 175             incr i
 176         }
 177     }
 178     coroutine foo ::apply [list {{start 0} {stop 10}} $body]
 179     set res {}
 180 } -body {
 181     for {set k 1} {$k < 4} {incr k} {
 182         lappend res [foo $k]
 183     }
 184     set res
 185 } -cleanup {
 186     rename moo {}
 187     unset body res
 188 } -result {0 10 20}
 189 test coroutine-1.10 {yield in nested eval} -setup {
 190     set body {
 191         # init
 192         set i    $start
 193         set imax $stop
 194         yield
 195         while {$i < $imax} {
 196             eval yield [expr {$i*$stop}]
 197             incr i
 198         }
 199     }
 200     coroutine foo ::apply [list {{start 0} {stop 10}} $body]
 201     set res {}
 202 } -body {
 203     for {set k 1} {$k < 4} {incr k} {
 204         lappend res [eval foo $k]
 205     }
 206     set res
 207 } -cleanup {
 208     unset body res
 209 } -result {0 10 20}
 210 test coroutine-1.11 {yield outside coroutine} -setup {
 211     proc moo {} {
 212         upvar 1 i i stop stop
 213         yield [expr {$i*$stop}]
 214     }
 215 } -body {
 216     variable i 5 stop 6
 217     moo
 218 } -cleanup {
 219     rename moo {}
 220     unset i stop
 221 } -returnCodes error -result {yield can only be called in a coroutine}
 222 test coroutine-1.12 {proc as coroutine} -setup {
 223     set body {
 224         # init
 225         set i    $start
 226         set imax $stop
 227         yield
 228         while {$i < $imax} {
 229             uplevel 0 [list yield [expr {$i*$stop}]]
 230             incr i
 231         }
 232     }
 233     proc moo {{start 0} {stop 10}} $body
 234     coroutine foo moo 2 8
 235 } -body {
 236     list [foo] [foo]
 237 } -cleanup {
 238     unset body
 239     rename moo {}
 240     rename foo {}
 241 } -result {16 24}
 242 test coroutine-1.13 {subst as coroutine: literal} {
 243     list [coroutine foo eval {subst {>>[yield a],[yield b]<<}}] [foo x] [foo y]
 244 } {a b >>x,y<<}
 245 test coroutine-1.14 {subst as coroutine: in variable} {
 246     set pattern {>>[yield c],[yield d]<<}
 247     list [coroutine foo eval {subst $pattern}] [foo p] [foo q]
 248 } {c d >>p,q<<}
 249
 250 test coroutine-2.1 {self deletion on return} -body {
 251     coroutine foo set x 3
 252     foo
 253 } -returnCodes error -result {invalid command name "foo"}
 254 test coroutine-2.2 {self deletion on return} -body {
 255     coroutine foo ::apply [list {} {yield; yield 1; return 2}]
 256     list [foo] [foo] [catch foo msg] $msg
 257 } -result {1 2 1 {invalid command name "foo"}}
 258 test coroutine-2.3 {self deletion on error return} -body {
 259     coroutine foo ::apply [list {} {yield;yield 1; error ouch!}]
 260     list [foo] [catch foo msg] $msg [catch foo msg] $msg
 261 } -result {1 1 ouch! 1 {invalid command name "foo"}}
 262 test coroutine-2.4 {self deletion on other return} -body {
 263     coroutine foo ::apply [list {} {yield;yield 1; return -code 100 ouch!}]
 264     list [foo] [catch foo msg] $msg [catch foo msg] $msg
 265 } -result {1 100 ouch! 1 {invalid command name "foo"}}
 266 test coroutine-2.5 {deletion of suspended coroutine} -body {
 267     coroutine foo ::apply [list {} {yield; yield 1; return 2}]
 268     list [foo] [rename foo {}] [catch foo msg] $msg
 269 } -result {1 {} 1 {invalid command name "foo"}}
 270 test coroutine-2.6 {deletion of running coroutine} -body {
 271     coroutine foo ::apply [list {} {yield; rename foo {}; yield 1; return 2}]
 272     list [foo] [catch foo msg] $msg
 273 } -result {1 1 {invalid command name "foo"}}
 274
 275 test coroutine-3.1 {info level computation} -setup {
 276     proc a {} {while 1 {yield [info level]}}
 277     proc b {} foo
 278 } -body {
 279     # note that coroutines execute in uplevel #0
 280     set l0 [coroutine foo a]
 281     set l1 [foo]
 282     set l2 [b]
 283     list $l0 $l1 $l2
 284 } -cleanup {
 285     rename a {}
 286     rename b {}
 287 } -result {1 1 1}
 288 test coroutine-3.2 {info frame computation} -setup {
 289     proc a {} {while 1 {yield [info frame]}}
 290     proc b {} foo
 291 } -body {
 292     set l0 [coroutine foo a]
 293     set l1 [foo]
 294     set l2 [b]
 295     expr {$l2 - $l1}
 296 } -cleanup {
 297     rename a {}
 298     rename b {}
 299 } -result 1
 300 test coroutine-3.3 {info coroutine} -setup {
 301     proc a {} {info coroutine}
 302     proc b {} a
 303 } -body {
 304     b
 305 } -cleanup {
 306     rename a {}
 307     rename b {}
 308 } -result {}
 309 test coroutine-3.4 {info coroutine} -setup {
 310     proc a {} {info coroutine}
 311     proc b {} a
 312 } -body {
 313     coroutine foo b
 314 } -cleanup {
 315     rename a {}
 316     rename b {}
 317 } -result ::foo
 318 test coroutine-3.5 {info coroutine} -setup {
 319     proc a {} {info coroutine}
 320     proc b {} {rename [info coroutine] {}; a}
 321 } -body {
 322     coroutine foo b
 323 } -cleanup {
 324     rename a {}
 325     rename b {}
 326 } -result {}
 327 test coroutine-3.6 {info frame, bug #2910094} -setup {
 328     proc stack {} {
 329         set res [list "LEVEL:[set lev [info frame]]"]
 330         for {set i 1} {$i < $lev} {incr i} {
 331             lappend res [info frame $i]
 332         }
 333         set res
 334         # the precise command depends on line numbers and such, is likely not
 335         # to be stable: just check that the test completes!
 336         return
 337     }
 338     proc a {} stack
 339 } -body {
 340     coroutine aa a
 341 } -cleanup {
 342     rename stack {}
 343     rename a {}
 344 } -result {}
 345 test coroutine-3.7 {bug 0b874c344d} {
 346     dict get [coroutine X coroutine Y info frame 0] cmd
 347 } {coroutine X coroutine Y info frame 0}
 348
 349 test coroutine-4.1 {bug #2093188} -setup {
 350     proc foo {} {
 351         set v 1
 352         trace add variable v {write unset} bar
 353         yield
 354         set v 2
 355         yield
 356         set v 3
 357     }
 358     proc bar args {lappend ::res $args}
 359     coroutine a foo
 360 } -body {
 361     list [a] [a] $::res
 362 } -cleanup {
 363     rename foo {}
 364     rename bar {}
 365     unset ::res
 366 } -result {{} 3 {{v {} write} {v {} write} {v {} unset}}}
 367 test coroutine-4.2 {bug #2093188} -setup {
 368     proc foo {} {
 369         set v 1
 370         trace add variable v {read unset} bar
 371         yield
 372         set v 2
 373         set v
 374         yield
 375         set v 3
 376     }
 377     proc bar args {lappend ::res $args}
 378     coroutine a foo
 379 } -body {
 380     list [a] [a] $::res
 381 } -cleanup {
 382     rename foo {}
 383     rename bar {}
 384     unset ::res
 385 } -result {{} 3 {{v {} read} {v {} unset}}}
 386
 387 test coroutine-4.3 {bug #2093947} -setup {
 388     proc foo {} {
 389         set v 1
 390         trace add variable v {write unset} bar
 391         yield
 392         set v 2
 393         yield
 394         set v 3
 395     }
 396     proc bar args {lappend ::res $args}
 397 } -body {
 398     coroutine a foo
 399     a
 400     a
 401     coroutine a foo
 402     a
 403     rename a {}
 404     set ::res
 405 } -cleanup {
 406     rename foo {}
 407     rename bar {}
 408     unset ::res
 409 } -result {{v {} write} {v {} write} {v {} unset} {v {} write} {v {} unset}}
 410
 411 test coroutine-4.4 {bug #2917627: cmd resolution} -setup {
 412     proc a {} {return global}
 413     namespace eval b {proc a {} {return local}}
 414 } -body {
 415     namespace eval b {coroutine foo a}
 416 } -cleanup {
 417     rename a {}
 418     namespace delete b
 419 } -result local
 420
 421 test coroutine-4.5 {bug #2724403} -constraints {memory} \
 422 -setup {
 423     proc getbytes {} {
 424         set lines [split [memory info] "\n"]
 425         lindex $lines 3 3
 426     }
 427 } -body {
 428     set end [getbytes]
 429     for {set i 0} {$i < 5} {incr i} {
 430         set ns ::y$i
 431         namespace eval $ns {}
 432         proc ${ns}::start {} {yield; puts hello}
 433         coroutine ${ns}::run ${ns}::start
 434         namespace delete $ns
 435         set start $end
 436         set end [getbytes]
 437     }
 438     set leakedBytes [expr {$end - $start}]
 439 } -cleanup {
 440     rename getbytes {}
 441     unset i ns start end
 442 } -result 0
 443
 444 test coroutine-4.6 {compile context, bug #3282869} -setup {
 445     unset -nocomplain ::x
 446     proc f x {
 447         coroutine D eval {yield X$x;yield Y}
 448     }
 449 } -body {
 450     f 12
 451 } -cleanup {
 452     rename f {}
 453 } -returnCodes error -match glob -result {can't read *}
 454
 455 test coroutine-4.7 {compile context, bug #3282869} -setup {
 456     proc f x {
 457         coroutine D eval {yield X$x;yield Y$x}
 458     }
 459 } -body {
 460     set ::x 15
 461     set ::x [f 12]
 462     D
 463 } -cleanup {
 464     D
 465     unset ::x
 466     rename f {}
 467 } -result YX15
 468
 469 test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels} \
 470 -setup {
 471     proc nestedYield {{val {}}} {
 472         yield $val
 473     }
 474     proc getNumLevel {} {
 475         # remove the level for this proc's call
 476         expr {[lindex [testnrelevels] 1] - 1}
 477     }
 478     proc relativeLevel base {
 479         # remove the level for this proc's call
 480         expr {[getNumLevel] - $base - 1}
 481     }
 482     proc foo {} {
 483         while 1 {
 484             nestedYield
 485         }
 486     }
 487     set res {}
 488 } -body {
 489     set base [getNumLevel]
 490     lappend res [relativeLevel $base]
 491     eval {coroutine a foo}
 492     # back to base level
 493     lappend res [relativeLevel $base]
 494     a
 495     lappend res [relativeLevel $base]
 496     eval a
 497     lappend res [relativeLevel $base]
 498     eval {eval a}
 499     lappend res [relativeLevel $base]
 500     rename a {}
 501     lappend res [relativeLevel $base]
 502     set res
 503 } -cleanup {
 504     rename foo {}
 505     rename nestedYield {}
 506     rename getNumLevel {}
 507     rename relativeLevel {}
 508     unset res
 509 } -result {0 0 0 0 0 0}
 510 test coroutine-5.2 {right numLevels within coro} -constraints {testnrelevels} \
 511 -setup {
 512     proc nestedYield {{val {}}} {
 513         yield $val
 514     }
 515     proc getNumLevel {} {
 516         # remove the level for this proc's call
 517         expr {[lindex [testnrelevels] 1] - 1}
 518     }
 519     proc relativeLevel base {
 520         # remove the level for this proc's call
 521         expr {[getNumLevel] - $base - 1}
 522     }
 523     proc foo base {
 524         while 1 {
 525             set base [nestedYield [relativeLevel $base]]
 526         }
 527     }
 528     set res {}
 529 } -body {
 530     lappend res [eval {coroutine a foo [getNumLevel]}]
 531     lappend res [a [getNumLevel]]
 532     lappend res [eval {a [getNumLevel]}]
 533     lappend res [eval {eval {a [getNumLevel]}}]
 534     set base [lindex $res 0]
 535     foreach x $res[set res {}] {
 536         lappend res [expr {$x-$base}]
 537     }
 538     set res
 539 } -cleanup {
 540     rename a {}
 541     rename foo {}
 542     rename nestedYield {}
 543     rename getNumLevel {}
 544     rename relativeLevel {}
 545     unset res
 546 } -result {0 0 0 0}
 547
 548 test coroutine-6.1 {coroutine nargs} -body {
 549     coroutine a ::apply $lambda
 550     a
 551 } -cleanup {
 552     rename a {}
 553 } -result 0
 554 test coroutine-6.2 {coroutine nargs} -body {
 555     coroutine a ::apply $lambda
 556     a a
 557 } -cleanup {
 558     rename a {}
 559 } -result 0
 560 test coroutine-6.3 {coroutine nargs} -body {
 561     coroutine a ::apply $lambda
 562     a a a
 563 } -cleanup {
 564     rename a {}
 565 } -returnCodes error -result {wrong # args: should be "a ?arg?"}
 566
 567 test coroutine-7.1 {yieldto} -body {
 568     coroutine c apply {{} {
 569         yield
 570         yieldto return -level 0 -code 1 quux
 571         return quuy
 572     }}
 573     set res [list [catch c msg] $msg]
 574     lappend res [catch c msg] $msg
 575     lappend res [catch c msg] $msg
 576 } -cleanup {
 577     unset res
 578 } -result [list 1 quux 0 quuy 1 {invalid command name "c"}]
 579 test coroutine-7.2 {multi-argument yielding with yieldto} -body {
 580     proc corobody {} {
 581         set a 1
 582         while 1 {
 583             set a [yield $a]
 584             set a [yieldto return -level 0 $a]
 585             lappend a [llength $a]
 586         }
 587     }
 588     coroutine a corobody
 589     coroutine b corobody
 590     list [a x] [a y z] [a \{p] [a \{q r] [a] [a] [rename a {}] \
 591         [b ok] [rename b {}]
 592 } -cleanup {
 593     rename corobody {}
 594 } -result {x {y z 2} \{p {\{q r 2} {} 0 {} ok {}}
 595 test coroutine-7.3 {yielding between coroutines} -body {
 596     proc juggler {target {value ""}} {
 597         if {$value eq ""} {
 598             set value [yield [info coroutine]]
 599         }
 600         while {[llength $value]} {
 601             lappend ::result $value [info coroutine]
 602             set value [lrange $value 0 end-1]
 603             lassign [yieldto $target $value] value
 604         }
 605         # Clear nested collection of coroutines
 606         catch $target
 607     }
 608     set result ""
 609     coroutine j1 juggler [coroutine j2 juggler [coroutine j3 juggler j1]]\
 610         {a b c d e}
 611     list $result [info command j1] [info command j2] [info command j3]
 612 } -cleanup {
 613     catch {rename juggler ""}
 614 } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}}
 615 test coroutine-7.4 {Bug 8ff0cb9fe1} -setup {
 616     proc foo {a b} {catch yield; return 1}
 617 } -cleanup {
 618     rename foo {}
 619 } -body {
 620     coroutine demo lsort -command foo {a b}
 621 } -result {b a}
 622 test coroutine-7.5 {return codes} {
 623     set result {}
 624     foreach code {0 1 2 3 4 5} {
 625         lappend result [catch {coroutine demo return -level 0 -code $code}]
 626     }
 627     set result
 628 } {0 1 2 3 4 5}
 629 test coroutine-7.6 {Early yield crashes} -setup {
 630     set i [interp create]
 631 } -body {
 632     # Force into a child interpreter [bug 60559fd4a6]
 633     $i eval {
 634         proc foo args {}
 635         trace add execution foo enter {catch yield}
 636         coroutine demo foo
 637         rename foo {}
 638         return ok
 639     }
 640 } -cleanup {
 641     interp delete $i
 642 } -result ok
 643 test coroutine-7.7 {Bug 2486550} -setup {
 644     set i [interp create]
 645     $i hide yield
 646 } -body {
 647     # Force into a child interpreter [bug 60559fd4a6]
 648     $i eval {
 649         coroutine demo interp invokehidden {} yield ok
 650     }
 651 } -cleanup {
 652     $i eval demo
 653     interp delete $i
 654 } -result ok
 655 test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup {
 656     namespace eval cotest {}
 657     set ::result ""
 658 } -body {
 659     proc cotest::body {} {
 660         lappend ::result a
 661         yield OUT
 662         lappend ::result b
 663         yieldto ::return -level 0 123
 664         lappend ::result c
 665         return
 666     }
 667     lappend ::result [coroutine cotest cotest::body]
 668     namespace delete cotest
 669     namespace eval cotest {}
 670     lappend ::result [cotest]
 671     cotest
 672     return $result
 673 } -returnCodes error -cleanup {
 674     catch {namespace delete ::cotest}
 675     catch {rename cotest ""}
 676 } -result {yieldto called in deleted namespace}
 677 test coroutine-7.9 {yieldto context nuke: Bug a90d9331bc} -setup {
 678     namespace eval cotest {}
 679     set ::result ""
 680 } -body {
 681     proc cotest::body {} {
 682         set y ::yieldto
 683         lappend ::result a
 684         yield OUT
 685         lappend ::result b
 686         $y ::return -level 0 123
 687         lappend ::result c
 688         return
 689     }
 690     lappend ::result [coroutine cotest cotest::body]
 691     namespace delete cotest
 692     namespace eval cotest {}
 693     lappend ::result [cotest]
 694     cotest
 695     return $result
 696 } -returnCodes error -cleanup {
 697     catch {namespace delete ::cotest}
 698     catch {rename cotest ""}
 699 } -result {yieldto called in deleted namespace}
 700 test coroutine-7.10 {yieldto context nuke: Bug a90d9331bc} -setup {
 701     namespace eval cotest {}
 702     set ::result ""
 703 } -body {
 704     proc cotest::body {} {
 705         lappend ::result a
 706         yield OUT
 707         lappend ::result b
 708         yieldto ::return -level 0 -cotest [namespace delete ::cotest] 123
 709         lappend ::result c
 710         return
 711     }
 712     lappend ::result [coroutine cotest cotest::body]
 713     lappend ::result [cotest]
 714     cotest
 715     return $result
 716 } -returnCodes error -cleanup {
 717     catch {namespace delete ::cotest}
 718     catch {rename cotest ""}
 719 } -result {yieldto called in deleted namespace}
 720 test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup {
 721     namespace eval cotest {}
 722     set ::result ""
 723 } -body {
 724     proc cotest::body {} {
 725         set y ::yieldto
 726         lappend ::result a
 727         yield OUT
 728         lappend ::result b
 729         $y ::return -level 0 -cotest [namespace delete ::cotest] 123
 730         lappend ::result c
 731         return
 732     }
 733     lappend ::result [coroutine cotest cotest::body]
 734     lappend ::result [cotest]
 735     cotest
 736     return $result
 737 } -returnCodes error -cleanup {
 738     catch {namespace delete ::cotest}
 739     catch {rename cotest ""}
 740 } -result {yieldto called in deleted namespace}
 741 test coroutine-7.12 {coro floor above street level #3008307} -body {
 742     proc c {} {
 743         yield
 744     }
 745     proc cc {} {
 746         coroutine C c
 747     }
 748     proc boom {} {
 749         cc ; # coro created at level 2
 750         C  ; # and called at level 1
 751     }
 752     boom   ; # does not crash: the coro floor is a good insulator
 753     list
 754 } -cleanup {
 755     rename boom {}; rename cc {}; rename c {}
 756 } -result {}
 757
 758 test coroutine-8.0.0 {coro inject executed} -body {
 759     coroutine demo apply {{} { foreach i {1 2} yield }}
 760     demo
 761     set ::result none
 762     tcl::unsupported::inject demo set ::result inject-executed
 763     demo
 764     set ::result
 765 } -result {inject-executed}
 766 test coroutine-8.0.1 {coro inject after error} -body {
 767     coroutine demo apply {{} { foreach i {1 2} yield; error test }}
 768     demo
 769     set ::result none
 770     tcl::unsupported::inject demo set ::result inject-executed
 771     lappend ::result [catch {demo} err] $err
 772 } -result {inject-executed 1 test}
 773 test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body {
 774     interp create child
 775     child eval {
 776         coroutine demo apply {{} { while {1} yield }}
 777         demo
 778         tcl::unsupported::inject demo set ::result inject-executed
 779     }
 780     interp delete child
 781 } -result {}
 782 test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body {
 783     interp create child
 784     child eval {
 785         coroutine demo apply {{} { while {1} yield }}
 786         demo
 787         tcl::unsupported::inject demo set ::result inject-executed
 788     }
 789     child eval demo
 790     set result [child eval {set ::result}]
 791
 792     interp delete child
 793     set result
 794 } -result {inject-executed}
 795
 796 test coroutine-9.1 {coro type} {
 797     coroutine demo eval {
 798         yield
 799         yield "PHASE 1"
 800         yieldto string cat "PHASE 2"
 801         ::tcl::unsupported::corotype [info coroutine]
 802     }
 803     list [demo] [::tcl::unsupported::corotype demo] \
 804         [demo] [::tcl::unsupported::corotype demo] [demo]
 805 } {{PHASE 1} yield {PHASE 2} yieldto active}
 806 test coroutine-9.2 {coro type} -setup {
 807     catch {rename nosuchcommand ""}
 808 } -returnCodes error -body {
 809     ::tcl::unsupported::corotype nosuchcommand
 810 } -result {can only get coroutine type of a coroutine}
 811 test coroutine-9.3 {coro type} -returnCodes error -body {
 812     proc notacoroutine {} {}
 813     ::tcl::unsupported::corotype notacoroutine
 814 } -returnCodes error -cleanup {
 815     rename notacoroutine {}
 816 } -result {can only get coroutine type of a coroutine}
 817
 818 test coroutine-10.1 {coroutine general introspection} -setup {
 819     set i [interp create]
 820 } -body {
 821     $i eval {
 822         # Make the introspection code
 823         namespace path tcl::unsupported
 824         proc probe {type var} {
 825             upvar 1 $var v
 826             set f [info frame]
 827             incr f -1
 828             set result [list $v [dict get [info frame $f] proc]]
 829             if {$type eq "yield"} {
 830                 tailcall yield $result
 831             } else {
 832                 tailcall yieldto string cat $result
 833             }
 834         }
 835         proc pokecoro {c var} {
 836             inject $c probe [corotype $c] $var
 837             $c
 838         }
 839
 840         # Coroutine implementations
 841         proc cbody1 {} {
 842             set val [info coroutine]
 843             set accum {}
 844             while {[set val [yield $val]] ne ""} {
 845                 lappend accum $val
 846                 set val ok
 847             }
 848             return $accum
 849         }
 850         proc cbody2 {} {
 851             set val [info coroutine]
 852             set accum {}
 853             while {[llength [set val [yieldto string cat $val]]]} {
 854                 lappend accum {*}$val
 855                 set val ok
 856             }
 857             return $accum
 858         }
 859
 860         # Make the coroutines
 861         coroutine c1 cbody1
 862         coroutine c2 cbody2
 863         list [c1 abc] [c2 1 2 3] [pokecoro c1 accum] [pokecoro c2 accum] \
 864             [c1 def] [c2 4 5 6] [pokecoro c1 accum] [pokecoro c2 accum] \
 865             [c1] [c2]
 866     }
 867 } -cleanup {
 868     interp delete $i
 869 } -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}}
 870 \f
 871 # cleanup
 872 unset lambda
 873 ::tcltest::cleanupTests
 874
 875 return
 876
 877 # Local Variables:
 878 # mode: tcl
 879 # End: