Posted to tcl by colin at Wed Feb 01 02:05:08 GMT 2012view raw
- # 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]
- }