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 © 2008 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 12if {"::tcltest" ni [namespace children]} { 13 package require tcltest 2.5 14 namespace import -force ::tcltest::* 15} 16 17::tcltest::loadTestedCommands 18catch [list package require -exact tcl::test [info patchlevel]] 19 20testConstraint testnrelevels [llength [info commands testnrelevels]] 21testConstraint memory [llength [info commands memory]] 22 23set 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 34test 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} 46test 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} 58test 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} 80test 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} 107test 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"}} 113test 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"}} 119test 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} 141test 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} 163test 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} 189test 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} 210test 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} 222test 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} 242test 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<<} 245test 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 250test coroutine-2.1 {self deletion on return} -body { 251 coroutine foo set x 3 252 foo 253} -returnCodes error -result {invalid command name "foo"} 254test 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"}} 258test 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"}} 262test 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"}} 266test 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"}} 270test 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 275test 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} 288test 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 300test 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 {} 309test 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 318test 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 {} 327test 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 {} 345test 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 349test 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}}} 367test 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 387test 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 411test 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 421test 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 444test 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 455test 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 469test 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} 510test 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 548test coroutine-6.1 {coroutine nargs} -body { 549 coroutine a ::apply $lambda 550 a 551} -cleanup { 552 rename a {} 553} -result 0 554test coroutine-6.2 {coroutine nargs} -body { 555 coroutine a ::apply $lambda 556 a a 557} -cleanup { 558 rename a {} 559} -result 0 560test 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 567test 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"}] 579test 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 {}} 595test 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} {} {} {}} 615test 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} 622test 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} 629test 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 643test 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 655test 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} 677test 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} 700test 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} 720test 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} 741test 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 758test 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} 766test 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} 773test 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 {} 782test 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 796test coroutine-9.1 {coroprobe with yield} -body { 797 coroutine demo apply {{} { foreach i {1 2} yield }} 798 list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo] 799} -cleanup { 800 catch {rename demo {}} 801} -result {1 {} 2 {}} 802test coroutine-9.2 {coroprobe with yieldto} -body { 803 coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }} 804 list [coroprobe demo set i] [demo a b] [coroprobe demo set i] [demo c d] 805} -cleanup { 806 catch {rename demo {}} 807} -result {1 {} 2 {{a b} {c d}}} 808test coroutine-9.3 {coroprobe errors} -setup { 809 catch {rename demo {}} 810} -body { 811 coroprobe demo set i 812} -returnCodes error -result {can only inject a probe command into a coroutine} 813test coroutine-9.4 {coroprobe errors} -body { 814 proc demo {} { foreach i {1 2} yield } 815 coroprobe demo set i 816} -returnCodes error -cleanup { 817 catch {rename demo {}} 818} -result {can only inject a probe command into a coroutine} 819test coroutine-9.5 {coroprobe errors} -body { 820 coroutine demo apply {{} { foreach i {1 2} yield }} 821 coroprobe 822} -returnCodes error -cleanup { 823 catch {rename demo {}} 824} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"} 825test coroutine-9.6 {coroprobe errors} -body { 826 coroutine demo apply {{} { foreach i {1 2} yield }} 827 coroprobe demo 828} -returnCodes error -cleanup { 829 catch {rename demo {}} 830} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"} 831test coroutine-9.7 {coroprobe errors in probe command} -body { 832 coroutine demo apply {{} { foreach i {1 2} yield }} 833 coroprobe demo set 834} -returnCodes error -cleanup { 835 catch {rename demo {}} 836} -result {wrong # args: should be "set varName ?newValue?"} 837test coroutine-9.8 {coroprobe errors in probe command} -body { 838 coroutine demo apply {{} { foreach i {1 2} yield }} 839 list [catch {coroprobe demo set}] [demo] [coroprobe demo set i] 840} -cleanup { 841 catch {rename demo {}} 842} -result {1 {} 2} 843test coroutine-9.9 {coroprobe: advanced features} -setup { 844 set i [interp create] 845} -body { 846 $i eval { 847 coroutine demo apply {{} { 848 set f [info level],[info frame] 849 foreach i {1 2} yield 850 }} 851 coroprobe demo apply {{} { 852 upvar 1 f f 853 list [info coroutine] [info level] [info frame] $f 854 }} 855 } 856} -cleanup { 857 interp delete $i 858} -result {::demo 2 3 1,2} 859 860test coroutine-10.1 {coroinject with yield} -setup { 861 set result {} 862} -body { 863 coroutine demo apply {{} { lmap i {1 2} yield }} 864 coroinject demo apply {{op val} {lappend ::result $op $val}} 865 list $result [demo x] [demo y] $result 866} -cleanup { 867 catch {rename demo {}} 868} -result {{} {} {{yield x} y} {yield x}} 869test coroutine-10.2 {coroinject stacking} -setup { 870 set result {} 871} -body { 872 coroutine demo apply {{} { lmap i {1 2} yield }} 873 coroinject demo apply {{op val} {lappend ::result $op $val A;return $val}} 874 coroinject demo apply {{op val} {lappend ::result $op $val B;return $val}} 875 list $result [demo x] [demo y] $result 876} -cleanup { 877 catch {rename demo {}} 878} -result {{} {} {x y} {yield x B yield x A}} 879test coroutine-10.3 {coroinject with yieldto} -setup { 880 set result {} 881} -body { 882 coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }} 883 coroinject demo apply {{op val} {lappend ::result $op $val;return $val}} 884 list $result [demo x mp] [demo y le] $result 885} -cleanup { 886 catch {rename demo {}} 887} -result {{} {} {{x mp} {y le}} {yieldto {x mp}}} 888test coroutine-10.4 {coroinject errors} -setup { 889 catch {rename demo {}} 890} -body { 891 coroinject demo set i 892} -returnCodes error -result {can only inject a command into a coroutine} 893test coroutine-10.5 {coroinject errors} -body { 894 proc demo {} { foreach i {1 2} yield } 895 coroinject demo set i 896} -returnCodes error -cleanup { 897 catch {rename demo {}} 898} -result {can only inject a command into a coroutine} 899test coroutine-10.6 {coroinject errors} -body { 900 coroutine demo apply {{} { foreach i {1 2} yield }} 901 coroinject 902} -returnCodes error -cleanup { 903 catch {rename demo {}} 904} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"} 905test coroutine-10.7 {coroinject errors} -body { 906 coroutine demo apply {{} { foreach i {1 2} yield }} 907 coroinject demo 908} -returnCodes error -cleanup { 909 catch {rename demo {}} 910} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"} 911test coroutine-10.8 {coroinject errors in injected command} -body { 912 coroutine demo apply {{} { foreach i {1 2} yield }} 913 coroinject demo apply {args {error "ERR: $args"}} 914 list [catch demo msg] $msg [catch demo msg] $msg 915} -cleanup { 916 catch {rename demo {}} 917} -result {1 {ERR: yield {}} 1 {invalid command name "demo"}} 918test coroutine-10.9 {coroinject: advanced features} -setup { 919 set i [interp create] 920} -body { 921 $i eval { 922 coroutine demo apply {{} { 923 set l [info level] 924 set f [info frame] 925 lmap i {1 2} yield 926 }} 927 coroinject demo apply {{arg op val} { 928 global result 929 upvar 1 f f l l 930 lappend result [info coroutine] $arg $op $val 931 lappend result [info level] $l [info frame] $f 932 lappend result [yield $arg] 933 return [string toupper $val] 934 }} grill 935 list [demo ABC] [demo pqr] [demo def] $result 936 } 937} -cleanup { 938 interp delete $i 939} -result {grill {} {ABC def} {::demo grill yield ABC 2 1 3 2 pqr}} 940 941test coroutine-11.1 {coro type} { 942 coroutine demo eval { 943 yield 944 yield "PHASE 1" 945 yieldto string cat "PHASE 2" 946 ::tcl::unsupported::corotype [info coroutine] 947 } 948 list [demo] [::tcl::unsupported::corotype demo] \ 949 [demo] [::tcl::unsupported::corotype demo] [demo] 950} {{PHASE 1} yield {PHASE 2} yieldto active} 951test coroutine-11.2 {coro type} -setup { 952 catch {rename nosuchcommand ""} 953} -returnCodes error -body { 954 ::tcl::unsupported::corotype nosuchcommand 955} -result {can only get coroutine type of a coroutine} 956test coroutine-11.3 {coro type} -returnCodes error -body { 957 proc notacoroutine {} {} 958 ::tcl::unsupported::corotype notacoroutine 959} -returnCodes error -cleanup { 960 rename notacoroutine {} 961} -result {can only get coroutine type of a coroutine} 962 963test coroutine-12.1 {coroutine general introspection} -setup { 964 set i [interp create] 965} -body { 966 $i eval { 967 # Make the introspection code 968 namespace path tcl::unsupported 969 proc probe {type var} { 970 upvar 1 $var v 971 set f [info frame] 972 incr f -1 973 set result [list $v [dict get [info frame $f] proc]] 974 if {$type eq "yield"} { 975 tailcall yield $result 976 } else { 977 tailcall yieldto string cat $result 978 } 979 } 980 proc pokecoro {c var} { 981 inject $c probe [corotype $c] $var 982 $c 983 } 984 985 # Coroutine implementations 986 proc cbody1 {} { 987 set val [info coroutine] 988 set accum {} 989 while {[set val [yield $val]] ne ""} { 990 lappend accum $val 991 set val ok 992 } 993 return $accum 994 } 995 proc cbody2 {} { 996 set val [info coroutine] 997 set accum {} 998 while {[llength [set val [yieldto string cat $val]]]} { 999 lappend accum {*}$val 1000 set val ok 1001 } 1002 return $accum 1003 } 1004 1005 # Make the coroutines 1006 coroutine c1 cbody1 1007 coroutine c2 cbody2 1008 list [c1 abc] [c2 1 2 3] [pokecoro c1 accum] [pokecoro c2 accum] \ 1009 [c1 def] [c2 4 5 6] [pokecoro c1 accum] [pokecoro c2 accum] \ 1010 [c1] [c2] 1011 } 1012} -cleanup { 1013 interp delete $i 1014} -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}} 1015 1016# cleanup 1017unset lambda 1018::tcltest::cleanupTests 1019 1020return 1021 1022# Local Variables: 1023# mode: tcl 1024# End: 1025