classes which are also coros - work around lack of yieldto

# coclass.tcl - classes which are also coros

namespace eval tcl::unsupported namespace export yieldm
namespace import tcl::unsupported::yieldm

if {[info commands ::oo::define::classmethod] eq ""} {
    proc ::oo::define::classmethod {name {args {}} {body {}}} {
	set class [lindex [info level -1] 1]
	set classmy [info object namespace $class]::my
	if {[llength [info level 0]] == 4} {
	    uplevel 1 [list self method $name $args $body]
	}
	uplevel 1 [list forward $name $classmy $name]
    }
}

oo::class create oo::coclass {
    # objgone - the object has died - kill the coro too
    classmethod objgone {obj coro} {
	trace delete command $coro delete [list ::oo::coclass corogone $obj $coro]
	rename $coro {}
    }

    # corogone - the coro has gone - restart it if the object is still there.
    classmethod corogone {obj coro} {
	if {[info commands $obj] ne ""} {
	    # (re)create a coro attachment to $obj
	    coroutine $coro $obj __dispatch__	;# create our coro with the object's name
	    trace add command $coro delete [list ::oo::coclass corogone $obj $coro]
	} else {
	    # both the object and the coro have gone.
	}
    }

    # intervene - add a __dispatch__ method to the object
    method intervene {obj} {
	rename $obj ${obj}_	;# move the object out of the way
	trace add command ${obj}_ delete [list ::oo::coclass::objgone ${obj}_ $obj]
	my corogone ${obj}_ $obj
	return $obj
    }

    method new {args} {
	tailcall my intervene [next {*}$args]
    }

    method create {name args} {
	tailcall my intervene [next $name {*}$args]
    }

    superclass ::oo::class
    constructor {args} {
	next {*}$args

	# add a __dispatch__ method to the class to shim between coro interface and object instance
	oo::define [self] {
	    method __dispatch__ {} {
		set self [info coroutine]
		set obj [self]
		set result {}
		catch {
		    while {1} {
			set result [my {*}[::yieldm $result]]
		    }
		} e eo

		# The coro died - we must make another and still return this error
		rename $self ${self}_dead_
		if {[catch {::oo::coclass corogone $obj $self} e1 eo1]} {
		    puts stderr "corogone fail: $e1 $eo1"
		}

		return -options $eo $e
	    }
	    export __dispatch__
	}

	return [self]
    }
}

oo::coclass create Fred {
    method Var {var} {
	variable $var
	return [set $var]
    }
    method error {} {
	error "ERROR"
    }

    constructor {args} {
	variable {*}$args
    }
}

if {1} {
    set fred [Fred new a 1 b 2 c 3]
    puts [$fred Var a]
    if {[catch {$fred error}]} {
	puts stderr "CAUGHT"
    }
    puts [$fred Var b]
}