Posted to tcl by colin at Mon May 17 23:37:26 GMT 2010view raw

  1. proc ::Coroutine {name command args} {
  2. # determine the appropriate namespace for coro creation
  3. set ns [namespace qualifiers $name]
  4. if {![string match ::* $ns]} {
  5. set ns [uplevel 1 namespace current]::$ns
  6. }
  7. set name [namespace tail $name]
  8.  
  9. # create a like-named coro
  10. set x [uplevel 1 [list ::coroutine ${ns}_$name $command {*}$args]]
  11.  
  12. # wrap the coro in a shim
  13. proc ${ns}$name {args} [string map [list $x %N%] {
  14. tailcall %N% $args ;# wrap the args into a list for the old-style coro
  15. }]
  16.  
  17. # the two commands need to be paired for destruction
  18. trace add command $x delete ::delshim ${ns}$name
  19. trace add command ${ns}$name ::delshim $x
  20.  
  21. # tell it we created the one they requested
  22. return ${ns}$name
  23. }