Posted to tcl by colin at Fri Aug 13 01:43:22 GMT 2010view raw
- # the new yieldm multi-arg coro call does not exist.
- # this is the older coroutine implementation
- interp alias {} ::yieldm {} ::yield
- proc ::delshim {name x y op} {
- catch {::rename $name {}} ;# delete shim
- }
- proc ::Coroutine {name command args} {
- # determine the appropriate namespace for coro creation
- set ns [namespace qualifiers $name]
- if {![string match ::* $ns]} {
- set ns [uplevel 1 namespace current]::$ns
- }
- set name [namespace tail $name]
- # create a like-named coro
- set x [uplevel 1 [list ::coroutine ${ns}_$name $command {*}$args]]
- # wrap the coro in a shim
- proc ${ns}$name {args} [string map [list $x %N%] {
- tailcall %N% $args ;# wrap the args into a list for the old-style coro
- }]
- # the two commands need to be paired for destruction
- trace add command ${ns}_$name delete [list ::delshim ${ns}$name]
- trace add command ${ns}$name delete [list ::delshim ${ns}_$name]
- # tell it we created the one they requested
- return ${ns}$name
- }