Posted to tcl by colin at Sun Mar 18 01:46:37 GMT 2012view raw

  1. # coclass.tcl - classes which are also coros
  2. package provide oo::coclass 1.0
  3.  
  4. if {[info commands ::yieldm] eq ""} {
  5. namespace eval tcl::unsupported namespace export yieldm
  6. namespace import tcl::unsupported::yieldm
  7. }
  8. if {[info commands ::oo::define::classmethod] eq ""} {
  9. proc ::oo::define::classmethod {name {args {}} {body {}}} {
  10. set class [lindex [info level -1] 1]
  11. set classmy [info object namespace $class]::my
  12. if {[llength [info level 0]] == 4} {
  13. uplevel 1 [list self method $name $args $body]
  14. }
  15. uplevel 1 [list forward $name $classmy $name]
  16. }
  17. }
  18.  
  19. oo::class create oo::coclass {
  20. # objgone - the object has died - kill the coro too
  21. classmethod objgone {obj coro} {
  22. trace delete command $coro delete [list ::oo::coclass corogone $obj $coro]
  23. rename $coro {}
  24. }
  25.  
  26. # corogone - the coro has gone - restart it if the object is still there.
  27. classmethod corogone {obj coro} {
  28. if {[info commands $obj] ne ""} {
  29. # (re)create a coro attachment to $obj
  30. coroutine $coro $obj __dispatch__ ;# create our coro with the object's name
  31. trace add command $coro delete [list ::oo::coclass corogone $obj $coro]
  32. } else {
  33. # both the object and the coro have gone.
  34. }
  35. }
  36.  
  37. # intervene - add a __dispatch__ method to the object
  38. # __dispatch__ shims between the fake object (coro) and the actual object.
  39. method intervene {obj} {
  40. rename $obj ${obj}_ ;# move the object out of the way
  41. trace add command ${obj}_ delete [list ::oo::coclass::objgone ${obj}_ $obj]
  42. my corogone ${obj}_ $obj
  43. return $obj
  44. }
  45.  
  46. # new - create a new instance of this class,
  47. # shimmed so it's actually being invoked as a coro
  48. method new {args} {
  49. tailcall my intervene [next {*}$args]
  50. }
  51.  
  52. # new - create a new instance of this class,
  53. # shimmed so it's actually being invoked as a coro
  54. method create {name args} {
  55. tailcall my intervene [next $name {*}$args]
  56. }
  57.  
  58. superclass ::oo::class
  59. constructor {args} {
  60. next {*}$args
  61.  
  62. # add a __dispatch__ method to the class to shim between coro interface and object instance
  63. if {"__dispatch__" ni [info class methods [self] -all]} {
  64. oo::define [self] {
  65. method __dispatch__ {} {
  66. set self [info coroutine] ;# this is the coroutine
  67. set obj [self] ;# the original obj being forwarded to
  68.  
  69. set result {} ;# method invocation result
  70. catch {
  71. while {1} {
  72. # invoke whatever's passed in and return the result
  73. set result [my {*}[::yieldm $result]]
  74. }
  75. } e eo
  76.  
  77. # The method invocation errored
  78. # this will kill the coro if we return it, but it must be returned to caller
  79. # So we must make another identically named coro and then return the error
  80. # from this inevitably doomed coro.
  81. rename $self ${self}_dead_
  82. if {[catch {::oo::coclass corogone $obj $self} e1 eo1]} {
  83. # we failed to make the replacement coro - here's why
  84. puts stderr "corogone fail: $e1 ($eo1)"
  85. }
  86.  
  87. return -options $eo $e ;# return the error result to the caller
  88. # this instance of the coro goes away now but will be reinstated via [trace]
  89. }
  90. export __dispatch__
  91. }
  92. }
  93.  
  94. return [self]
  95. }
  96. }
  97.  
  98. if {[info script] eq $argv0} {
  99. oo::coclass create Fred {
  100. method Var {var} {
  101. variable $var
  102. return [set $var]
  103. }
  104. method error {} {
  105. error "ERROR"
  106. }
  107.  
  108. constructor {args} {
  109. variable {*}$args
  110. }
  111. }
  112.  
  113. set fred [Fred new a 1 b 2 c 3]
  114. puts [$fred Var a]
  115. if {[catch {$fred error}]} {
  116. puts stderr "CAUGHT"
  117. }
  118. puts [$fred Var b]
  119. $fred destroy
  120. }