CMcC: I often want to instantiate an object then call it via coroutine - it's useful for lightweight threading (green threads)
Here's an easy way to do it. It extends TclOO class as coclass. coclass creates the object, but then moves it aside and substitutes for it a coroutine which forwards method invocations, collects and returns their results. Method invocations are therefore also coroutine invocations.
What this allows you to do is effectively block via yield in any method. The dispatcher needs to be more complex to enable this to work effectively, but this is quite cool :)
# 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
# __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
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} {
set result [my {*}[::yieldm $result]] ;# invoke whatever's passed in
}
} 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
}
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]
$fred destroy
}