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