home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / FPC355_3.ZIP / ZIMMER.ZIP / OBJECT.SEQ < prev    next >
Encoding:
Text File  |  1989-10-20  |  5.7 KB  |  200 lines
  1. \ OBJECT.SEQ  From Forth Dimmensions, Volume 10, number 2  by Rick Hoselton
  2.  
  3. comment:
  4.  
  5.         Some object oriented words slightly modified by Tom Zimmer
  6.         for use in F-PC.
  7.  
  8.  
  9.         OFFSET  #BYTES  METHOD format
  10.         0       2       next older borther METHOD pointer
  11.         2       2       MESSAGE number
  12.         4       n       METHOD's code
  13.  
  14.  
  15.         OFFSET  #BYTES  OBJECT format
  16.         0       2       father OBJECT address
  17.         2       2       youngest son OBJECT address + 4
  18.         4       2       next older brother OBJECT address + 4
  19.         6       2       youngest METHOD address
  20.         8       n       optional local data
  21.  
  22. comment;
  23.  
  24. only forth also definitions
  25.  
  26. anew objectstuff
  27.  
  28. true  #if       \ Do we want to use the CODE version ov ACTION?
  29.  
  30. code action     ( obj msg --- )
  31.                 pop ax
  32.                 pop bx
  33.                 add bx, # 6
  34.                 begin
  35.                         mov bx, 0 [bx]
  36.                         cmp ax, 2 [bx]
  37.              0= until
  38.                 add bx, # 4
  39.                 mov ax, bx
  40.                 jmp ax          end-code
  41.  
  42. #else
  43.  
  44. : action        ( obj msg --- )
  45.                 swap    6 +
  46.                 begin   @ 2dup 2+ @ =
  47.                 until   4 + nip execute ;
  48.  
  49. #then
  50.  
  51. variable 'msg
  52. variable 'object
  53.  
  54. : act           ( pfa msg --- )
  55.                 2dup 'msg @ ! 'object ! action ;
  56.  
  57. : me            ( --- ?? )
  58.                 'object @ ;
  59.  
  60. : >object       ( rel-addr --- addr )
  61.                 me + ;
  62.  
  63. : >super        ( rel-addr --- addr )
  64.                 me @ + ;
  65.  
  66. : link,         ( addr --- )
  67.                 here over @ , swap ! ;
  68.  
  69. : object>       ( --- )
  70.                 'object link,
  71.                 0 ,
  72.                 2 >super   link,
  73.                 6 >super @  ,  ;
  74.  
  75. create master
  76.                 master 'object !
  77.                 object>
  78.                 2 >object 6 erase
  79.  
  80. : (method)      ( --- msg )
  81.                 create here does> act ;
  82.  
  83. : ?create       ( --- msg )
  84.                 >in @   defined
  85.                 if      nip >body
  86.                 else    drop >in ! (method)
  87.                 then    ;
  88.  
  89. : (method:)     ( --- )
  90.                 ?create
  91.                 6 >object  link, ,
  92.                 ,JUMP
  93.                 >NEST HERE - HERE 2- !  \ link into JUMP the addr of nest
  94.                 XHERE PARAGRAPH +
  95.                 DUP XDPSEG !
  96.                 XSEG @ - ,
  97.                 XDP OFF
  98.                 !csp ] ;
  99.  
  100. (method:) anchor ." I don't understand" ;
  101.  
  102. ' anchor >body 2+ 'msg !
  103.  
  104. (method:) method:       ( --- )
  105.                 (method:) ;
  106.  
  107. master method: object:  ( --- )
  108.                 create  object> ;
  109.  
  110. : .method       ( link --- )
  111.                 cr dup 6 u.r  dup @ 6 u.r
  112.                 2+ @ dup 6 u.r  2 spaces body> >name .id ;
  113.  
  114. master method: .methods ( --- )
  115.                 base @ hex  6 >object
  116.                 begin   @ ?dup
  117.                 while   dup .method
  118.                 repeat  base ! ;
  119.  
  120. : .me           ( n --- )
  121.                 cr spaces me body> >name .id ;
  122.  
  123. master method: (.sons)  ( n --- )
  124.                 dup .me  2 >object
  125.                 begin   @ dup
  126.                 while   2dup 4 - (.sons)
  127.                 repeat  2drop ;
  128.  
  129. master method: .sons    ( --- )
  130.                 0  me (.sons) ;
  131.  
  132. master method: .one     ( --- )
  133.                 4 .me ;
  134.  
  135.  
  136. cr .( Type 140 load & 157 load, to load the demonstration words.)
  137. \s
  138. \ Demonstration stuff starts here.
  139.  
  140. \               ********** Vehicle ************
  141.  
  142. master object: vehicle
  143.  
  144. vehicle method: #wheels  8 >super @ ;
  145.  
  146. vehicle object: boat    0 ,
  147. vehicle object: car     4 ,
  148. vehicle object: tricycle 3 ,
  149.  
  150. car object: green-monster
  151. boat object: queen-mary
  152.  
  153. \ green-monster #wheels .
  154. \ queen-mary    #wheels .
  155.  
  156. \s
  157.  
  158. \               ********** Automobile **********
  159.  
  160. master object: automobile
  161.  
  162. automobile method: object: ( n1 --- )
  163.                 create object>          \ build links
  164.                 0 ,                     \  8 = odometer milage
  165.                 0 ,                     \ 10 = odometer milage at last fillup
  166.                 0 ,                     \ 12 = gas in tank
  167.                   , ;                   \ 14 = miles-per gallon
  168.  
  169. automobile method: drive  ( n1 --- )
  170.                 14 >object @ 12 >object @ * min \ gas * mpg = range
  171.                 dup  8 >object +!               \ increment odometer
  172.                 dup 14 >object @ / negate 12 >object +!
  173.                 ." I'm driving " . ."  miles " ;
  174.  
  175. automobile method: tell-gas ( --- )
  176.                 12 >object @ cr
  177.                 ." I have " . ." gallons in my tank " ;
  178.  
  179. automobile method: fill-gas ( n1 --- )
  180.                 12 >object +!  me tell-gas ;
  181.  
  182.  
  183.  7 automobile object: racer             \ High performance, seven MPG.
  184. 23 automobile object: slow-poke         \ Low performance, twenty-three MPG.
  185.  
  186.                                         \ Some privacy for SLOW-POKE
  187.                                         \ This shows that different objects
  188.                                         \ can use the same MESSAGE name to
  189.                                         \ produce different results.
  190. slow-poke method: tell-gas cr ." It's a secret! " ; \ <────────────┐
  191.                         \                                          │
  192.  18 racer fill-gas      \                                          │
  193. 100 racer drive         \                                          │
  194.                         \                                          │
  195.     racer tell-gas      \ This command doesn't seem to work        │
  196.                         \ after doing the above special stuff??? >─┘
  197.  
  198. slow-poke tell-gas      \ This works just great though???
  199.  
  200.