classes which are also coroutines

# coclass.tcl - classes which are also coros
package provide oo::coclass 1.0

if {[info commands ::yieldm] eq ""} {
    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
    # __dispatch__ shims between the fake object (coro) and the actual 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
    }

    # new - create a new instance of this class,
    # shimmed so it's actually being invoked as a coro
    method new {args} {
	tailcall my intervene [next {*}$args]
    }

    # new - create a new instance of this class,
    # shimmed so it's actually being invoked as a coro
    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
	if {"__dispatch__" ni [info class methods [self] -all]} {
	    oo::define [self] {
		method __dispatch__ {} {
		    set self [info coroutine]	;# this is the coroutine
		    set obj [self]		;# the original obj being forwarded to
		    
		    set result {}		;# method invocation result
		    catch {
			while {1} {
			    # invoke whatever's passed in and return the result
			    set result [my {*}[::yieldm $result]]
			}
		    } e eo
		    
		    # The method invocation errored
		    # this will kill the coro if we return it, but it must be returned to caller
		    # So we must make another identically named coro and then return the error
		    # from this inevitably doomed coro.
		    rename $self ${self}_dead_
		    if {[catch {::oo::coclass corogone $obj $self} e1 eo1]} {
			# we failed to make the replacement coro - here's why
			puts stderr "corogone fail: $e1 ($eo1)"
		    }

		    return -options $eo $e	;# return the error result to the caller
		    # this instance of the coro goes away now but will be reinstated via [trace]
		}
		export __dispatch__
	    }
	}

	return [self]
    }
}

if {[info script] eq $argv0} {
    oo::coclass create Fred {
	method Var {var} {
	    variable $var
	    return [set $var]
	}
	method error {} {
	    error "ERROR"
	}

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

    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]
    $fred destroy
}