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

# 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
    }