home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 8 / CDASC08.ISO / VRAC / FORTH035.ZIP / FORTH.INI < prev    next >
Text File  |  1993-07-08  |  14KB  |  436 lines
  1. ( FORTH.INI  Initialization file for FORTH/2        07/08/93 )
  2. ( Copyright <c> 1993  BLUE STAR SYSTEMS )
  3.  
  4. ( The following words from the Forth-83 standard are still missing:
  5.  
  6.   >BODY  CONVERT
  7.   D+  D<  DNEGATE  UM*  UM/MOD
  8.  
  9.   These are partially supported in the file BLOCKS.4TH:
  10.      BLK  BLOCK  BUFFER  FLUSH  LOAD  SAVE-BUFFERS  UPDATE
  11. )
  12.  
  13. DECIMAL
  14.  
  15.  
  16. : greet ." This message came from the file 'FORTH.INI' " cr ;
  17. : CLS   27 emit ." [2J"  0 #OUT ! ;
  18.  
  19. ( Define the NON-STANDARD!!! "   Fixed 7/8/93 v0.031 )
  20. : " POSTPONE S"
  21.     POSTPONE DROP
  22.     POSTPONE CELL
  23.     POSTPONE -  ; IMMEDIATE
  24.  
  25. VARIABLE CSP       ( Adds stack checking during compilation )
  26. : !CSP   SP@ CSP ! ;
  27. : ?CSP   SP@ CSP @ - IF ." Definition not finished " ABORT THEN ;
  28. : :                     :  !CSP ;  IMMEDIATE
  29. : ;      ?CSP  POSTPONE ;  ;       IMMEDIATE
  30.  
  31. 1 CELLS CONSTANT CELL
  32.  
  33.  
  34. 32 CONSTANT BL
  35. : SPACE    BL EMIT ;
  36. : SPACES   0 MAX  1000 MIN  0 FOR  SPACE  NEXT ;
  37.  
  38. HEX
  39. : ?BRANCH,  C383038B , 0FC02304 , 84 C, 0 , ;
  40. : BRANCH,   E9 C, 0 , ;
  41.  
  42. : BEGIN     HERE ;             IMMEDIATE
  43. : WHILE     ?BRANCH,  HERE ;   IMMEDIATE
  44.  
  45. : REPEAT    SWAP   BRANCH,  HERE -  HERE CELL - !
  46.                        HERE OVER -  SWAP CELL - ! ;   IMMEDIATE
  47. : UNTIL           ?BRANCH,  HERE -  HERE CELL - ! ;   IMMEDIATE
  48. : AGAIN            BRANCH,  HERE -  HERE CELL - ! ;   IMMEDIATE
  49. : EXIT      R> DROP ;
  50.  
  51.  
  52. 0 CONSTANT CASE  IMMEDIATE
  53. : <OF>      OVER = IF  DROP 1  ELSE  0  THEN ;
  54. : OF        1+ >R  POSTPONE OVER   POSTPONE =
  55.                    POSTPONE IF     POSTPONE DROP  R> ; IMMEDIATE
  56. : ENDOF         >R POSTPONE ELSE                  R> ; IMMEDIATE
  57. : ENDCASE          POSTPONE DROP
  58.             0 FOR  POSTPONE THEN  NEXT ;               IMMEDIATE
  59.  
  60.  
  61. : LIT     R> DUP CELL + >R @ ;
  62. : ASCII   ( char-- b )  POSTPONE [CHAR] ;              IMMEDIATE
  63. : CONTROL ( char-- b )  BL WORD  CELL+ C@ 64 -
  64.                         State @ IF  POSTPONE LIT ,  THEN ; IMMEDIATE
  65. : CHAR    POSTPONE ASCII ; IMMEDIATE
  66.  
  67. DECIMAL
  68. : PAD   HERE 100 + ;      VARIABLE HLD
  69. : <#     ( n -- n )  PAD HLD ! ;
  70.  
  71. : #9     ( n -- )  9 OVER <  IF  7 +  THEN   ASCII 0 + ;
  72. : HOLD   ( char -- )  HLD @ -1 +  DUP HLD !  C! ;
  73.  
  74. : SIGN   0 < IF  ASCII - HOLD  THEN ;
  75.  
  76. : #   ( n -- n  ( one digit )  BASE @  /MOD ( U/MOD ) SWAP ABS #9 HOLD ;
  77. : #S  ( n -- 0  )  BEGIN  #   DUP  0 = UNTIL ;
  78.  
  79. : #>  ( n -- a l )  DROP   HLD @   PAD OVER -  ;
  80.  
  81. : .R  ( n length -- ) >R  DUP ABS  <#  #S  SWAP SIGN  #>
  82.                       R>  OVER - SPACES  TYPE ;
  83. : U.R ( n length -- ) >R           <#  #S  #>
  84.                       R>  OVER - SPACES  TYPE ;
  85. : .   0 .R  SPACE ;
  86. : ?   @ . ;
  87.  
  88. : ANSI. ( n -- )   ABS 0 .R ;
  89. : XY    ( x y -- ) 27 EMIT ." ["  ANSI.  59 EMIT  ANSI.  72 EMIT ;
  90.  
  91. : -ROT    ( n1 n2 n3 -- n3 n1 n2 ) ROT ROT ;
  92. : UNDER   ( n1 n2 -- n1 n1 n2 ) >R DUP R> ;
  93. : TUCK    ( n1 n2 -- n2 n1 n2 ) SWAP OVER ;
  94. : ALONG   ( n1 n2 -- n1+n2 n1 ) OVER + SWAP ;  ( good before DO loops )
  95.  
  96. : W-  CELL - ;   : 0>  0 > ;
  97. : 2+  2 + ;      : 2-  2 - ;
  98.  
  99. : TOGGLE ( n addr -- )  TUCK @ XOR SWAP ! ;
  100.  
  101. : TRUE  -1 ;                        : FALSE  0 ;
  102. : ON ( addr -- )  -1 SWAP ! ;       : OFF ( addr -- )  0 SWAP ! ;
  103.  
  104. : -TRAILING   ( addr n1 -- addr n2 )  2DUP + 1-  SWAP
  105.               0 FOR   DUP C@  BL > IF  LEAVE  ELSE  1-  THEN
  106.                 NEXT  1+  OVER - ;
  107. : 0-Terminate ( addr -- )  @+ + 0 SWAP C! ;
  108. : 0"COUNT ( addr -- addr len )  DUP    BEGIN
  109.                       DUP C@ WHILE  1+ REPEAT  OVER - ;
  110.  
  111.  
  112. : ".  ( addr -- )  @+ TYPE ;      (  ".  prints a counted       string )
  113. : 0". ( addr -- )  0"COUNT TYPE ; ( 0".  prints a 0-terminated string. )
  114.  
  115.  
  116. 4 CONSTANT StrPadSize                   ( All strings are padded with 4 0's  )
  117. : "->0"    ( addr1 -- addr2 ) CELL + ;  ( Convert counted string to 0-end string )
  118. : ",       @ CELL+ StrPadSize + ALLOT ; ( Compile string into dictionary   )
  119.  
  120. : <">      R> DUP  @+ +  StrPadSize +  >R     ;
  121. : <.(>     R> DUP  @+ +  StrPadSize +  >R  ". ;
  122. : <ABORT"> R> DUP  @+ +  StrPadSize +  >R  SWAP  IF  ".  ABORT CR
  123.            ELSE  DROP  THEN ;
  124.  
  125. \ HUH? (MAW - I don't get this one!?!?!?!? )
  126. \
  127. \  : 0"       State @ IF  POSTPONE <0">   THEN
  128. \             ASCII " WORD
  129. \             State @ IF  ",  ELSE "->0" THEN ; IMMEDIATE
  130. \
  131. \ : "        State @ IF  POSTPONE <">    THEN
  132. \            ASCII " WORD
  133. \            State @ IF  ",             THEN ; IMMEDIATE
  134. \
  135. \ : ."       State @ IF  POSTPONE ."    ELSE
  136. \            ASCII " WORD  ".           THEN ; IMMEDIATE
  137. \
  138. \ : .(       State @ IF  POSTPONE <.(>   THEN
  139. \            ASCII ) WORD
  140. \            State @ IF  ",  ELSE  ".   THEN ; IMMEDIATE
  141. \
  142. \ : S"       POSTPONE "  POSTPONE @+ ;
  143. \
  144. \ : ,"       POSTPONE "  HERE @ CELL+ ALLOT ;
  145. \
  146.  
  147. : ABORT"   ?COMPILE    POSTPONE <ABORT"> 
  148.            ASCII " WORD  ", ; IMMEDIATE
  149.  
  150. VARIABLE FENCE
  151. : +VLink      CELL+ ;
  152. : +NextVoc  2 CELLS + ;
  153. : FORGET ( name-- )     \ Forgets across vocabularies
  154.      '  FENCE @ over U< IF
  155.        Context ContextSize CELLS along DO
  156.            dup  I @  u< IF  0 I !  THEN  CELL +LOOP
  157.        Context  Context ContextSize CELLS along do
  158.            I @ IF  I @  0 I !  over !  CELL+  THEN   CELL +LOOP  drop
  159.        >R  I  Current @ +VLink @ U< IF  POSTPONE Forth  THEN
  160.        VOC-LINK @
  161.        BEGIN  I OVER U< WHILE  +NextVoc @  REPEAT
  162.        DUP VOC-LINK !
  163.        BEGIN  DUP +VLink
  164.            BEGIN  @  dup I u< UNTIL
  165.            over +VLink !  +NextVoc @  ?DUP 0=
  166.        UNTIL  R> DP!
  167.     ELSE
  168.       ." Can't forget before FENCE! " cr
  169.     THEN ;
  170.  
  171. ' FORGET FENCE !   \ Set up the fence
  172.  
  173.  
  174.  
  175. : 2CONSTANT  CREATE  SWAP , ,  DOES>  DUP @ SWAP CELL+ @ ;
  176. : 2VARIABLE  VARIABLE  CELL ALLOT ;
  177.  
  178. : ERASE  ( addr len -- )  0 FILL ;  \ Fill memory with 0's
  179.  
  180. : TYPE     dup 20000 > ABORT" Tried to TYPE over 20000 characters" TYPE ;
  181.  
  182. \ "MOVE  moves a counted string to another address
  183.  
  184. : "MOVE  ( counted_string_address dest_address -- )
  185.          OVER @  CELL+  CMOVE ;
  186.  
  187.  
  188. \ MOVE>"  copies addr,len to be a counted string at dest_addr
  189.  
  190. : MOVE>"  ( addr len dest_addr -- ) 2dup !
  191.                                     CELL+ swap cmove ;
  192.  
  193.  
  194. \ "CAT   conCATenate string1 to the end of string2
  195.  
  196. : "CAT   ( counted_string_addr1  counted_string_dest_addr2 -- )
  197.          2DUP  @+ +  SWAP @+ ROT SWAP CMOVE
  198.          SWAP @  SWAP +! ;
  199.  
  200.  
  201. : "CONSTANT  ( addr <word>-- Does: -- addr ) HERE 53 + "MOVE
  202.              CREATE  HERE ",  DOES> ;
  203.  
  204. : CALL"  ( <string><name>-- Does: -- addr ) ASCII " WORD  "CONSTANT ;
  205.  
  206. \ CALL" Bill Clinton" President  ...   President ".
  207.  
  208.  
  209. : INTEGER  ( -- )   CREATE  HERE  0 ,
  210.                             %TO @ IF  <TODOES>  ELSE  DROP  THEN
  211.                     DOES>   <TODOES> ;
  212.  
  213. : INTARRAY ( size ) CREATE  CELLS  HERE  OVER ALLOT  DUP ROT 0 FILL
  214.                             %TO @ IF  SWAP CELLS + <TODOES>  THEN
  215.                     DOES>  SWAP CELLS +  <TODOES> ;
  216.  
  217. \ STRING TO variables:  " XYZ123" TO String1  ...   String1 ".
  218.  
  219. variable StringSize  255 StringSize !    \ Size of STRING's to be created
  220. variable TempString  StringSize @ ALLOT  \ To move string out of way of CREATE
  221.  
  222. : <"TODOES>  ( -- addr  ;  addr TO --   ;  addr +TO --  )
  223.              %TO @    IF
  224.              %TO @ 0> IF  "MOVE  ELSE  "CAT  THEN  0 %TO !  THEN ;
  225.  
  226. : STRING   %TO @ IF  TempString "MOVE  TempString  THEN
  227.            CREATE  HERE  StringSize @ CELL+ ALLOT  DUP StringSize @ CELL+ 0 FILL
  228.                    %TO @ IF  <"TODOES>  ELSE  DROP  THEN
  229.            DOES>   <"TODOES> ;
  230.  
  231.  
  232. : TONE ( frequency duration -- ) SWAP SYS$BEEP SYSCALL  3 DROPS ;
  233. ( frequency in cycles/second, duration in milliseconds, 1/1000 of a second )
  234.  
  235. : BEEP  3000 60 TONE ;
  236.  
  237. HEX
  238.  
  239. Variable   Handle               0 Handle !
  240. Variable   ActionTaken
  241. Variable   BytesTransferred
  242. Variable   BufferArea
  243. Variable   BufferLength
  244. Variable   LineSource
  245. Variable   LineLength
  246.  
  247. 0   Constant    EABUF
  248. 42  Constant    OpenMode
  249. 11  Constant    OpenFlag
  250. 0   Constant    FileAttribute
  251. 0   Constant    FileSize
  252.  
  253. : Source-ID Handle @ ;
  254.  
  255. : \ Source-ID 0= IF Postpone \ ELSE
  256.                     0 #TIB !   THEN ; Immediate
  257.  
  258. : Source LineLength @ LineSource @ ;
  259.  
  260. : Open ( name -- handle ) >R EABUF OpenMode OpenFlag FileAttribute
  261.     FileSize ActionTaken Handle R> sys$open syscall
  262.     9 Drops  handle @ ;
  263.  
  264. : Close ( handle -- ) Sys$Close SysCall 2drop ;
  265.  
  266. : FWrite ( handle address length )
  267.   BufferLength !
  268.   BufferArea !
  269.   Handle !
  270.   BytesTransferred BufferLength @ BufferArea @ Handle @ sys$write syscall
  271.   5 drops ;
  272.  
  273. : FRead ( handle address buffersize --  )
  274.   BufferLength !
  275.   BufferArea !
  276.   Handle !
  277.   BytesTransferred BufferLength @ BufferArea @ Handle @ sys$read syscall
  278.   5 drops ;
  279.  
  280. : EOF?  ( -- f ) BytesTransferred @ 0= ;  \ True if at end of file
  281.  
  282. Variable FilePtr
  283. : FSeek   ( ptr handle -- f ) >R  FilePtr  0  ROT   R> SYS$SEEK SYSCALL
  284.                               >R  4 Drops  R> ;
  285.  
  286. : Readln ( handle -- addr len ) DUP >R  FBuffer 100 FRead
  287.          FBuffer  begin
  288.                      dup c@  dup 0A =  swap 0= OR  NOT while
  289.               1+  repeat  1- ( subtract off 0Dh from length )
  290.          FBuffer tuck -  dup FilePtr @ + 2+ R> FSeek  ABORT" Seek failed"
  291.  
  292.          2dup LineSource ! LineLength ! ;
  293.  
  294.  
  295. : Fibinacci ( n -- fib[n] )
  296.   dup 2 <= if drop 1 else dup 1 - recurse swap 2 - recurse + then ;
  297.  
  298.  
  299. Variable ResultCodes 4 allot
  300.  
  301. Variable Arguments 256 Allot
  302.  
  303. : Args  ( string -- ) Arguments "MOVE  Arguments 0-Terminate ;
  304. : Args" ( args-- )  State @ IF  COMPILE "  Compile Args  ELSE
  305.                                   ASCII " WORD  Args     THEN ; IMMEDIATE
  306.  
  307. : Shell ( name -- ) Arguments CELL+ @ if
  308.                         Arguments CELL+  over @  over + 1+ Arguments @ 1+ cmove>
  309.                         dup @  Arguments + CELL+ 0 swap c!
  310.                         dup    Arguments "MOVE then     "->0"
  311.                     ResultCodes 0 Arguments CELL+ 0 0 0 sys$execpgm syscall
  312.                     8 drops     0 Arguments CELL+ ! ;
  313.  
  314. : Shell"   State @ IF   POSTPONE "  Compile Shell  ELSE
  315.                            ASCII " WORD  shell     THEN ;  IMMEDIATE
  316.  
  317. : CommandShell ( shell's to C:\OS2\CMD.EXE ) " C:\OS2\CMD.EXE" shell ;
  318.  
  319. : dir          " /C DIR " Arguments "MOVE  bl word Arguments "CAT
  320.                Arguments 0-terminate  CommandShell ;  
  321. \ Example: dir *.4th
  322.  
  323. : DoShell " c:\os2\cmd.exe" resultcodes 0 0 0 0 0 sys$execpgm syscall 8 drops ;
  324.  
  325. DECIMAL
  326.  
  327. \ ?PAGE gives scrolling control to pause at the end of each screen
  328.  
  329. VARIABLE L/P  23 L/P !  ( Lines per Page )
  330. : 0PAGE  0 LINE# ! ;
  331. : ?PAGE  ( -- f )  1 LINE# +!  LINE# @ L/P @ > IF
  332.             CR  ." Space to continue, Enter to advance 1 line... "
  333.             KEY  255 AND  DUP 32 OR 113 = if  DROP  CR True  else
  334.                                      31 > if  0PAGE  then   False then
  335.             13 EMIT  46 SPACES  13 EMIT  ELSE  CR  False  THEN ;
  336.  
  337.  
  338. \ Use DUMP to examine an area of memory 
  339. DECIMAL
  340. : HEX.     DUP 9 > IF  55  ELSE  48  THEN  + EMIT ;
  341. : SAFEMIT  DUP 14 < OVER 6 > AND IF DROP BL THEN  EMIT ;
  342. : ASCII. ( addr -- )  16 0 DO  DUP C@ SAFEMIT  1 + LOOP  DROP ;
  343. : BYTE.    DUP 16 / HEX. 16 MOD HEX. SPACE ;
  344. : LINE.  ( addr -- ) 16 0 DO  DUP C@ BYTE.  1 +
  345.                  DUP 16 MOD 0 = IF  SPACE  THEN  LOOP DROP ;
  346. : DUMP   ( addr len -- ) BASE @ >R HEX  0PAGE CR
  347.          16 / 1 +  0 DO
  348.                DUP .  SPACE  DUP LINE.  3 SPACES DUP ASCII.  
  349.                ?PAGE IF  LEAVE  THEN
  350.          16 + LOOP R> BASE !  DROP ;
  351.  
  352.  
  353. \ MORE lists the contents of a file.   Example:  0" FORTH.INI" MORE
  354. : MORE ( name -- )  Open  0PAGE  CR  0 FilePtr !
  355.         begin   dup readln type  ?PAGE
  356.                 eof?  OR  until
  357.         Close ;
  358.  
  359. : MORE" ( name-- ) ASCII " WORD  CELL+ MORE ;
  360. \ Example: MORE" FORTH.INI"
  361.  
  362. create WordStr 31 allot   variable ViewPtr
  363. : VIEW ( word-- )  0" FORTH2.DOC" Open  CR  0 FilePtr !
  364.         BL Word  WordStr "MOVE
  365.         ViewPtr @ IF  ViewPtr @ over FSEEK ABORT" Seek failed"
  366.         ELSE
  367.           870 0 do  dup readln 2drop       \ Skip 880 lines
  368.                     eof? if  leave then
  369.           loop      eof? if  exit  then
  370.           begin   dup readln               \ Look for vocabulary listing
  371.                   " --Begin--"  =STRING  eof? or  until
  372.           eof? ABORT" Did not find vocabulary listing"
  373.           FilePtr @ ViewPtr !              \ Save beginning location
  374.         THEN
  375.         begin   dup readln                 \ Look for word
  376.                2dup WordStr @ min  WordStr =STRING NOT
  377.                eof? NOT and  while  2drop
  378.         repeat
  379.         eof? ABORT" Did not find word"
  380.         TYPE  CR  close ;
  381. \ VIEW  shows information about Forth words:  VIEW ECHO
  382.  
  383.  
  384. \ User ECHO to turn on/off echoing of files while they are being loaded.
  385.  
  386. VARIABLE Echo  \ Echo ON  --> Echo file being loaded to screen
  387.                \ Echo OFF --> Do not echo
  388.  
  389. ( TRUE ECHO ! )
  390.  
  391. : INCLUDE ( name -- ) OPEN >R                \ Load a Forth source file
  392.         TIB @  FilePtr @  LINE# @  Echo @    \ save & restore TIB
  393.         0 FilePtr !  0 LINE# !
  394.         begin  i readln   1 LINE# +!
  395.            EOF? not while
  396.                dup if
  397.                   Echo @ if cr 2dup type 100 ms then
  398.                   1+ SPAN !  TIB ! 0 >IN ! INTERPRET
  399.                else  2drop  then
  400.            repeat    2drop
  401.         Echo !  LINE# !  FilePtr !  TIB !
  402.         R> Close
  403.   0 #TIB ! 0 >IN ! 0 Handle !
  404.   ;
  405.  
  406. : INCLUDE"  ( filename-- ) ASCII " WORD CELL+ INCLUDE ; \ INCLUDE" STRUCT.4TH"
  407.  
  408.  
  409. : VOCABULARY ( voc_name-- )
  410.              CREATE  HERE  0 ,  0 ,  VOC-LINK @ ,  VOC-LINK !  IMMEDIATE
  411.              DOES>   <VOCABULARY> ;
  412.  
  413. : DEFINITIONS ( -- )  CONTEXT @ CURRENT ! ;
  414. : ONLY ( -- ) CONTEXT @  CONTEXT ContextSize CELLS 0 FILL  CONTEXT !
  415.               DEFINITIONS ;
  416.  
  417. HEX
  418. : show ( -- ) dup 20 - dup 4 - @ ." {" type ." }" ;
  419. : MyExecute show key drop <execute> ;
  420.  
  421. ( Install the debugger - Comment out to save lot's o headaches )
  422. \ ' MyExecute 'Execute !
  423.  
  424. DECIMAL
  425.  
  426. ( Add any files you want to load at start-up time here )
  427.  
  428. ( include" struct.4th"   )
  429. (  include" threads.4th"  )
  430. ( include" locals.4th"   )
  431. ( include" startup.4th"  )
  432.   include" mike.4th"
  433.  
  434. greet
  435.  
  436.