Posted to tcl by colin at Tue Jan 31 12:25:40 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. oo::class create oo::coclass {
  7. method intervene {obj} {
  8. oo::objdefine $obj {
  9. method __dispatch__ {} {
  10. set result {}
  11. while {1} {
  12. set result [my {*}[::yieldm $result]]
  13. }
  14. }
  15. export __dispatch__
  16. }
  17.  
  18. rename $obj ${obj}_
  19. coroutine $obj ${obj}_ __dispatch__
  20.  
  21. trace add command $obj delete [list ${obj}_ destroy]
  22. trace add command ${obj}_ delete [list rename $obj {}]
  23.  
  24. return $obj
  25. }
  26.  
  27. method new {args} {
  28. tailcall my intervene [next {*}$args]
  29. }
  30.  
  31. method create {name args} {
  32. tailcall my intervene [next $name {*}$args]
  33. }
  34.  
  35. superclass ::oo::class
  36. }
  37.  
  38. oo::coclass create Fred {
  39. method var {var} {
  40. variable $var
  41. return [set $var]
  42. }
  43. method error {} {
  44. error "ERROR"
  45. }
  46.  
  47. constructor {args} {
  48. variable {*}$args
  49. }
  50. }
  51.  
  52. if {0} {
  53. set fred [Fred new a 1 b 2 c 3]
  54. puts [$fred var a]
  55. if {[catch {$fred error}]} {
  56. puts stderr "CAUGHT"
  57. }
  58. puts [$fred var b]
  59. }