Posted to tcl by colin at Wed Feb 01 02:05:08 GMT 2012view raw

  1. # coclass.tcl - classes which are also coros
  2.  
  3. namespace eval tcl::unsupported namespace export yieldm
  4. namespace import tcl::unsupported::yieldm
  5.  
  6. if {[info commands ::oo::define::classmethod] eq ""} {
  7. proc ::oo::define::classmethod {name {args {}} {body {}}} {
  8. set class [lindex [info level -1] 1]
  9. set classmy [info object namespace $class]::my
  10. if {[llength [info level 0]] == 4} {
  11. uplevel 1 [list self method $name $args $body]
  12. }
  13. uplevel 1 [list forward $name $classmy $name]
  14. }
  15. }
  16.  
  17. oo::class create oo::coclass {
  18. # objgone - the object has died - kill the coro too
  19. classmethod objgone {obj coro} {
  20. trace delete command $coro delete [list ::oo::coclass corogone $obj $coro]
  21. rename $coro {}
  22. }
  23.  
  24. # corogone - the coro has gone - restart it if the object is still there.
  25. classmethod corogone {obj coro} {
  26. if {[info commands $obj] ne ""} {
  27. # (re)create a coro attachment to $obj
  28. coroutine $coro $obj __dispatch__ ;# create our coro with the object's name
  29. trace add command $coro delete [list ::oo::coclass corogone $obj $coro]
  30. } else {
  31. # both the object and the coro have gone.
  32. }
  33. }
  34.  
  35. # intervene - add a __dispatch__ method to the object
  36. method intervene {obj} {
  37. rename $obj ${obj}_ ;# move the object out of the way
  38. trace add command ${obj}_ delete [list ::oo::coclass::objgone ${obj}_ $obj]
  39. my corogone ${obj}_ $obj
  40. return $obj
  41. }
  42.  
  43. method new {args} {
  44. tailcall my intervene [next {*}$args]
  45. }
  46.  
  47. method create {name args} {
  48. tailcall my intervene [next $name {*}$args]
  49. }
  50.  
  51. superclass ::oo::class
  52. constructor {args} {
  53. next {*}$args
  54.  
  55. # add a __dispatch__ method to the class to shim between coro interface and object instance
  56. oo::define [self] {
  57. method __dispatch__ {} {
  58. set self [info coroutine]
  59. set obj [self]
  60. set result {}
  61. catch {
  62. while {1} {
  63. set result [my {*}[::yieldm $result]]
  64. }
  65. } e eo
  66.  
  67. # The coro died - we must make another and still return this error
  68. rename $self ${self}_dead_
  69. if {[catch {::oo::coclass corogone $obj $self} e1 eo1]} {
  70. puts stderr "corogone fail: $e1 $eo1"
  71. }
  72.  
  73. return -options $eo $e
  74. }
  75. export __dispatch__
  76. }
  77.  
  78. return [self]
  79. }
  80. }
  81.  
  82. oo::coclass create Fred {
  83. method Var {var} {
  84. variable $var
  85. return [set $var]
  86. }
  87. method error {} {
  88. error "ERROR"
  89. }
  90.  
  91. constructor {args} {
  92. variable {*}$args
  93. }
  94. }
  95.  
  96. if {1} {
  97. set fred [Fred new a 1 b 2 c 3]
  98. puts [$fred Var a]
  99. if {[catch {$fred error}]} {
  100. puts stderr "CAUGHT"
  101. }
  102. puts [$fred Var b]
  103. }