Posted to tcl by colin at Fri Aug 13 01:43:22 GMT 2010view raw

  1. # the new yieldm multi-arg coro call does not exist.
  2. # this is the older coroutine implementation
  3. interp alias {} ::yieldm {} ::yield
  4.  
  5. proc ::delshim {name x y op} {
  6. catch {::rename $name {}} ;# delete shim
  7. }
  8.  
  9. proc ::Coroutine {name command args} {
  10. # determine the appropriate namespace for coro creation
  11. set ns [namespace qualifiers $name]
  12. if {![string match ::* $ns]} {
  13. set ns [uplevel 1 namespace current]::$ns
  14. }
  15. set name [namespace tail $name]
  16.  
  17. # create a like-named coro
  18. set x [uplevel 1 [list ::coroutine ${ns}_$name $command {*}$args]]
  19.  
  20. # wrap the coro in a shim
  21. proc ${ns}$name {args} [string map [list $x %N%] {
  22. tailcall %N% $args ;# wrap the args into a list for the old-style coro
  23. }]
  24.  
  25. # the two commands need to be paired for destruction
  26. trace add command ${ns}_$name delete [list ::delshim ${ns}$name]
  27. trace add command ${ns}$name delete [list ::delshim ${ns}_$name]
  28.  
  29. # tell it we created the one they requested
  30. return ${ns}$name
  31. }