/hmsl/fth/obmethod.fth

https://github.com/philburk/hmsl · Forth · 272 lines · 245 code · 27 blank · 0 comment · 19 complexity · 5b7a9a37db837a4a435c0a042e543aed MD5 · raw file

  1. \ @(#) obmethod.fth 96/06/11 1.1
  2. \ This file defines the words used to define METHODS for a class.
  3. \ Methods are used to manipulate an objects instance variables.
  4. \
  5. \ Author: Phil Burk
  6. \ Copyright 1986 Phil Burk
  7. \
  8. \ MOD: PLB 11/29/86 Store CFAs in relocatable form for MAC
  9. \ MOD: PLB 2/10/87 Catch redeclared Methods!
  10. \ MOD: PLB 9/5/87 Add METHODS.OF and other tools.
  11. \ MOD: PLB 9/10/87 Attempt smart forget.
  12. \ MOD: PLB 11/16/87 Add CURRENT.OBJECT
  13. \ MOD: PLB 1/13/87 Use PFA for backlinking methods instead of NFA.
  14. \ MOD: PLB 9/13/88 Add [FORGET] to eliminate need for MRESET
  15. \ MOD: PLB 5/22/89 Add 0 ob-state ! to [FORGET]
  16. \ MOD: PLB 9/22/89 Fix stack checking for H4th.
  17. \ MOD: PLB 12/15/89 Add Defining Class for METHODS.OF
  18. \ MOD: PLB 3/31/92 Added INHERIT.METHOD
  19. \ 00001 PLB 8/3/92 Objects put absolute address on stack.
  20. ANEW TASK-OBMETHOD
  21. : MI++ ( -- index , allocate new method index )
  22. mi-next @ ( current )
  23. dup 1+ mi-next ! ( increment )
  24. ;
  25. \ Method contents:
  26. \ CELL 0 = method index.
  27. \ CELL 1 = method back link (in relocatable form ).
  28. \ Holds PFA of last defined method, relocatable.
  29. CREATE METHOD-LAST 0 ,
  30. : (METHOD) ( <name:> -- , declare method for later definition )
  31. CREATE
  32. here ( for linking )
  33. mi++ , ( cell1: set index )
  34. method-last @ , ( cell2: back pointer )
  35. use->rel method-last ! ( point to PFA of this method. )
  36. immediate ( make it immediate )
  37. DOES> @ ob.bind ( bind message to object )
  38. ;
  39. : METHOD ( <name:> -- , declare method if new )
  40. >in @ >r \ save input pointer
  41. ho.find.pfa
  42. r> >in ! \ restore input pointer
  43. IF
  44. @ mi-next <
  45. IF bl word count type ." - method already declared." cr
  46. ELSE (method)
  47. THEN
  48. ELSE (method)
  49. THEN
  50. ;
  51. : OB.MIND@ ( <WORD> -- INDEX , return index )
  52. ho.find.pfa NOT
  53. IF
  54. " OB.MIND@" " Method not declared!"
  55. ER_FATAL ER.REPORT
  56. ELSE ( save NFA of method for debugger )
  57. dup pfa->nfa current-method ! @
  58. THEN
  59. ;
  60. \ Pairs checking for Method definitions.
  61. : OB.CHECK:M ( flag -- , report pairing error if flag different )
  62. dup ob-inside-:m @ =
  63. IF not ob-inside-:m !
  64. ELSE drop " OB.CHECK:M" " Missing :M or ;M in class definition!"
  65. er_fatal er.report
  66. THEN
  67. ;
  68. \ :M is one of the most complicated words in the system.
  69. \ It generates a headerless secondary with some object stack manipulations
  70. \ at the beginning and end.
  71. \ It will have to be hand tweaked for each FORTH because of
  72. \ differences in the compilers.
  73. : :M ( <method> -- , COMPILE A METHOD FOR A CLASS )
  74. false ob.check:m
  75. ob.mind@ dup ob-current-mind !
  76. :noname ( -- mi exectoken , save exectoken )
  77. \
  78. \ Calculate offset into cfa table for this method.
  79. swap cell* ( -- cfa moffset )
  80. \ Store CFA in methods table.
  81. ob-current-class @ ob_cfas + ( -- base_cfas ) + !
  82. ;
  83. defer ;M immediate
  84. : <;M> ( -- , Terminate method definition )
  85. true ob.check:m
  86. current-method off
  87. -1 ob-current-mind !
  88. [compile] ; ( Go back to interpretation mode , checks stack )
  89. ; immediate
  90. \ Use deferred ;M for Locals and Debugger.
  91. ' <;M> is ;M
  92. 0 MI-NEXT ! ( reset method counter )
  93. METHOD INIT: ( INIT: MUST have method index = 0 !!! )
  94. \ This is handy for inside Forth words called from a method.
  95. : CURRENT.OBJECT ( -- object )
  96. os.copy
  97. \ use->rel \ 00001
  98. ;
  99. create MRESET-WARN true ,
  100. : MRESET ( <method> -- )
  101. 32 word
  102. mreset-warn @
  103. IF ." MRESET " $type
  104. ." is no longer needed!" cr
  105. ELSE drop
  106. THEN
  107. ;
  108. : [FORGET] ( -- , reset method index )
  109. [forget]
  110. method-last @ rel->use ( get last method )
  111. BEGIN dup here > ( is it forgotten )
  112. WHILE ( -- method_pfa )
  113. cell+ @ if.rel->use
  114. REPEAT
  115. dup if.use->rel method-last ! ( set pointer to last )
  116. @ 1+ mi-next ! ( reset index so CFA tables don't grow)
  117. 0 ob-state ! ( reset state to avoid :CLASS warnings )
  118. ;
  119. : METHOD.LINK ( method_PFA -- index previous_pfa )
  120. dup @ swap cell+ @ ?dup
  121. IF rel->use
  122. ELSE 0 ( for the Mac )
  123. THEN
  124. ;
  125. : (.METHOD) ( method_pfa method_index -- , print it )
  126. 4 .r space pfa->nfa id.
  127. ;
  128. : ALL.METHODS ( -- list all methods )
  129. cr method-last @ rel->use
  130. BEGIN dup
  131. WHILE dup method.link -rot
  132. (.method) cr ?pause
  133. REPEAT drop
  134. ;
  135. variable OB-SCRATCH
  136. : ?DEFINING.CLASS ( method_index pfa_class -- pfa_class' )
  137. \ Scan backwards in Class list to find first occurrence of method.
  138. \ Do this by checking superclass for bad method, index overrange,
  139. \ or 0 pointer.
  140. 2dup method@ >r ( cfa to match with )
  141. \ Give up if 0 super link.
  142. BEGIN dup ..@ ob_super dup ob-scratch ! ( non-zero? )
  143. IF ( super class = 0 for object class )
  144. \ Give up if method count of superclass too low.
  145. ob-scratch @ ..@ ob_#methods 2 pick >
  146. \ Give up if method CFA doesn't match
  147. IF over ob-scratch @ method@ r@ =
  148. IF drop ob-scratch @ ( use super ) false
  149. ELSE true
  150. THEN
  151. ELSE true
  152. THEN
  153. ELSE true
  154. THEN
  155. UNTIL rdrop nip
  156. ;
  157. : METHODS.OF ( <class> -- , list valid methods for class )
  158. cr ho.find.pfa
  159. IF dup ob.check.class
  160. >r
  161. \ Start with last method defined, scan all methods,
  162. \ print it if its method cfa is not the OB.BAD.METHOD cfa.
  163. method-last @ rel->use
  164. BEGIN dup ?pause
  165. \ Link to next method header in dictionary.
  166. WHILE dup method.link -rot ( -- prev pfa i )
  167. \ Check to see if class method table is big enough.
  168. dup r@ ..@ ob_#methods < ( -- prev pfa i f )
  169. IF ( prev pfa index )
  170. \ Compare CFA of method.
  171. dup r@ method@ 'c ob.bad.method -
  172. IF tuck (.method) 4 spaces
  173. r@ ?defining.class pfa->nfa
  174. BL 20 emit-to-column id. cr
  175. ELSE 2drop
  176. THEN
  177. ELSE 2drop
  178. THEN
  179. REPEAT drop
  180. rdrop
  181. ELSE " METHODS.OF" " Not a class!"
  182. er_fatal er.report
  183. THEN
  184. ;
  185. : IS.SUPER? { pfa_class1 pfa_class2 | flag -- flag , is class2 a superclass of class1 }
  186. false -> flag
  187. pfa_class1
  188. BEGIN
  189. ..@ ob_super ?dup
  190. WHILE
  191. dup pfa_class2 =
  192. IF
  193. true -> flag
  194. THEN
  195. REPEAT
  196. flag
  197. ;
  198. : INHERIT.METHOD ( <method> <class> -- )
  199. ob-state @ 0=
  200. abort" INHERIT.METHOD only valid between :CLASS and ;CLASS"
  201. \
  202. \ get method index of method given
  203. ho.find.pfa NOT
  204. IF " INHERIT.METHOD" " METHOD not found"
  205. ER_FATAL ER.REPORT
  206. THEN ( -- method-pfa )
  207. @ >r \ get method index
  208. \
  209. \ get class
  210. ho.find.pfa NOT
  211. IF " INHERIT.METHOD" " CLASS not found"
  212. ER_FATAL ER.REPORT
  213. THEN ( -- class-pfa )
  214. dup ob.check.class
  215. \
  216. \ warn if not superclass of current class
  217. ob-current-class @ over is.super? not
  218. IF
  219. ." Warning from INHERIT.METHOD. "
  220. dup pfa->nfa id.
  221. ." not a SUPER-class of "
  222. ob-current-class @ pfa->nfa id. cr
  223. THEN
  224. \
  225. \ get cfa for that method
  226. .. ob_cfas
  227. r@ cells + @ ( method cfa )
  228. \
  229. \ save in current class
  230. ob-current-class @ ( -- pfa-class )
  231. .. ob_cfas
  232. r> cells + !
  233. ;
  234. \ Required Initialization
  235. : OB.INIT ( -- )
  236. os.sp! ( set object stack pointers )
  237. 0 ob-state !
  238. 0 ob-current-class !
  239. 0 ob-self-cfas !
  240. 0 ob-super-cfas !
  241. 0 ob-dooper-cfas !
  242. true ob-if-check-bind !
  243. ;
  244. : OB.TERM ( -- )
  245. ;