home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1996 January / macformat-033.iso / mac / Shareware City / Developers / CGIshell Folder / Pocket 6.4 / Extensions / Starting / Brodie < prev    next >
Encoding:
Text File  |  1995-05-14  |  6.1 KB  |  180 lines  |  [TEXT/McSk]
  1. \ Brodie v.1.2   Define some words to conform to Brodie's book.
  2.  
  3. 0 28 +md ! forget task decimal page  \ be neat
  4.  
  5. \
  6. \       ------------------------------------------------
  7. \   \|/   Drag the icon of this file to Pocket Forth,    \|/
  8. \   -X-   then release the mouse button. That is, drop   -X-
  9. \   /|\   this file onto Pocket Forth, loading it.       /|\
  10. \       ------------------------------------------------
  11. \
  12. \ In order to use the book Starting Forth to learn Pocket
  13. \ Forth, some definitions must be added to Pocket Forth. Load
  14. \ this file to get partial compatability with Brodie's Forth.
  15. \
  16. \ Many of these definitions are machine language to give
  17. \ maximum speed and take up minimum dictionary space.
  18.  
  19. \ Chapter 1
  20. : SPACES ( n -- )
  21.     ?dup IF 0 DO space LOOP THEN ;  \ emit n spaces
  22.  
  23. \ Chapter 2
  24. : D- dnegate d+ ;  \ double length number subtraction
  25.  
  26. \ Display the contents of the stack from bottom to top.
  27. : .S  ( n[m] .. n[1] -- n[m] .. n[1] )
  28.     depth ?dup IF negate -1 DO      \ contributed by
  29.       s0@  r 2* s>d  d+ l@ .        \ Jesus Consuegra
  30.     -1 +LOOP ELSE ." Empty" THEN ;  \   * Thanks! *
  31.  
  32. \ Chapter 3
  33. : .(  41 word here count type ;  \ interactive printing utility
  34.  
  35. \ Chapter 4
  36. : <> ( n1 n2 -- flag )  = 0= ;   \ true if n1 and n2 are not the same
  37. : NOT ( n -- not[n] )  -1 xor ;  \ this is a bit not, not the same as 0=
  38.  
  39. \ Chapter 5
  40. : 2- ( n -- n-2 ) ,$ 5556 ; MACRO  \ subq #2,(ps)
  41.  
  42. : R@ ( -- n ) ( rstack: n -- n )   \ same as r
  43.     ,$ 3d17 ; MACRO                \ move  (a7),-(a6)
  44.  
  45. \ Chapter 6
  46. : I ( -- n ) ( rstack: n -- n ) ( same as r and r@ )
  47.     ,$ 3d17 ; MACRO                \ move  (a7),-(a6)
  48. : J ( -- n ) ( rstack: n x m -- n x m )
  49.     ,$ 3d2f ,$ 0004 ; MACRO        \ move 4(a7),-(a6)
  50.  
  51. \ Chapter 7
  52. : OCTAL ( -- ) 8 base ! ;
  53.  
  54. : ASCII ( -- c ) \ ascii of next word  *STATE SMART
  55.     32 word here 1+ c@  cstate c@ IF literal THEN ; IMMEDIATE
  56.  
  57. : D= ( d1 d2 -- flag ) d- + 0= ;          \ true if d1=d2
  58. : D< ( d1 d2 -- flag ) d- swap drop 0< ;  \ true if d1<d2
  59. : DMAX ( d1 d2 -- dmax )  \ dmax is the larger of d1 and d2
  60.     2over 2over d< IF 2swap THEN 2drop ;
  61. : DMIN ( d1 d2 -- dmin )  \ dmin is the smaller of d1 and d2
  62.     2over 2over d< 0= IF 2swap THEN 2drop ;
  63.  
  64. : U< ( u1 u2 -- flag ) 0 rot 0 2swap d< ;  \ true if u1<u2
  65.  
  66. : UM* ( u u -- d )  u* ;  \ unsigned single multiply with double product
  67. : M* ( n n -- d )  \ signed single multiply with double product
  68.     ,$ 301E ,$ C1DE ,$ 2D00 ; \ move (ps)+,d0  muls (ps)+,d0  move.l d0,-(ps)
  69. : UM/MOD ( d n -- urem uquot ) m/mod drop ;
  70. : M/ ( d n -- quot ) m/mod rot 2drop ;
  71. : M+ ( d n -- d[d+n] ) s>d d+ ;
  72.  
  73. : mst cr 9 spaces ." The word M*/ requires an 68020 or greater."
  74.       cr 9 spaces ." M*/ may give incorrect results." 
  75.       cr 9 spaces ." (No other words are effected.)" cr cr cr ;
  76. : mstest ( -- )
  77.     ,s proc ?gestalt 0= IF   \ check processor type
  78.       beep ." Caution: This is an old system." mst
  79.     ELSE  drop 3 < IF        \ must be 68020 or greater
  80.       beep beep beep ." Warning: This processor is too puny." mst
  81.     THEN THEN ;
  82. mstest forget mst
  83.  
  84. : M*/ ( d n u -- d*n/u )  \ safe version -- will not crash on a 68000
  85.     ,s proc ?gestalt swap drop and  2 > IF   \ must be 68020 or greater
  86.         >r                \ move   (ps)+,-(rs)
  87.         ,$ 4280           \ clr.l  d0
  88.         ,$ 4281           \ clr.l  d1
  89.         ,$ 321E           \ move   (ps)+,d1
  90.         ,$ 4C16  ,$ 1C00  \ muls.l (ps),d0:d1  <-- 68020 instruction
  91.         ,$ 4296           \ clr.l  (a6)
  92.         ,$ 3D5F  ,$ 0002  \ move   (rs)+,2(ps)
  93.         ,$ 4C56  ,$ 1400  \ divu.l (ps),d0:d1  <-- 68020 instruction
  94.         ,$ 2C81           \ move.l d1,(ps)
  95.     ELSE rot drop */ s>d THEN ;  \ auto fall back to 16 bit version
  96.  
  97. \ Right justified numeric display.
  98. : D.R ( d width -- )
  99.     >r  swap over dabs  <# #s sign #>
  100.     r>  over - spaces type space ;
  101. : .R  ( n width -- ) >r s>d r> d.r ;
  102. : U.R ( u width -- ) 0 swap  d.r ;
  103.  
  104. \ Chapter 8
  105. 0 constant FALSE
  106. -1 constant TRUE
  107.  
  108. : ? ( addr -- ) @ . ;  ( print variable )
  109.  
  110. 32 constant BL
  111. : BLANK ( addr n -- ) bl fill ;  \ Fill addr with n spaces.
  112. : ERASE ( addr n -- ) 0 fill ;  \ Fill addr with n zeros.
  113.  
  114. variable c,even  -1 c,even !
  115. : C,  ( c -- )  \ NOTE: this allways leaves the address HERE even.
  116.     c,even @ IF  here !  here 1+ c@  here c!
  117.       2 allot  0 c,even !
  118.     ELSE  here 1- c!  -1 c,even !  THEN ;
  119.  
  120. \ Chapter 9
  121. : @EXECUTE ( addr -- ) @ ?dup IF  execute THEN ;
  122. : S0 ( -- dabs.addr ) S0@ ;
  123.  
  124. : ['] ( -- addr ) \ of the next word in a colon definition
  125.     token latest search IF literal
  126.     ELSE  here count type space ." not found." abort
  127.     THEN ; IMMEDIATE
  128.  
  129. : RECURSE ( -- ) latest 6 +  compile ; IMMEDIATE  \ bug fix by Ron Kneusel
  130.  
  131. variable eh
  132. : H ( -- addr ) here eh !  eh ;
  133.  
  134. \ Chapter 10
  135. : KEY? ( -- flag ) ?terminal ;
  136. : MOVE ( addr1 addr2 count -- ) cmove ;
  137. : CMOVE> ( addr1 addr2 count -- ) cmove ;
  138.  
  139. variable espan  \ count of characters of the last EXPECTed input
  140. : SPAN ( -- addr ) ,$ 3D07 ( move d7,-[ps] )  espan ! espan ;
  141.   
  142. variable in  \ offset from tib of the current byte
  143. : >IN ( -- addr ) ,$ 2D0C ( move.l is,-[ps] ) >rel  tib -  in !  in ;
  144.  
  145. variable  tblk  \ flag indicates input source
  146. : BLK ( -- flag ) cblk c@ 0=  tblk ! tblk ; \ true=file(paste)/false=keyboard
  147.  
  148. variable tstate
  149. : STATE ( -- addr ) cstate c@ 0= 0=  tstate ! tstate ;
  150.  
  151. : STRING ( c -- )  \ compile a string 
  152.     word here c@ 1+ ,$ 5256 ,$ 256 ,$ fffe allot ; \ keep HERE even
  153. : LIT" 34 string ; IMMEDIATE
  154.  
  155.  
  156. \ These three words are redefined:
  157. : (word) word ;  .( WORD is redefined.) cr
  158. : WORD ( c -- addr ) (word) here ;
  159.  
  160. : (number)  number ;  .( NUMBER is redefined.) cr
  161. : NUMBER ( addr -- d ) (number) IF  s>d  ELSE 0 0 THEN ;
  162.  
  163. \ Chapter 11
  164. .( COMPILE is redefined.) cr
  165. : COMPILE ( -- ) \ compile the next word from within a colon def.
  166.     token latest search IF        \ ( -- n ) addr of token
  167.       ,$ 24FC  ,$ 24FC ,$ 4EAB  ,  \ move.l #[move.l jsr n(a3)],(a2)+
  168.     ELSE  here count type space ." not found." abort
  169.     THEN ; IMMEDIATE
  170.  
  171. \ Restore the origonal WORD NUMBER and COMPILE by typing:  FORGET (WORD)
  172.  
  173. : TASK ;
  174.  
  175. cr .( Welcome to Pocket Forth. ) cr cr
  176. .( The extension file 'Brodie' has been loaded, providing) cr
  177. .( substantial compatibility with Starting Forth.) cr cr
  178. .( See 'To Use Starting Forth' for more information.) cr
  179. -1 28 +md !
  180.