Posted to tcl by colin at Tue Jan 31 12:25:40 GMT 2012view raw
- # 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]
- }