/hmsl/fth/ob_bind.fth

https://github.com/philburk/hmsl · Forth · 368 lines · 323 code · 43 blank · 2 comment · 16 complexity · 3d473088d05bef3e3be741f1222bd5d1 MD5 · raw file

  1. \ @(#) ob_bind.fth 96/06/11 1.1
  2. \ BINDING for Object Oriented Development Environment
  3. \
  4. \ This code provides words for binding a message to the appropriate
  5. \ method for an object. Binding can occur at compile time ( "EARLY" ),
  6. \ or at run time, ( "LATE" )
  7. \
  8. \ Author: Phil Burk
  9. \ Copyright 1986 Phil Burk
  10. \
  11. \ MOD: PLB 11/29/86 Added MAC RO calls.
  12. \ For relocating systems, like on the MAC, relocatable tokens
  13. \ are stored in the dictionary, and absolute addresses are used at
  14. \ run time (when possible ). The object stack contains absolute
  15. \ addresses. The CFAs for methods are stored as relocatable tokens.
  16. \ MOD: PLB 5/13/87 Change OS-STACK-PTR to OSSTACKPTR for Mac
  17. \ MOD: PLB 5/24/87 Compile time check for Illegal Method.
  18. \ MOD: PLB 9/6/87 Add binding for Instance Objects.
  19. \ MOD: PLB 9/8/87 Preshift late bound offset in OB.LATE.BIND
  20. \ mdh 7/2/88 changed appropriate 'literal's to 'aliterals's
  21. \ MOD: PLB 7/25/88 USE OB.OBJ->CFA_BASE in OB.BIND.RUN
  22. \ MOD: PLB 11/27/90 Warn if recursive call to self.
  23. \ 00001 PLB 10/24/91 Allow binding to local variables.
  24. \ 00002 PLB 11/12/91 Call LOCAL.REFERENCE to force fetch.
  25. \ 00003 PLB 1/22/92 Assembled OB.BAD.CLASS? and added odd check.
  26. \ 00004 PLB 6/9/92 Use OB_VALID_OBJECT in OB.VALID?
  27. \ 00005 PLB 8/3/92 Objects put absolute address on stack.
  28. \ 19961106 PLB Port binding to objects passed as local variables to Pforth.
  29. ANEW TASK-OB_BIND
  30. ( Bind a method found in a CFA array. )
  31. ( Object base holds a pointer to an array of method CFAS )
  32. : OB.OBJ->CFA_BASE ( use_obj_base -- use_cfa_base )
  33. @ rel->use ( relocate rel_cfa_base )
  34. ;
  35. : OB.OBJ->CLASS ( use_obj_base -- use_class_base )
  36. @ rel->use ob_cfas -
  37. ;
  38. : OB.CFA@ ( use_obj_base method_index -- rel_method_cfa , CFA for method )
  39. cell* swap @ rel->use
  40. + @
  41. ;
  42. \ Error Checking for binding --------------------------------------
  43. : OB.VALID? ( abs_object -- true_if_ok )
  44. \ rel->use \ 00005
  45. dup in.dict? \ FIXME - what about instantiated objects?
  46. IF
  47. s@ obj_key ob_valid_object = \ 00004
  48. ELSE
  49. drop 0
  50. THEN
  51. ;
  52. : OB.IN.DICT? ( object -- flag )
  53. \ rel->use \ 00005
  54. in.dict?
  55. ;
  56. : OB.BAD.CLASS? ( use_class_base -- bad? )
  57. dup 1 and
  58. IF
  59. drop true
  60. ELSE
  61. ..@ ob_valid_key ob_valid_class = NOT
  62. THEN
  63. ;
  64. : OB.CHECK.CLASS ( use_class_base -- , abort if not a class )
  65. ob.bad.class?
  66. IF
  67. " OB.CHECK.CLASS" " Not an ODE class!"
  68. er_fatal er.report
  69. THEN
  70. ;
  71. : OB.CHECK.METHOD ( method_index use_class_base -- , abort if bad method )
  72. ..@ ob_#methods >
  73. IF " OB.CHECK.METHOD" " Method not supported for that object!"
  74. er_fatal er.report
  75. THEN
  76. ;
  77. : OB.CHECK.OBJECT ( use_object -- , abort if not an object )
  78. s@ obj_key ob_valid_object - \ 00004
  79. IF
  80. " OB.CHECK.OBJECT" " Not an ODE object!"
  81. er_fatal er.report
  82. THEN
  83. ;
  84. : OB.CHECK.BIND ( use_object method_index -- , abort if bad )
  85. swap dup ob.check.object
  86. ob.obj->class
  87. ob.check.method
  88. ;
  89. \ DO compile time checking for illegal methods.
  90. : OB.CHECK.ILLEGAL ( rel_method_cfa -- )
  91. rel->use 'c ob.bad.method =
  92. IF " OB.CHECK.ILLEGAL" " Method not defined for this class."
  93. er_fatal er.report
  94. THEN
  95. ;
  96. \ Compile code to execute method for an object. ---------------
  97. #HOST_PFORTH [IF]
  98. : OB.BIND.CFA ( use_obj_base rel_method_cfa -- , binds method to object )
  99. dup ob.check.illegal swap
  100. STATE @ IF
  101. [compile] aliteral
  102. compile os.push
  103. compile,
  104. compile os.drop
  105. ELSE
  106. os.push
  107. execute os.drop
  108. THEN
  109. ;
  110. : OB.BIND.INSTANCE.CFA ( instance_offset rel_method_cfa -- )
  111. dup ob.check.illegal swap
  112. state @
  113. IF [compile] literal
  114. compile os+push
  115. compile,
  116. compile os.drop
  117. ELSE
  118. os+push
  119. execute os.drop
  120. THEN
  121. ;
  122. [THEN]
  123. #HOST_AMIGA_JFORTH [IF]
  124. : OB.BIND.CFA ( use_obj_base rel_method_cfa -- , binds method to object )
  125. dup ob.check.illegal swap
  126. STATE @ IF
  127. [compile] aliteral
  128. compile os.push
  129. calladr,
  130. compile os.drop
  131. ELSE
  132. os.push
  133. execute os.drop
  134. THEN
  135. ;
  136. : OB.BIND.INSTANCE.CFA ( instance_offset rel_method_cfa -- )
  137. dup ob.check.illegal swap
  138. state @
  139. IF [compile] literal
  140. compile os+push
  141. calladr,
  142. compile os.drop
  143. ELSE
  144. os+push
  145. execute os.drop
  146. THEN
  147. ;
  148. [THEN]
  149. #HOST_MAC_H4TH [IF]
  150. : (OB.EXEC.METHOD) ( rel_method_cfa rel_obj_base -- )
  151. \ rel->use \ 00005
  152. os.push ro.execute os.drop
  153. ;
  154. : OB.BIND.CFA ( use_obj_base rel_method_cfa -- , binds method to object )
  155. dup ob.check.illegal
  156. STATE @ IF
  157. [compile] literal ( cfa )
  158. \ use->rel [compile] literal ( obj_base 00005 )
  159. [compile] Aliteral ( obj_base 00005 )
  160. compile (ob.exec.method)
  161. ELSE
  162. swap os.push ro.execute os.drop
  163. THEN
  164. ;
  165. : (OB.EXEC.METHOD.I) ( rel_method_cfa offset -- )
  166. os+push ro.execute os.drop
  167. ;
  168. : OB.BIND.INSTANCE.CFA ( instance_offset rel_method_cfa -- )
  169. dup ob.check.illegal
  170. state @
  171. IF
  172. [compile] literal ( cfa )
  173. [compile] literal ( offset )
  174. compile (ob.exec.method.i)
  175. ELSE
  176. swap os+push
  177. ro.execute os.drop
  178. THEN
  179. ;
  180. [THEN]
  181. variable OB-IF-CHECK-BIND
  182. variable OB-CURRENT-MIND \ currently compiling method index
  183. : OB.BIND.RUN ( object method_index*cell -- , run time binding act)
  184. >r
  185. \ rel->use \ 00005
  186. ob-if-check-bind @
  187. IF dup r@ cell/ ob.check.bind
  188. THEN
  189. dup os.push ( push object onto object stack )
  190. @ rel->use r> + ( index to method cfa )
  191. @ ( rel->use ) execute ( Perform method on object. )
  192. os.drop
  193. ;
  194. : OB.LATE.BIND ( [object] method_index -- , do late binding of method )
  195. \ object not present at compile time.
  196. STATE @
  197. IF
  198. cell* ( preshift for faster run time )
  199. [compile] literal ( save method index for late binding )
  200. compile ob.bind.run
  201. ELSE cell* ob.bind.run
  202. THEN
  203. ;
  204. : SELF ( -- rel_obj_base, of_self )
  205. os.copy
  206. \ use->rel ( %R 00005 )
  207. ;
  208. EXISTS? [] NOT [IF]
  209. : [] ( -- , use late binding if 'method: []' )
  210. " OBJECT USE" " '[]' CAN ONLY BE AFTER A METHOD"
  211. er_fatal er.report
  212. ;
  213. [THEN]
  214. : SUPER ( --- , stub for superbinding )
  215. " OBJECT USE" " 'SUPER' can only be used inside a METHOD definition"
  216. er_fatal er.report
  217. ;
  218. \ Binding with super-dooper uses the method defined in a superclasses'
  219. \ superclass.
  220. : SUPER-DOOPER ( --- , stub for superbinding with skip )
  221. " OBJECT USE"
  222. " 'SUPER-DOOPER' can only be used inside a METHOD definition"
  223. er_fatal er.report
  224. ;
  225. #HOST_AMIGA_JFORTH [IF]
  226. : OB.BIND.'BASE ( CFA -- , bind CFA to current object )
  227. ?comp calladr,
  228. ;
  229. [THEN]
  230. #HOST_PFORTH [IF]
  231. : OB.BIND.'BASE ( CFA -- , bind CFA to current object )
  232. ?comp compile,
  233. ;
  234. [THEN]
  235. #HOST_MAC_H4th [IF]
  236. : OB.BIND.'BASE ( rel_CFA -- , bind CFA to current object )
  237. ?comp [compile] literal compile ro.execute
  238. ;
  239. [THEN]
  240. \ These words work off of a variable that contains a use_cfa_base.
  241. : OB.BIND.VAR ( method_index cfa_base_variable -- , bind from that variable )
  242. @ swap cell* + @ ( -- method_cfa )
  243. dup ob.check.illegal
  244. ob.bind.'base ( %? )
  245. ;
  246. : OB.BIND.INSTANCE ( method_index pfa_object_def -- )
  247. dup ..@ obi_offset ( get offset )
  248. -rot s@ obi_rel_class .. ob_cfas ( -- off mi acfas )
  249. swap cell* + @
  250. ob.bind.instance.cfa
  251. ;
  252. : OB.BIND.NORMAL ( method_index pfa_object -- )
  253. dup rot 2dup ob.check.bind
  254. ob.cfa@ ob.bind.cfa
  255. ;
  256. : OB.EARLY.BIND ( method_index cfa_object -- )
  257. cfa->pfa
  258. ob-state @ ob_def_class =
  259. IF dup ob-current-class @
  260. ob.is.instance? ( Check to see if this is an Instance Object.)
  261. IF ob.bind.instance
  262. ELSE ob.bind.normal
  263. THEN
  264. ELSE ob.bind.normal
  265. THEN
  266. ;
  267. : OB.FIND.OBJECT { | $name cfa -- cfa , abort if not found }
  268. 0 -> cfa
  269. bl word -> $name
  270. \ ." Word = " $name count type cr
  271. \
  272. \ is this a local variable
  273. local-compiler @ ?dup
  274. IF ( -- 'compiler )
  275. $name swap execute
  276. IF \ if so compile reference and use late binding
  277. ['] [] -> cfa
  278. THEN
  279. THEN
  280. \ do we already have a winner
  281. cfa 0=
  282. IF
  283. $name find NOT
  284. IF
  285. >newline count type ." ?" cr
  286. " OB.FIND.OBJECT" " Object not found!"
  287. er_fatal er.report
  288. THEN
  289. -> cfa
  290. THEN
  291. cfa
  292. ;
  293. : OB.CHECK.RECURSE ( method_index -- , warn in recurse: self )
  294. ob-current-mind @ =
  295. IF
  296. " OB.CHECK.RECURSE" " Recursive message to self!"
  297. er_warning er.report
  298. current-method @ id. ." SELF" cr
  299. THEN
  300. ;
  301. : OB.BIND ( method_index <object> -- , bind )
  302. ob.find.object ( -- mi cfa )
  303. CASE ( Different types of binding. )
  304. \ Assume rel_obj_base also on stack at runtime for late binding.
  305. 'c []
  306. OF ob.late.bind
  307. ENDOF
  308. \
  309. 'c SELF
  310. OF dup ob.check.recurse
  311. ob-self-cfas ob.bind.var
  312. ENDOF
  313. \
  314. 'c SUPER
  315. OF ob-super-cfas ob.bind.var
  316. ENDOF
  317. \
  318. 'c SUPER-DOOPER
  319. OF ob-dooper-cfas ob.bind.var
  320. ENDOF
  321. \
  322. \ Bind named object.
  323. ob.early.bind 0 ( needs zero for dropping )
  324. ENDCASE
  325. ;