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
}

======


<<categories>>Enter Category Here