home *** CD-ROM | disk | FTP | other *** search
/ Borland Programmer's Resource / Borland_Programmers_Resource_CD_1995.iso / ntcode / jx4nt125 / obj4th / oopsobjs.utf (.txt) < prev   
Encoding:
Null Bytes Alternating  |  1995-05-19  |  12.6 KB  |  159 lines
  1. \ oopsobjs.utf .. test objects for multioop.utf
  2. \ ANS Forth compliant source code is Copyright (c)1992-1994 by
  3. \ Jack J. Woehr, P.O. Box 51, Golden, Colorado 80402-0051
  4. \ jax@well.sf.ca.us 72203.1320@compuserve.com
  5. \ SYSOP RCFB (303) 278-0364 2400/9600/14400
  6. \ All Rights Reserved
  7. \ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  8. \ This is free software and can be modified and redistributed under
  9. \ certain conditions described in the file COPYING.TXT. The
  10. \ Disclaimer of Warranty and License for this free software are also
  11. \ contained in the file COPYING.TXT.
  12. \ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  13. \ $Revision: 1.1 $
  14. \
  15. \ Dependencies:
  16. \       Object extensions loaded from file MULTIOOP.UTF
  17. \       TUCK from CORE EXT
  18. \ A Standard System still exists after this code is loaded.
  19.  
  20. \ Test Code for MULTIOOP.
  21. \ Remember, all methods are passed the object address automatically
  22. \ (here designated thusly: [o])
  23.  
  24. : PROVIDES ( c-addr u "ccc< >" --)
  25.     BL WORD FIND NIP 0=
  26.     IF INCLUDED ELSE 2DROP THEN ;
  27.  
  28. S" UTILS\UTILS.UTF" PROVIDES .(
  29. S" OBJ4TH\MULTIOOP.UTF" PROVIDES CLASS
  30.  
  31. .( Loading test objects for Multioop.) CR
  32.  
  33. MARKER multioop.utf
  34. BASE @ HEX
  35.  
  36. \ Class OBJECT is essentially a one-dimensional array.
  37. CELL CLASS: OBJECT
  38. M: `TO' ( value index [o] --)
  39.         3 ?ENOUGH                               \ -- value index [o]
  40.         OVER 0< ABORT" Negative index."         \ -- value index [o]
  41.         2DUP SIZEOF 1-                          \ -- value index [o] index n
  42.         > ABORT" Index too large."              \ -- value index [o]
  43.         TUCK TYPEOF                             \ -- value [o] index n
  44.         *                                       \ -- value [o] offset
  45.         SWAP DATAOF                             \ -- value offset data-addr
  46.         +                                       \ -- value address
  47.         !                                       \ --
  48. ;M
  49.  
  50. M: `AT' ( index [o] -- value)
  51.         2 ?ENOUGH                               \ -- index [o]
  52.         OVER 0< ABORT" Negative index."         \ -- index [o]
  53.         2DUP SIZEOF 1-                          \ -- index [o] index n
  54.          > ABORT" Index too large."             \ -- index [o]
  55.         TUCK TYPEOF                             \ -- [o] index n
  56.         *                                       \ -- [o] offset
  57.         SWAP DATAOF                             \ -- offset data-addr
  58.         +                                       \ -- address
  59.         @                                       \ -- value
  60. ;M
  61. ;CLASS
  62.  
  63. \ Class ARRAY adds the method of summing all its entries.
  64. CELL CLASS: ARRAY 
  65.         INHERITS OBJECT
  66.  
  67. M: `SUM' ( [o] -- sum)
  68.         0 SWAP                                  \ dummy to hold result
  69.         DUP SIZEOF                              \ number of entries in object
  70.         0 ?DO
  71.                 I `AT' 2 PICK                   \ get contents
  72.                 DO-OBJ
  73.                 ROT + SWAP                      \ add to dummp
  74.         LOOP
  75.         DROP                                    \ discard object address
  76. ;M
  77.  
  78. ;CLASS
  79.  
  80. \ Class BOOLEAN adds some boolean methods for mask manipulation.
  81. \ The entries are operated upon and results are both returned upon
  82. \ the data stack and stored into the original entry.
  83. CELL CLASS: BOOLEAN
  84.         INHERITS OBJECT
  85.  
  86. M: `NOT!' ( index [o] -- x)
  87.         2 ?ENOUGH                               \ check stack
  88.         2DUP `AT' SWAP DO-OBJ                   \ get value
  89.         INVERT DUP >R                           \ INVERT and save
  90.         ROT ROT `TO' SWAP DO-OBJ                \ store to entry
  91.         R>                                      \ return result
  92. ;M
  93.  
  94. M: `AND!' ( bitmask index [o] -- x)
  95.         3 ?ENOUGH                               \ check stack
  96.         ROT >R                                  \ put bitmask where handy
  97.         2DUP `AT' SWAP DO-OBJ                   \ get value
  98.         R> AND DUP >R                           \ AND and save
  99.         ROT ROT `TO' SWAP DO-OBJ                \ store to entry
  100.         R>                                      \ return result
  101. ;M
  102.  
  103. M: `OR!' ( bitmask index [o] -- x)
  104.         3 ?ENOUGH                               \ check stack
  105.         ROT >R                                  \ put bitmask where handy
  106.         2DUP `AT' SWAP DO-OBJ                   \ get value
  107.         R> OR DUP >R                            \ OR and save
  108.         ROT ROT `TO' SWAP DO-OBJ                \ store to entry
  109.         R>                                      \ return result
  110. ;M
  111.  
  112. ;CLASS
  113.  
  114. \ Class CHAR-ARRAY (address-unit array) has ARRAY's SUM method and
  115. \ BOOLEAN's methods but has to use its own `AT' and `TO' since
  116. \ we are talking characters, not cells here ( note C@ and C!).
  117. 1 CHARS CLASS: CHAR-ARRAY
  118.  
  119. M: `TO' ( value index [o] --)
  120.         3 ?ENOUGH                               \ -- value index [o]
  121.         OVER 0< ABORT" Negative index."         \ -- value index [o]
  122.         2DUP SIZEOF 1-                          \ -- value index [o] index n
  123.         > ABORT" Index too large."              \ -- value index [o]
  124.         TUCK TYPEOF                             \ -- value [o] index n
  125.         *                                       \ -- value [o] offset
  126.         SWAP DATAOF                             \ -- value offset data-addr
  127.         +                                       \ -- value address
  128.         C!                                      \ --
  129. ;M
  130.  
  131. M: `AT' ( index [o] -- value)
  132.         2 ?ENOUGH                               \ -- index [o]
  133.         OVER 0< ABORT" Negative index."         \ -- index [o]
  134.         2DUP SIZEOF 1-                          \ -- index [o] index n
  135.          > ABORT" Index too large."             \ -- index [o]
  136.         TUCK TYPEOF                             \ -- [o] index n
  137.         *                                       \ -- [o] offset
  138.         SWAP DATAOF                             \ -- offset data-addr
  139.         +                                       \ -- address
  140.         C@                                      \ -- value
  141. ;M
  142.  
  143. M: `CHECKSUM' ( [o] -- checksum)
  144.         `SUM' SWAP DO-OBJ                       \ SUM from ARRAY class
  145.         0FF AND 0FF SWAP -                      \ subtract from 0xff
  146. ;M
  147.  
  148.     INHERITS ARRAY
  149.     INHERITS BOOLEAN
  150.  
  151. ;CLASS
  152.  
  153. BASE !
  154.  
  155. \ ~~~~~~~~~~~~~~~~~~~
  156. \ End of OOPSOBJS.UTF
  157. \ ~~~~~~~~~~~~~~~~~~~
  158.  
  159.