home *** CD-ROM | disk | FTP | other *** search
/ Borland Programmer's Resource / Borland_Programmers_Resource_CD_1995.iso / ntcode / jx4nt125 / obj4th / multioop.utf (.txt) < prev    next >
Encoding:
Null Bytes Alternating  |  1995-05-19  |  27.6 KB  |  411 lines
  1. \ multioop.utf ...
  2. \ a multiple-inheritance object-oriented extension to ANS-Forth
  3. \ ANS Forth compliant source code is Copyright (c)1992-1994 by
  4. \ Jack J. Woehr, P.O. Box 51, Golden, Colorado 80402-0051
  5. \ jax@well.sf.ca.us 72203.1320@compuserve.com
  6. \ SYSOP RCFB (303) 278-0364 2400/9600/14400
  7. \ All Rights Reserved
  8. \ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  9. \ This is free software and can be modified and redistributed under
  10. \ certain conditions described in the file COPYING.TXT. The
  11. \ Disclaimer of Warranty and License for this free software are also
  12. \ contained in the file COPYING.TXT.
  13. \ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  14. \ $Revision: 1.1 $
  15. \
  16. \ Dependencies:  NIP TUCK U.R TRUE FALSE from Core Extensions.
  17. \                D= from Double.
  18. \                DEFER from DEFER.UTF
  19. \ A Standard System still exists after this code is loaded.
  20.  
  21. : PROVIDES ( c-addr u "ccc< >" --)
  22.     BL WORD FIND NIP 0=
  23.     IF INCLUDED ELSE 2DROP THEN ;
  24.  
  25. S" UTILS\UTILS.UTF" PROVIDES .(
  26. S" UTILS\DEFER.UTF" PROVIDES DEFER
  27.  
  28. MARKER multioop.utf
  29.  
  30. .( Loading Multioop multiple-inheritance object extensions.) CR
  31.  
  32. \ A Standard System still exists after this code is loaded.
  33.  
  34. BASE @ HEX
  35.  
  36. \ ** Some Utility Words
  37. : OFF ( a-addr --) 0 SWAP ! ;
  38. : PERFORM ( a-addr --) @ EXECUTE ;
  39. : ?ENOUGH ( n --) DEPTH 1- > ABORT" Not enough arguments." ;
  40. : CELL ( -- n) 1 CELLS ;
  41. : CELL- ( n1 -- n2) CELL - ;
  42. : U/ ( u1 u2 -- u3) SWAP S>D ROT UM/MOD NIP ;
  43. : >= ( n1 n2 -- flag) 1- > ;
  44.  
  45.  
  46. \ ** The Method Stack .. nested method search and retrieval.
  47. \ Method stack will grow UPWARDS in memory. May make it easier
  48. \ to examine and comprehend DUMPs of method stack memory.
  49.  
  50. 40 CELLS CONSTANT #MSTACK-SIZE                \ methodstack size
  51.  
  52. \ MODE? RAM ( MODE? returns RAM or ROM compilation mode)
  53. \           ( Use for embedded systems)
  54. CREATE MSTACK #MSTACK-SIZE ALLOT        \ method stack
  55. \ ?MODE     ( Restores the RAM or ROM mode)
  56.  
  57. MSTACK #MSTACK-SIZE CELLS +
  58.     CONSTANT MSTACK-TOP                 \ top of methodstack
  59.  
  60. VARIABLE *MSTACK                        \ method stack pointer
  61.  
  62. \ Initialize method stack pointer to one entry before base of
  63. \ preincrementing MSTACK.
  64. : MSTACK.INIT ( --)
  65.         MSTACK CELL- *MSTACK !
  66. ; MSTACK.INIT
  67.  
  68. \ Test for incipient method stack overflow
  69. \ (i.e., address about to be preincremented too high in mem).
  70. : MSTACK-OVER? ( @mstack-ptr -- flag)
  71.         MSTACK-TOP >=
  72. ;
  73.  
  74. \ Test for incipient method stack underflow
  75. \ (i.e., address about to be postdecremented too low in memory).
  76. : MSTACK-UNDER? ( @mstack-ptr -- flag)
  77.         MSTACK <
  78. ;
  79.  
  80. \ Preincrement method stack pointer by size of one entry and push x.
  81. \ Exercise method stack security.
  82. : ++MSTACK! ( x --)
  83.         *MSTACK @ DUP
  84.         MSTACK-OVER? ABORT" Method stack overflow."
  85.         CELL+ TUCK ! *MSTACK !
  86. ;
  87.  
  88. \ Fetch x and postdecrement method stack pointer by size of one entry.
  89. \ Exercise method stack security.
  90. : @MSTACK-- ( -- x)
  91.         *MSTACK @ DUP
  92.         MSTACK-UNDER? ABORT" Method stack underflow."
  93.         DUP CELL- *MSTACK !
  94.         @
  95. ;
  96.  
  97. \ Operators analogous to Forth stack operators, some not needed.
  98.  
  99. \ : MSTACK-DUP        ( --)
  100. \        *MSTACK @ @ ++MSTACK!
  101. \ ;
  102.  
  103. : MSTACK-DROP ( --)
  104.         @MSTACK-- DROP
  105. ;
  106.  
  107. \ : MSTACK-SWAP ( --)
  108. \        @MSTACK-- @MSTACK--
  109. \        SWAP
  110. \        ++MSTACK! ++MSTACK!
  111. \ ;
  112.  
  113. \ : MSTACK-OVER ( --)
  114. \        *MSTACK @ CELL- @ ++MSTACK!
  115. \ ;
  116.  
  117. : MSTACK-DEPTH ( -- n)
  118.         *MSTACK @ MSTACK CELL- - CELL U/
  119. ;
  120.  
  121. \ Print out the MSTACK like .S in Forth
  122. : .MSTACK ( --)
  123.         MSTACK-DEPTH 0=
  124.         IF
  125.                 ." Method stack empty. "
  126.                 EXIT
  127.         THEN
  128.         MSTACK MSTACK-DEPTH #MSTACK-SIZE MIN 0
  129.         ?DO
  130.                 DUP I CELLS + @ 0A U.R
  131.         LOOP
  132.         DROP
  133. ;
  134.  
  135.  
  136. \ ** Methods
  137.  
  138. \ A method record is stored in the method list as two cells:
  139. \          /SELECTOR/VECTOR/
  140. 2 CELLS  CONSTANT #CELLS/SELECT
  141. CELL DUP CONSTANT /VECTOR
  142.          CONSTANT /INHERITANCE
  143.  
  144. \ Having located address of method , discard selector,
  145. \ execute method. Methods expect base object address of object
  146. \ to be present on data stack.
  147. : EXE-METHOD ( obj-addr selector selector-addr --)
  148.         NIP /VECTOR + PERFORM
  149. ;
  150.  
  151.  
  152. \ When a method is sought in a class method list, if SELECTOR
  153. \ is null, VECTOR should point to continuation elsewhere of method
  154. \ list, or to that of next inheritance class.
  155. \ If VECTOR null, end of list has been reached and method not found.
  156.  
  157. \ NEXT-CLASS is passed address of null SELECTOR which is found
  158. \ associated with a non-null VECTOR, so pushes next cell address
  159. \ past the location of that VECTOR as the next place to look in
  160. \ current class in case nesting into inheritance doesn't find a
  161. \ match. In such case, search will continue after popping method
  162. \ stack.
  163. : NEXT-CLASS ( sel-addr1 -- sel-addr2) ( M: -- sel-addr1+cells)
  164.         DUP
  165.         #CELLS/SELECT + ++MSTACK!
  166.         /INHERITANCE + @
  167. ;
  168.  
  169. \ If anything left on method stack, return to previous class
  170. : PREV-CLASS ( -- sel-addr2 | ABORT)
  171.         MSTACK-DEPTH 1 <
  172.         ABORT" Method not found."
  173.         @MSTACK--
  174. ;
  175.  
  176. \ Does selector on stack match embedded selector?
  177. : MATCH-METHOD? ( sel addr -- sel addr flag)
  178.         2DUP @ =
  179. ;
  180.  
  181. \ At end of this portion of a class's own method list, decide if
  182. \ there are more lists or inheritances.
  183. : END-OF-CLASS ( sel-addr -- sel-addr | ABORT)
  184.         DUP /INHERITANCE + @ 0=
  185.         IF
  186.                 DROP PREV-CLASS
  187.         ELSE
  188.                 NEXT-CLASS
  189.         THEN
  190. ;
  191.  
  192. \ Given the data address of an object, the selector sought and
  193. \ the address of the head of a class method list, begin
  194. \ dereferencing its list of methods and inheritance until a method
  195. \ is found failure causes ABORT.
  196. : FIND-METHOD ( obj-addr selector method-list-addr -- method-xt | ABORT)
  197.         MSTACK.INIT                \ Clear the deck!
  198.         BEGIN
  199.                 MATCH-METHOD? 0=
  200.         WHILE
  201.                 DUP @ 0=
  202.                 IF
  203.                         END-OF-CLASS
  204.                 ELSE
  205.                         #CELLS/SELECT +
  206.                 THEN
  207.  
  208.         REPEAT
  209. ;
  210.  
  211.  
  212. \ ** Objects & Classes
  213.  
  214. \ Object structure is in cell order:
  215. \        /TYPE/SIZE/PTR-TO-CLASS/PTR-TO-DATA
  216.  
  217. 0 CELLS CONSTANT /TYPE
  218. 1 CELLS CONSTANT /SIZE
  219. 2 CELLS CONSTANT /DATA
  220. 3 CELLS CONSTANT /CLASS
  221.  
  222. \ Class structure is in cell order:
  223. \        /TYPE/METHOD-LIST ..
  224. 1 CELLS CONSTANT /METHOD-LIST
  225.  
  226. \ The DOES> code for an object
  227. : DO-OBJ ( i*x selector obj-addr -- j*x)
  228.         TUCK
  229.         /CLASS + @ /METHOD-LIST +
  230.         FIND-METHOD
  231.         EXE-METHOD
  232. ;
  233.  
  234. \ Creating objects
  235. \ CLASSY if non-zero is the address of last selector/vector pair
  236. \ in the object under construction.
  237. VARIABLE CLASSY 
  238.  
  239. \ End a class definition by resetting CLASSY.
  240. : ;CLASS ( ADDR --)
  241.         CLASSY OFF
  242. ; ;CLASS        \ init for compile time use
  243.  
  244. \ What a CLASS does: create an object pointing back to its
  245. \ class which pushes its own address onto Forth data stack.
  246. \ Objects also contain records of "size" (#entries) and of
  247. \ "type" (size of one entry). This is the ROM version for
  248. \ VFSE-332.
  249. : CREATE-ROM-OBJ ( #entries class-addr "name" --)
  250.         2 ?ENOUGH           \ check stack depth
  251. \       MODE? >R            \ save address space
  252.         ( ROM)              \ objects are ROMmable
  253.         CREATE              \ create named object
  254.         DUP /TYPE + @       \ get size of one entry from class
  255.         ,                   \ store entry data type
  256.         OVER ,              \ next is "size" (#entries)
  257.         SWAP OVER           \ -- class-addr #entries class-addr        R: -- mode
  258.         /TYPE + @           \ get size of one entry from class
  259.         *                   \ times #entries is data space needed
  260.         ( RAM) HERE >R      \ save address to compile into object
  261.         ALLOT               \ allot correct num addr units in RAM
  262.         R> ( ROM) ,         \ compile data space
  263.         ,                   \ then pointer to class
  264. \       R> ?MODE            \ set back to RAM or ROM or whatever
  265.         DOES> ( i*x selector [self] -- j*x)
  266.                 DO-OBJ
  267. ;
  268.  
  269. \ Here is a RAM version for Jax4th and ZEN.
  270. : CREATE-RAM-OBJ ( #entries class-addr "name" --)
  271.         2 ?ENOUGH        \ check stack depth
  272.         CREATE                \ create named object
  273.         DUP /TYPE + @        \ get size of one entry from class
  274.         ,                \ store entry data type
  275.         OVER ,                \ next is "size" (#entries)
  276.         SWAP OVER        \ -- class-addr #entries class-addr        R: -- mode
  277.         /TYPE + @        \ get size of one entry from class
  278.         *                \ times #entries is data space needed
  279.         HERE 2 CELLS + ,        \ save address to compile into object
  280.         SWAP ,                \ then pointer to class
  281.         ALLOT                \ allot correct num addr units in RAM
  282.         DOES> ( i*x selector [self] -- j*x)
  283.                 DO-OBJ
  284. ;
  285.  
  286. \ Decide how to vector this in INIT-OOPS later in file.
  287. DEFER CREATE-OBJ
  288.  
  289. \ Start a class definition. create a class with no methods.
  290. \ The class will, at runtime, create objects pointing to itself
  291. \ of an address unit size per individual entry corresponding
  292. \ to the assigned value at class-creation time. This will
  293. \ work for RAM and RAM/ROM systems as long as MODEPRLD.F is
  294. \ loaded first.
  295. : CLASS: ( individual-entry-size "name" -- addr)
  296.         1 ?ENOUGH               \ "type" provided?
  297. \       MODE? >R                \ save address space selector
  298.         ( ROM) CREATE           \ create CLASS in ROM
  299.         ,                       \ save "type"
  300.         HERE CLASSY !           \ current end of method list
  301.         0 , 0 ,                 \ /0/0 terminator
  302.         0 , 0 ,                 \ extra one for after previous gets patched
  303. \       R> ?MODE                \ restore address space selector
  304.         DOES> ( size "name" --) \ runtime action
  305.                 CREATE-OBJ      \ creates objects
  306. ;
  307.  
  308. \ METHODIST non-zero contains method number under definition
  309. VARIABLE METHODIST
  310. METHODIST OFF        \ init for compile time use
  311.  
  312. \ Postincrementing count of defined methods.
  313. \ Methods are numbered 1 - 2^cell-bitsize.
  314. VARIABLE METHOD-POINTER
  315. : METHOD-POINTER.INIT ( n --)
  316.         METHOD-POINTER !
  317. ; 1 METHOD-POINTER.INIT
  318.  
  319. \ The current value of METHOD-POINTER has to be saved by
  320. \ the application somewhere in ROM and restored at powerup
  321. \ if compilation is to continue after an incremental
  322. \ ROMming of the system. INIT-OOPS takes this number as argument.
  323.  
  324. \ Patch class method list in order to continue it.
  325. : PATCH-CLASS ( vector selector --)
  326. \        MODE? >R ROM           \ we're comma-ing into ROM
  327.         HERE                    \ HERE is where /selector/vector goes
  328.         CLASSY @                \ get where we left off /0/0 in a CLASS
  329.         /VECTOR + !             \ store HERE to its vector
  330.         , ,                     \ store /selector/vector for new method
  331.         HERE CLASSY !           \ update pointer to current end of methods
  332.         0 , 0 ,                 \ store new /0/0 method list terminator
  333.         0 , 0 ,                 \ extra one for after previous gets patched
  334. \        R> ?MODE               \ restore address space selector
  335. ;       
  336.         
  337. \ Terminate a method definition
  338. : ;M ( --) ( R: sys --)
  339.         METHODIST @ 0= ABORT" No method currently being defined." 
  340.         POSTPONE ;        \ finish :NONAME definition
  341.         METHODIST @        \ get this method's selector
  342.         PATCH-CLASS        \ consume selector and :NONAME xt
  343.         METHODIST OFF        \ indicate no method being compiled
  344. ; IMMEDIATE
  345.  
  346. \ Create a new method which contains an embedded selector.
  347. \ The embedded selector is made a Forth CONSTANT if not
  348. \ yet defined. Don't create the CONSTANT if it's already defined.
  349. \ Careful about names passed to M: ... they had better either
  350. \ be undefined or a CONSTANT since M: executes them if found!
  351.  
  352. : M: ( "name" -- ) ( R: -- sys)
  353.         CLASSY @ 0= ABORT" No CLASS under construction."
  354.         >IN @                        \ save input pointer
  355.         BL WORD FIND 0=         \ 0 means didn't find
  356.         IF                        \ if didn't find ..
  357.                 DROP >IN !                \ restore input pointer
  358.                 METHOD-POINTER @        \ allocate a new method
  359.                 DUP CONSTANT                \ save number, create name
  360.                 1 METHOD-POINTER +!        \ increment method number
  361.         ELSE                        \ name was found
  362.                 NIP                \ drop >IN
  363.                 EXECUTE         \ get extant selector's CONSTANT value
  364.         THEN
  365.         METHODIST !                \ store current methodnum
  366.         :NONAME                 \ start headerless definition
  367. ;       
  368.  
  369. \ INHERITS adds a CLASS inheritance to current position in
  370. \ method list of class under definition. INHERITS doesn't
  371. \ check to make sure that "name" is a CLASS so be careful!
  372. \ This could be fixed by keeping a linked list of CLASSes
  373. \ and searching it in INHERITS.
  374. \ You can use INHERITS anywhere in a class definition, any
  375. \ number of times.
  376. : INHERITS ( "name" --)
  377.         CLASSY @ 0= ABORT" No CLASS under construction."
  378.         ' >BODY /METHOD-LIST + 0 PATCH-CLASS
  379. ;
  380.  
  381. \ Get size of an object in number of entries.
  382. : SIZEOF ( object -- #entries)
  383.         /SIZE + @
  384. ;
  385.  
  386. \ Get "type" of each entry in object, i.e., size in address units.
  387. : TYPEOF ( object -- entry-size)
  388.         /TYPE + @
  389. ;
  390.  
  391. : DATAOF ( object -- data-address)
  392.         /DATA + @
  393. ;
  394.  
  395. : INIT-OOPS ( first method# --)
  396.         METHOD-POINTER.INIT
  397.         ;CLASS
  398.         METHODIST OFF
  399.         MSTACK.INIT
  400.         ['] CREATE-RAM-OBJ IS CREATE-OBJ        \ <- Change for VFSE-332!
  401. ;
  402.  
  403. 1 INIT-OOPS
  404.  
  405. BASE !
  406.  
  407. \ ~~~~~~~~~~~~~~~~~~~
  408. \ End of MULTIOOP.UTF
  409. \ ~~~~~~~~~~~~~~~~~~~
  410.  
  411.