Posted to tcl by dkf at Wed Nov 11 22:11:12 GMT 2015view raw

  1. ###
  2. # A utility for defining a domain specific language for TclOO systems
  3. ###
  4.  
  5. namespace eval ::oo::dialect {
  6. namespace export create
  7. }
  8.  
  9. # A stack of class names
  10. proc ::oo::dialect::Push {class} {
  11. ::variable class_stack
  12. lappend class_stack $class
  13. }
  14. proc ::oo::dialect::Peek {} {
  15. ::variable class_stack
  16. return [lindex $class_stack end]
  17. }
  18. proc ::oo::dialect::Pop {} {
  19. ::variable class_stack
  20. set class_stack [lrange $class_stack 0 end-1]
  21. }
  22.  
  23. ###
  24. # This proc will generate a namespace, a "mother of all classes", and a
  25. # rudimentary set of policies for this dialect.
  26. ###
  27. proc ::oo::dialect::create {name {parent ""}} {
  28. set NSPACE [NSNormalize $name]
  29. ::namespace eval $NSPACE {::namespace eval define {}}
  30. ###
  31. # Build the "define" namespace
  32. ###
  33. if {$parent eq ""} {
  34. ###
  35. # With no "parent" language, begin with all of the keywords in
  36. # oo::define
  37. ###
  38. foreach command [info commands ::oo::define::*] {
  39. set procname [namespace tail $command]
  40. interp alias {} ${NSPACE}::define::$procname {} \
  41. ::oo::dialect::DefineThunk $procname
  42. }
  43. # Create an empty dynamic_methods proc
  44. proc ${NSPACE}::dynamic_methods {class} {}
  45. namespace eval $NSPACE {
  46. ::namespace export dynamic_methods
  47. ::namespace eval define {::namespace export *}
  48. }
  49. set ANCESTORS {}
  50. } else {
  51. ###
  52. # If we have a parent language, that language already has the
  53. # [oo::define] keywords as well as additional keywords and behaviors.
  54. # We should begin with that
  55. ###
  56. set pnspace [NSNormalize $parent]
  57. apply [list parent {
  58. ::namespace export dynamic_methods
  59. ::namespace import ${parent}::dynamic_methods
  60. } $NSPACE] $pnspace
  61. apply [list parent {
  62. ::namespace import ${parent}::define::*
  63. ::namespace export *
  64. } ${NSPACE}::define] $pnspace
  65. set ANCESTORS [list ${pnspace}::object]
  66. }
  67. ###
  68. # Build our dialect template functions
  69. ###
  70.  
  71. interp alias {} ${NSPACE}::define {} \
  72. ::oo::dialect::Define $NSPACE
  73. interp alias {} ${NSPACE}::define::current_class {} \
  74. ::oo::dialect::Peek
  75. interp alias {} ${NSPACE}::define::aliases {} \
  76. ::oo::dialect::Aliases $NSPACE
  77. interp alias {} ${NSPACE}::define::superclass {} \
  78. ::oo::dialect::SuperClass $NSPACE
  79.  
  80. ###
  81. # Build the metaclass for our language
  82. ###
  83. ::oo::class create ${NSPACE}::class {
  84. superclass ::oo::dialect::MotherOfAllMetaClasses
  85. }
  86. # Wire up the create method to add in the extra argument we need; the
  87. # MotherOfAllMetaClasses will know what to do with it.
  88. ::oo::objdefine ${NSPACE}::class \
  89. method create {name {definitionScript ""}} \
  90. [list next $name ${NSPACE}::define $definitionScript]
  91.  
  92. ###
  93. # Build the mother of all classes. Note that $ANCESTORS is already
  94. # guaranteed to be a list in canonical form.
  95. ###
  96. uplevel #0 [string map [list %NSPACE% [list $NSPACE] %name% [list $name] %ANCESTORS% $ANCESTORS] {
  97. %NSPACE%::class create %NSPACE%::object {
  98. superclass %ANCESTORS%
  99. # Put MOACish stuff in here
  100. }
  101. }]
  102. }
  103.  
  104. # Support commands; not intended to be called directly.
  105.  
  106. proc ::oo::dialect::NSNormalize {qualname} {
  107. if {![string match ::* $qualname]} {
  108. set qualname [uplevel 2 {namespace current}]::$qualname
  109. }
  110. regsub -all {::+} $qualname "::"
  111. }
  112.  
  113. proc ::oo::dialect::DefineThunk {target args} {
  114. tailcall ::oo::define [Peek] $target {*}$args
  115. }
  116.  
  117. ###
  118. # Implementation of the languages' define command
  119. ###
  120. proc ::oo::dialect::Define {namespace class args} {
  121. Push $class
  122. try {
  123. if {[llength $args]==1} {
  124. namespace eval ${namespace}::define [lindex $args 0]
  125. } else {
  126. ${namespace}::define::[lindex $args 0] {*}[lrange $args 1 end]
  127. }
  128. ${namespace}::dynamic_methods $class
  129. } finally {
  130. Pop
  131. }
  132. }
  133.  
  134. ###
  135. # Implementation of how we specify the other names that this class will answer
  136. # to
  137. ###
  138.  
  139. proc ::oo::dialect::Aliases {namespace args} {
  140. set class [Peek]
  141. namespace upvar $namespace cname cname
  142. set cname($class) $class
  143. foreach name $args {
  144. set alias ::[string trimleft $name :]
  145. set cname($alias) $class
  146. }
  147. }
  148.  
  149. ###
  150. # Implementation of a superclass keyword which will enforce the inheritance of
  151. # our language's mother of all classes
  152. ###
  153.  
  154. proc ::oo::dialect::SuperClass {namespace args} {
  155. set class [Peek]
  156. namespace upvar $namespace class_info class_info cname cname
  157. dict set class_info($class) superclass 1
  158. set unique {}
  159. foreach item $args {
  160. set Item [NSNormalize $item]
  161. if {[info exists cname($Item)]} {
  162. set item $cname($Item)
  163. } elseif {[llength [info commands $Item]]} {
  164. set item $Item
  165. }
  166. dict set unique $item $item
  167. }
  168. set root ${namespace}::object
  169. if {$class ne $root} {
  170. dict set unique $root $root
  171. }
  172. tailcall ::oo::define $class superclass {*}[dict keys $unique]
  173. }
  174.  
  175. ###
  176. # Implementation of the common portions of the the metaclass for our
  177. # languages.
  178. ###
  179.  
  180. ::oo::class create ::oo::dialect::MotherOfAllMetaClasses {
  181. superclass ::oo::class
  182. constructor {define definitionScript} {
  183. $define [self] {
  184. superclass
  185. }
  186. $define [self] $definitionScript
  187. }
  188. }
  189.  
  190. package provide oo::dialect 0.1.1
  191.  

Comments

Posted by dkf at Wed Nov 11 22:24:59 GMT 2015 [text] [code]

Bug in line 90: should be "next \$name [list ${NSPACE}::define] \$definitionScript"