home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Professional / OS2PRO194.ISO / os2 / prgramer / forth_32 / forth.ini < prev    next >
Encoding:
Text File  |  1993-03-23  |  13.6 KB  |  413 lines
  1. ( FORTH.INI  Initialization file for FORTH/2        03/18/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. : greet ." This message came from the file 'FORTH.INI' " cr ;
  14. : CLS   27 emit ." [2J"  0 #OUT ! ;
  15.  
  16. VARIABLE CSP       ( Adds stack checking during compilation )
  17. : !CSP   SP@ CSP ! ;
  18. : ?CSP   SP@ CSP @ - IF ." Definition not finished " ABORT THEN ;
  19. : :            [COMPILE] :  !CSP ;  IMMEDIATE
  20. : ;      ?CSP  [COMPILE] ;  ;       IMMEDIATE
  21.  
  22. DECIMAL
  23. : \      13 WORD DROP ;  IMMEDIATE    \ Comments to end of line
  24.  
  25.  
  26. 32 CONSTANT BL
  27. : SPACE    BL EMIT ;
  28. : SPACES   0 MAX  1000 MIN  0 FOR  SPACE  NEXT ;
  29.  
  30. HEX
  31. : ?BRANCH,  C383038B , 0FC02304 , 84 C, 0 , ;
  32. : BRANCH,   E9 C, 0 , ;
  33.  
  34. : BEGIN     HERE ;             IMMEDIATE
  35. : WHILE     ?BRANCH,  HERE ;   IMMEDIATE
  36.  
  37. : REPEAT    SWAP   BRANCH,  HERE -  HERE W - !
  38.                        HERE OVER -  SWAP W - ! ;   IMMEDIATE
  39. : UNTIL           ?BRANCH,  HERE -  HERE W - ! ;   IMMEDIATE
  40. : AGAIN            BRANCH,  HERE -  HERE W - ! ;   IMMEDIATE
  41. : EXIT      R> DROP ;
  42.  
  43.  
  44. 0 CONSTANT CASE  IMMEDIATE
  45. : <OF>      OVER = IF  DROP 1  ELSE  0  THEN ;
  46. : OF        1 + >R  COMPILE  <OF>  ?BRANCH,  HERE W - R> ; IMMEDIATE
  47. : ENDOF         >R [COMPILE] ELSE  R> ;                    IMMEDIATE
  48. : ENDCASE   0 FOR  [COMPILE] THEN  NEXT ;                  IMMEDIATE
  49.  
  50.  
  51. : LIT     R> DUP W + >R @ ;
  52. : ASCII   ( char-- b )  BL WORD  W + C@
  53.                         State @ IF  COMPILE LIT ,  THEN ; IMMEDIATE
  54. : CONTROL ( char-- b )  BL WORD  W + C@ 64 -
  55.                         State @ IF  COMPILE LIT ,  THEN ; IMMEDIATE
  56.  
  57. DECIMAL
  58. : PAD   HERE 100 + ;      VARIABLE HLD
  59. : <#     ( n -- n )  PAD HLD ! ;
  60.  
  61. : #9     ( n -- )  9 OVER <  IF  7 +  THEN   ASCII 0 + ;
  62. : HOLD   ( char -- )  HLD @ -1 +  DUP HLD !  C! ;
  63.  
  64. : SIGN   0 < IF  ASCII - HOLD  THEN ;
  65.  
  66. : #   ( n -- n  ( one digit )  BASE @  /MOD ( U/MOD ) SWAP ABS #9 HOLD ;
  67. : #S  ( n -- 0  )  BEGIN  #   DUP  0 = UNTIL ;
  68.  
  69. : #>  ( n -- a l )  DROP   HLD @   PAD OVER -  ;
  70. : F.  ( n -- )   DUP <# # # # #  ASCII . HOLD  #S  SWAP SIGN  #>  TYPE ;
  71. ( F.  is for typing fixed-point numbers from 0.0001 to 200000.0000 )
  72.  
  73. : .R  ( n length -- ) >R  DUP ABS  <#  #S  SWAP SIGN  #>
  74.                       R>  OVER - SPACES  TYPE ;
  75. : U.R ( n length -- ) >R           <#  #S  #>
  76.                       R>  OVER - SPACES  TYPE ;
  77. : .   0 .R  SPACE ;
  78. : ?   @ . ;
  79. : >IN SPAN ;
  80.  
  81. : ANSI. ( n -- )   ABS 0 .R ;
  82. : XY    ( x y -- ) 27 EMIT ." ["  ANSI.  59 EMIT  ANSI.  72 EMIT ;
  83.  
  84. : -ROT    ( n1 n2 n3 -- n3 n1 n2 ) ROT ROT ;
  85. : UNDER   ( n1 n2 -- n1 n1 n2 ) >R DUP R> ;
  86. : TUCK    ( n1 n2 -- n2 n1 n2 ) SWAP OVER ;
  87. : ALONG   ( n1 n2 -- n1+n2 n1 ) OVER + SWAP ;  ( good before DO loops )
  88.  
  89. : W-  W - ;   : 0<  0 < ;    : 0>  0 > ;
  90. : 1+  1 + ;   : 1-  1 - ;
  91. : 2+  2 + ;   : 2-  2 - ;    : 2/  2 / ;    : 2*  2 * ;
  92.  
  93. : TOGGLE ( n addr -- )  TUCK @ XOR SWAP ! ;
  94.  
  95. : TRUE  -1 ;                        : FALSE  0 ;
  96. : ON ( addr -- )  -1 SWAP ! ;       : OFF ( addr -- )  0 SWAP ! ;
  97.  
  98. : -TRAILING   ( addr n1 -- addr n2 )  2DUP + 1-  SWAP
  99.               0 FOR   DUP C@  BL > IF  LEAVE  ELSE  1-  THEN
  100.                 NEXT  1+  OVER - ;
  101. : 0-Terminate ( addr -- )  @+ + 0 SWAP C! ;
  102. : 0"COUNT ( addr -- addr len )  DUP    BEGIN
  103.                       DUP C@ WHILE  1+ REPEAT  OVER - ;
  104.  
  105.  
  106. : ".  ( addr -- )  @+ TYPE ;      (  ".  prints a counted       string )
  107. : 0". ( addr -- )  0"COUNT TYPE ; ( 0".  prints a 0-terminated string. )
  108.  
  109.  
  110. 4 CONSTANT StrPadSize                  ( All strings are padded with 4 0's  )
  111. : "->0"    ( addr1 -- addr2 )  W + ;   ( Convert counted string to 0-end string )
  112. : ",       @ W+ StrPadSize + ALLOT ;   ( Compile string into dictionary   )
  113.  
  114. : <">      R> DUP  @+ +  StrPadSize +  >R     ;
  115. : <.(>     R> DUP  @+ +  StrPadSize +  >R  ". ;
  116. : <ABORT"> R> DUP  @+ +  StrPadSize +  >R  SWAP  IF  ".  ABORT CR
  117.            ELSE  DROP  THEN ;
  118.  
  119. : 0"       State @ IF  COMPILE <0">   THEN
  120.            ASCII " WORD
  121.            State @ IF  ",  ELSE "->0" THEN ; IMMEDIATE
  122.  
  123. : "        State @ IF  COMPILE <">    THEN
  124.            ASCII " WORD
  125.            State @ IF  ",             THEN ; IMMEDIATE
  126.  
  127. : ."       State @ IF  [COMPILE] ."   ELSE
  128.            ASCII " WORD  ".           THEN ; IMMEDIATE
  129.  
  130. : .(       State @ IF  COMPILE <.(>   THEN
  131.            ASCII ) WORD
  132.            State @ IF  ",  ELSE  ".   THEN ; IMMEDIATE
  133.  
  134. : ,"       [COMPILE] "  HERE @ W+ ALLOT ;
  135.  
  136. : ABORT"   ?COMPILE    COMPILE <ABORT"> 
  137.            ASCII " WORD  ", ; IMMEDIATE
  138.  
  139. VARIABLE FENCE
  140. : +VLink      W  + ;
  141. : +NextVoc  2 W* + ;
  142. : FORGET ( name-- )     \ Forgets across vocabularies
  143.     [COMPILE] '  FENCE @ over U< IF
  144.        Context ContextSize W* along DO
  145.            dup  I @  u< IF  0 I !  THEN  W +LOOP
  146.        Context  Context ContextSize W* along do
  147.            I @ IF  I @  0 I !  over !  W+  THEN   W +LOOP  drop
  148.        >R  I  Current @ +VLink @ U< IF  [COMPILE] Forth  THEN
  149.        VOC-LINK @
  150.        BEGIN  I OVER U< WHILE  +NextVoc @  REPEAT
  151.        DUP VOC-LINK !
  152.        BEGIN  DUP +VLink
  153.            BEGIN  @  dup I u< UNTIL
  154.            over +VLink !  +NextVoc @  ?DUP 0=
  155.        UNTIL  R> DP!
  156.     ELSE
  157.       ." Can't forget before FENCE! " cr
  158.     THEN ;
  159.  
  160. ' FORGET FENCE !   \ Set up the fence
  161.  
  162.  
  163. HEX
  164. : ' ( word-- lfa )  [COMPILE] '  STATE @ IF  [COMPILE] LITERAL  THEN ;
  165. IMMEDIATE
  166.  
  167. : LFA ( lfa -- lfa )      ;
  168. : FFA ( lfa -- ffa ) 04 + ; ( Flag Field Address )
  169. : CFA ( lfa -- cfa ) 08 + ; ( Code Field Address )
  170. : NFA ( lfa -- nfa ) 0C + ; ( Name Field Address )
  171. : PFA ( lfa -- pfa ) 30 + ; ( Parameter Field Address )
  172. DECIMAL
  173.  
  174.  
  175. : 2CONSTANT  CREATE  SWAP , ,  DOES>  DUP @ SWAP W+ @ ;
  176. : 2VARIABLE  VARIABLE  W 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 @  W+  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.                                     W+ 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  W*  HERE  OVER ALLOT  DUP ROT 0 FILL
  214.                             %TO @ IF  SWAP W* + <TODOES>  THEN
  215.                     DOES>  SWAP W* +  <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 @ W+ ALLOT  DUP StringSize @ W+ 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
  240. Variable   ActionTaken
  241. Variable   BytesTransferred
  242. Variable   BufferArea
  243. Variable   BufferLength
  244.  
  245. 0   Constant    EABUF
  246. 42  Constant    OpenMode
  247. 11  Constant    OpenFlag
  248. 0   Constant    FileAttribute
  249. 0   Constant    FileSize
  250.  
  251. : Open ( name -- handle ) >R EABUF OpenMode OpenFlag FileAttribute
  252.     FileSize ActionTaken Handle R> sys$open syscall
  253.     9 Drops  handle @ ;
  254.  
  255. \ : Close ( handle -- ) Sys$Close SysCall 2drop ;
  256.  
  257. : FWrite ( handle address length )
  258.   BufferLength !
  259.   BufferArea !
  260.   Handle !
  261.   BytesTransferred BufferLength @ BufferArea @ Handle @ sys$write syscall
  262.   4 drops ;
  263.  
  264. : FRead ( handle address buffersize --  )
  265.   BufferLength !
  266.   BufferArea !
  267.   Handle !
  268.   BytesTransferred BufferLength @ BufferArea @ Handle @ sys$read syscall
  269.   5 drops ;
  270.  
  271. : EOF?  ( -- f ) BytesTransferred @ 0= ;  \ True if at end of file
  272.  
  273. Variable FilePtr
  274. : FSeek   ( ptr handle -- f ) >R  FilePtr  0  ROT   R> SYS$SEEK SYSCALL
  275.                               >R  4 Drops  R> ;
  276.  
  277. : Readln ( handle -- addr len ) DUP >R  FBuffer 100 FRead
  278.          FBuffer  begin 
  279.                      dup c@  dup 0A =  swap 0= OR  NOT while
  280.               1+  repeat  1- ( subtract off 0Dh from length )
  281.          FBuffer tuck -  dup FilePtr @ + 2+ R> FSeek  ABORT" Seek failed" ;
  282.  
  283.  
  284. : Fibinacci ( n -- fib[n] )
  285.   dup 2 <= if drop 1 else dup 1 - recurse swap 2 - recurse + then ;
  286.  
  287.  
  288. Variable ResultCodes 4 allot
  289.  
  290. Variable Arguments 256 Allot
  291.  
  292. : Args  ( string -- ) Arguments "MOVE  Arguments 0-Terminate ;
  293. : Args" ( args-- )  State @ IF  [COMPILE] "  Compile Args  ELSE
  294.                                  ASCII " WORD  Args        THEN ; IMMEDIATE
  295.  
  296. : Shell ( name -- ) Arguments W+ @ if
  297.                         Arguments W+  over @  over + 1+ Arguments @ 1+ cmove>
  298.                         dup @  Arguments + W+ 0 swap c!
  299.                         dup    Arguments "MOVE then     "->0"
  300.                     ResultCodes 0 Arguments W+ 0 0 0 sys$execpgm syscall
  301.                     8 drops     0 Arguments W+ ! ;
  302.  
  303. : Shell"   State @ IF   [COMPILE] "  Compile Shell  ELSE
  304.                          ASCII " WORD  shell        THEN ;  IMMEDIATE
  305.  
  306. : CommandShell ( shell's to C:\OS2\CMD.EXE ) " C:\OS2\CMD.EXE" shell ;
  307.  
  308. : dir          " /C DIR " Arguments "MOVE  bl word Arguments "CAT
  309.                Arguments 0-terminate  CommandShell ;  
  310. \ Example: dir *.4th
  311.  
  312.  
  313. DECIMAL
  314.  
  315. \ ?PAGE gives scrolling control to pause at the end of each screen
  316.  
  317. VARIABLE L/P  23 L/P !  ( Lines per Page )
  318. : 0PAGE  0 LINE# ! ;
  319. : ?PAGE  ( -- f )  1 LINE# +!  LINE# @ L/P @ > IF
  320.             CR  ." Space to continue, Enter to advance 1 line... "
  321.             KEY  255 AND  DUP 32 OR 113 = if  DROP  CR True  else
  322.                                      31 > if  0PAGE  then   False then
  323.             13 EMIT  46 SPACES  13 EMIT  ELSE  CR  False  THEN ;
  324.  
  325.  
  326. \ Use DUMP to examine an area of memory 
  327. DECIMAL
  328. : HEX.     DUP 9 > IF  55  ELSE  48  THEN  + EMIT ;
  329. : SAFEMIT  DUP 14 < OVER 6 > AND IF DROP BL THEN  EMIT ;
  330. : ASCII. ( addr -- )  16 0 DO  DUP C@ SAFEMIT  1 + LOOP  DROP ;
  331. : BYTE.    DUP 16 / HEX. 16 MOD HEX. SPACE ;
  332. : LINE.  ( addr -- ) 16 0 DO  DUP C@ BYTE.  1 +
  333.                  DUP 16 MOD 0 = IF  SPACE  THEN  LOOP DROP ;
  334. : DUMP   ( addr len -- ) BASE @ >R HEX  0PAGE CR
  335.          16 / 1 +  0 DO
  336.                DUP .  SPACE  DUP LINE.  3 SPACES DUP ASCII.  
  337.                ?PAGE IF  LEAVE  THEN
  338.          16 + LOOP R> BASE !  DROP ;
  339.  
  340.  
  341. \ MORE lists the contents of a file.   Example:  0" FORTH.INI" MORE
  342. : MORE ( name -- )  Open  0PAGE  CR  0 FilePtr !
  343.         begin   dup readln type  ?PAGE
  344.                 eof?  OR  until
  345.         Close ;
  346.  
  347. : MORE" ( name-- ) ASCII " WORD  W+ MORE ;
  348. \ Example: MORE" FORTH.INI"
  349.  
  350. create WordStr 31 allot   variable ViewPtr
  351. : VIEW ( word-- )  0" FORTH.DOC" Open  CR  0 FilePtr !
  352.         BL Word  WordStr "MOVE
  353.         ViewPtr @ IF  ViewPtr @ over FSEEK ABORT" Seek failed"
  354.         ELSE
  355.           870 0 do  dup readln 2drop       \ Skip 880 lines
  356.                     eof? if  leave then
  357.           loop      eof? if  exit  then
  358.           begin   dup readln               \ Look for vocabulary listing
  359.                   " --Begin--"  =STRING  eof? or  until
  360.           eof? ABORT" Did not find vocabulary listing"
  361.           FilePtr @ ViewPtr !              \ Save beginning location
  362.         THEN
  363.         begin   dup readln                 \ Look for word
  364.                2dup WordStr @ min  WordStr =STRING NOT
  365.                eof? NOT and  while  2drop 
  366.         repeat
  367.         eof? ABORT" Did not find word"
  368.         TYPE  CR  close ;
  369. \ VIEW  shows information about Forth words:  VIEW ECHO
  370.  
  371.  
  372. \ User ECHO to turn on/off echoing of files while they are being loaded.
  373.  
  374. VARIABLE Echo  \ Echo ON  --> Echo file being loaded to screen
  375.                \ Echo OFF --> Do not echo
  376.  
  377. : INCLUDE ( name -- ) OPEN >R                \ Load a Forth source file
  378.         TIB @  #TIB @  FilePtr @  LINE# @  Echo @  \ save & restore TIB
  379.         0 FilePtr !  0 LINE# !
  380.         begin  i readln   1 LINE# +!
  381.            EOF? not while
  382.                dup if  
  383.                   Echo @ if cr 2dup type then
  384.                   1+ #TIB !  TIB !  INTERPRET
  385.                else  2drop  then
  386.            repeat    2drop
  387.         Echo !  LINE# !  FilePtr !  #TIB !  TIB !
  388.         R> Close ;
  389.  
  390. : INCLUDE"  ( filename-- ) ASCII " WORD W+ INCLUDE ; \ INCLUDE" STRUCT.4TH"
  391.  
  392.  
  393. : VOCABULARY ( voc_name-- )
  394.              CREATE  HERE  0 ,  0 ,  VOC-LINK @ ,  VOC-LINK !
  395.              DOES>   <VOCABULARY> ;
  396.  
  397. : DEFINITIONS ( -- )  CONTEXT @ CURRENT ! ;
  398. : ONLY ( -- ) CONTEXT @  CONTEXT ContextSize W* 0 FILL  CONTEXT ! 
  399.               DEFINITIONS ;
  400.  
  401. : \   0 SPAN ! ; IMMEDIATE    (  \  cannot be used later in this file )
  402.  
  403.  
  404. ( Add any files you want to load at start-up time here )
  405.  
  406. ( include" struct.4th"   )
  407.   include" threads.4th"
  408. ( include" locals.4th"   )
  409. ( include" startup.4th"  )
  410.  
  411. greet
  412.  
  413.