coclass

# coclass.tcl - classes which are also coros

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

oo::class create oo::coclass {
    method intervene {obj} {
	oo::objdefine $obj {
	    method __dispatch__ {} {
		set result {}
		while {1} {
		    set result [my {*}[::yieldm $result]]
		}
	    }
	    export __dispatch__
	}

	rename $obj ${obj}_
	coroutine $obj ${obj}_ __dispatch__

	trace add command $obj delete [list ${obj}_ destroy]
	trace add command ${obj}_ delete [list rename $obj {}]

	return $obj
    }

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

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

    superclass ::oo::class
}

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

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

if {0} {
    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]
}