Power-Programmierung

home *** CD-ROM | disk | FTP | other *** search

/ Power-Programmierung / CD1.mdf / forth / compiler / forth2 / forth.ini < prev next >

Wrap

Text File | 1994-05-22 | 14.9 KB | 467 lines

( FORTH.INI Initialization file for FORTH/2 05/22/94 ) ( Copyright <c> 1993,1994 BLUE STAR SYSTEMS ) ( The following words from the Forth-83 standard are still missing: >BODY CONVERT D+ D< DNEGATE UM* UM/MOD These are partially supported in the file BLOCKS.4TH: BLK BLOCK BUFFER FLUSH LOAD SAVE-BUFFERS UPDATE ) DECIMAL : greet cr ." Welcome to Forth/2 !" cr ; : CLS 27 emit ." [2J" 0 #OUT ! ; ( Define the NON-STANDARD!!! " Fixed 7/8/93 v0.031 ) : " POSTPONE S" POSTPONE DROP POSTPONE CELL POSTPONE - ; IMMEDIATE VARIABLE CSP ( Adds stack checking during compilation ) ( : !CSP SP@ CSP ! ; : ?CSP SP@ CSP @ - IF ." Definition not finished " ABORT THEN ; : : : !CSP ; IMMEDIATE : :NONAME :NONAME !CSP ; IMMEDIATE : ; ?CSP POSTPONE ; ; IMMEDIATE ) 1 CELLS CONSTANT CELL 32 CONSTANT BL : SPACE BL EMIT ; : SPACES 0 MAX 1000 MIN 0 FOR SPACE NEXT ; HEX : ?BRANCH, C383038B , 0FC02304 , 84 C, 0 , ; : BRANCH, E9 C, 0 , ; : BEGIN HERE ; IMMEDIATE : WHILE ?BRANCH, HERE ; IMMEDIATE : REPEAT SWAP BRANCH, HERE - HERE CELL - ! HERE OVER - SWAP CELL - ! ; IMMEDIATE : UNTIL ?BRANCH, HERE - HERE CELL - ! ; IMMEDIATE : AGAIN BRANCH, HERE - HERE CELL - ! ; IMMEDIATE : EXIT R> DROP ; 0 CONSTANT CASE IMMEDIATE : <OF> OVER = IF DROP 1 ELSE 0 THEN ; : OF 1+ >R POSTPONE OVER POSTPONE = POSTPONE IF POSTPONE DROP R> ; IMMEDIATE : ENDOF >R POSTPONE ELSE R> ; IMMEDIATE : ENDCASE POSTPONE DROP 0 FOR POSTPONE THEN NEXT ; IMMEDIATE : LIT R> DUP CELL + >R @ ; : ASCII ( char-- b ) POSTPONE [CHAR] ; IMMEDIATE : CONTROL ( char-- b ) BL WORD CELL+ C@ 64 - State @ IF POSTPONE LIT , THEN ; IMMEDIATE \ : CHAR POSTPONE ASCII ; IMMEDIATE DECIMAL : PAD HERE 200 + ; VARIABLE HLD : <# ( n -- n ) PAD HLD ! ; : #9 ( n -- ) 9 OVER < IF 7 + THEN ASCII 0 + ; : HOLD ( char -- ) HLD @ -1 + DUP HLD ! C! ; : SIGN 0 < IF ASCII - HOLD THEN ; : # ( n -- n ( one digit ) BASE @ /MOD ( U/MOD ) SWAP ABS #9 HOLD ; : #S ( n -- 0 ) BEGIN # DUP 0 = UNTIL ; : #> ( n -- a l ) DROP HLD @ PAD OVER - ; : .R ( n length -- ) >R DUP ABS <# #S SWAP SIGN #> R> OVER - SPACES TYPE ; : U.R ( n length -- ) >R <# #S #> R> OVER - SPACES TYPE ; : . 0 .R SPACE ; : ? @ . ; : ANSI. ( n -- ) ABS 0 .R ; : XY ( x y -- ) 27 EMIT ." [" ANSI. 59 EMIT ANSI. 72 EMIT ; : -ROT ( n1 n2 n3 -- n3 n1 n2 ) ROT ROT ; : UNDER ( n1 n2 -- n1 n1 n2 ) >R DUP R> ; : TUCK ( n1 n2 -- n2 n1 n2 ) SWAP OVER ; : ALONG ( n1 n2 -- n1+n2 n1 ) OVER + SWAP ; ( good before DO loops ) : W- CELL - ; : 0> 0 > ; : 2+ 2 + ; : 2- 2 - ; : TOGGLE ( n addr -- ) TUCK @ XOR SWAP ! ; : TRUE -1 ; : FALSE 0 ; : ON ( addr -- ) -1 SWAP ! ; : OFF ( addr -- ) 0 SWAP ! ; : -TRAILING ( addr n1 -- addr n2 ) 2DUP + 1- SWAP 0 FOR DUP C@ BL > IF LEAVE ELSE 1- THEN NEXT 1+ OVER - ; : 0-Terminate ( addr -- ) @+ + 0 SWAP C! ; : 0"COUNT ( addr -- addr len ) DUP BEGIN DUP C@ WHILE 1+ REPEAT OVER - ; : ". ( addr -- ) @+ TYPE ; ( ". prints a counted string ) : 0". ( addr -- ) 0"COUNT TYPE ; ( 0". prints a 0-terminated string. ) 4 CONSTANT StrPadSize ( All strings are padded with 4 0's ) : "->0" ( addr1 -- addr2 ) CELL + ; ( Convert counted string to 0-end string ) : ", @ CELL+ StrPadSize + ALLOT ; ( Compile string into dictionary ) : <"> R> DUP @+ + StrPadSize + >R ; : <.(> R> DUP @+ + StrPadSize + >R ". ; : <ABORT"> R> DUP @+ + StrPadSize + >R SWAP IF ". ABORT CR ELSE DROP THEN ; \ HUH? (MAW - I don't get this one!?!?!?!? ) \ \ : 0" State @ IF POSTPONE <0"> THEN \ ASCII " WORD \ State @ IF ", ELSE "->0" THEN ; IMMEDIATE \ \ : " State @ IF POSTPONE <"> THEN \ ASCII " WORD \ State @ IF ", THEN ; IMMEDIATE \ \ : ." State @ IF POSTPONE ." ELSE \ ASCII " WORD ". THEN ; IMMEDIATE \ \ : .( State @ IF POSTPONE <.(> THEN \ ASCII ) WORD \ State @ IF ", ELSE ". THEN ; IMMEDIATE \ \ : S" POSTPONE " POSTPONE @+ ; \ \ : ," POSTPONE " HERE @ CELL+ ALLOT ; \ : ABORT" ?COMPILE POSTPONE <ABORT"> ASCII " WORD ", ; IMMEDIATE VARIABLE FENCE : +VLink CELL+ ; : +NextVoc 2 CELLS + ; : FORGET ( name-- ) \ Forgets across vocabularies ' FENCE @ over U< IF Context ContextSize CELLS along DO dup I @ u< IF 0 I ! THEN CELL +LOOP Context Context ContextSize CELLS along do I @ IF I @ 0 I ! over ! CELL+ THEN CELL +LOOP drop >R I Current @ +VLink @ U< IF POSTPONE Forth THEN VOC-LINK @ BEGIN I OVER U< WHILE +NextVoc @ REPEAT DUP VOC-LINK ! BEGIN DUP +VLink BEGIN @ dup I u< UNTIL over +VLink ! +NextVoc @ ?DUP 0= UNTIL R> DP! ELSE ." Can't forget before FENCE! " cr THEN ; ' FORGET FENCE ! \ Set up the fence : 2CONSTANT CREATE SWAP , , DOES> DUP @ SWAP CELL+ @ ; : 2VARIABLE VARIABLE CELL ALLOT ; : ERASE ( addr len -- ) 0 FILL ; \ Fill memory with 0's : TYPE dup 20000 > ABORT" Tried to TYPE over 20000 characters" TYPE ; \ "MOVE moves a counted string to another address : "MOVE ( counted_string_address dest_address -- ) OVER @ CELL+ CMOVE ; \ MOVE>" copies addr,len to be a counted string at dest_addr : MOVE>" ( addr len dest_addr -- ) 2dup ! CELL+ swap cmove ; \ "CAT conCATenate string1 to the end of string2 : "CAT ( counted_string_addr1 counted_string_dest_addr2 -- ) 2DUP @+ + SWAP @+ ROT SWAP CMOVE SWAP @ SWAP +! ; : "CONSTANT ( addr <word>-- Does: -- addr ) HERE 53 + "MOVE CREATE HERE ", DOES> ; : CALL" ( <string><name>-- Does: -- addr ) ASCII " WORD "CONSTANT ; \ CALL" Bill Clinton" President ... President ". : INTEGER ( -- ) CREATE HERE 0 , %TO @ IF <TODOES> ELSE DROP THEN DOES> <TODOES> ; : INTARRAY ( size ) CREATE CELLS HERE OVER ALLOT DUP ROT 0 FILL %TO @ IF SWAP CELLS + <TODOES> THEN DOES> SWAP CELLS + <TODOES> ; \ STRING TO variables: " XYZ123" TO String1 ... String1 ". variable StringSize 255 StringSize ! \ Size of STRING's to be created variable TempString StringSize @ ALLOT \ To move string out of way of CREATE : <"TODOES> ( -- addr ; addr TO -- ; addr +TO -- ) %TO @ IF %TO @ 0> IF "MOVE ELSE "CAT THEN 0 %TO ! THEN ; : STRING %TO @ IF TempString "MOVE TempString THEN CREATE HERE StringSize @ CELL+ ALLOT DUP StringSize @ CELL+ 0 FILL %TO @ IF <"TODOES> ELSE DROP THEN DOES> <"TODOES> ; : TONE ( frequency duration -- ) SWAP SYS$BEEP SYSCALL 3 DROPS ; ( frequency in cycles/second, duration in milliseconds, 1/1000 of a second ) : BEEP 3000 60 TONE ; HEX Variable Handle 0 Handle ! Variable ActionTaken Variable BytesTransferred Variable BufferArea Variable BufferLength Variable LineSource Variable LineLength 0 Constant EABUF 42 Constant OpenMode 01 Constant OpenFlag ( 11h caused files to be created... messy ) 11 Constant CreateFlag 0 Constant FileAttribute 0 Constant FileSize : Source-ID Handle @ ; : \ Source-ID 0= IF Postpone \ ELSE 0 #TIB ! THEN ; Immediate : Source LineLength @ LineSource @ ; ( Modified 5/22/94 MAW, better handling of non-existant files.. ) : Open ( name -- handle ) >R EABUF OpenMode OpenFlag FileAttribute FileSize ActionTaken Handle R> sys$open syscall dup >R 9 Drops handle @ R> ABORT" File not found" ; : OpenNew ( name -- handle )>R EABUF OpenMode CreateFlag FileAttribute FileSize ActionTaken Handle R> sys$open syscall dup >R 9 Drops handle @ R> ABORT" Could not open or create file" ; : Close ( handle -- ) Sys$Close SysCall 2drop ; : FWrite ( handle address length ) BufferLength ! BufferArea ! Handle ! BytesTransferred BufferLength @ BufferArea @ Handle @ sys$write syscall 5 drops ; : FRead ( handle address buffersize -- ) BufferLength ! BufferArea ! Handle ! BytesTransferred BufferLength @ BufferArea @ Handle @ sys$read syscall 5 drops ; : EOF? ( -- f ) BytesTransferred @ 0= ; \ True if at end of file Variable FilePtr : FSeek ( ptr handle -- f ) >R FilePtr 0 ROT R> SYS$SEEK SYSCALL >R 4 Drops R> ; ( Increased line length from 100 to 200 11/14/93 MAW ) ( vvv ) : Readln ( handle -- addr len ) DUP >R FBuffer 200 FRead FBuffer begin dup c@ dup 0A = swap 0= OR NOT while 1+ repeat 1- ( subtract off 0Dh from length ) FBuffer tuck - dup FilePtr @ + 2+ R> FSeek ABORT" Seek failed" 2dup LineSource ! LineLength ! ; : Fibinacci ( n -- fib[n] ) dup 2 <= if drop 1 else dup 1 - recurse swap 2 - recurse + then ; Variable ResultCodes 4 allot Variable Arguments 256 Allot : Args ( string -- ) Arguments "MOVE Arguments 0-Terminate ; : Args" ( args-- ) State @ IF COMPILE " Compile Args ELSE ASCII " WORD Args THEN ; IMMEDIATE : Shell ( name -- ) Arguments CELL+ @ if Arguments CELL+ over @ over + 1+ Arguments @ 1+ cmove> dup @ Arguments + CELL+ 0 swap c! dup Arguments "MOVE then "->0" ResultCodes 0 Arguments CELL+ 0 0 0 sys$execpgm syscall 8 drops 0 Arguments CELL+ ! ; : Shell" State @ IF POSTPONE " Compile Shell ELSE ASCII " WORD shell THEN ; IMMEDIATE : CommandShell ( shell's to C:\OS2\CMD.EXE ) " C:\OS2\CMD.EXE" shell ; : dir " /C DIR " Arguments "MOVE bl word Arguments "CAT Arguments 0-terminate CommandShell ; \ Example: dir *.4th : DoShell " c:\os2\cmd.exe" resultcodes 0 0 0 0 0 sys$execpgm syscall 8 drops ; DECIMAL \ ?PAGE gives scrolling control to pause at the end of each screen VARIABLE L/P 23 L/P ! ( Lines per Page ) : 0PAGE 0 LINE# ! ; : ?PAGE ( -- f ) 1 LINE# +! LINE# @ L/P @ > IF CR ." Space to continue, Enter to advance 1 line... " KEY 255 AND DUP 32 OR 113 = if DROP CR True else 31 > if 0PAGE then False then 13 EMIT 46 SPACES 13 EMIT ELSE CR False THEN ; \ Use DUMP to examine an area of memory DECIMAL : HEX. DUP 9 > IF 55 ELSE 48 THEN + EMIT ; : SAFEMIT DUP 14 < OVER 6 > AND IF DROP BL THEN EMIT ; : ASCII. ( addr -- ) 16 0 DO DUP C@ SAFEMIT 1 + LOOP DROP ; : BYTE. DUP 16 / HEX. 16 MOD HEX. SPACE ; : LINE. ( addr -- ) 16 0 DO DUP C@ BYTE. 1 + DUP 16 MOD 0 = IF SPACE THEN LOOP DROP ; : DUMP ( addr len -- ) BASE @ >R HEX 0PAGE CR 16 / 1 + 0 DO DUP . SPACE DUP LINE. 3 SPACES DUP ASCII. ?PAGE IF LEAVE THEN 16 + LOOP R> BASE ! DROP ; \ MORE lists the contents of a file. Example: 0" FORTH.INI" MORE : MORE ( name -- ) Open 0PAGE CR 0 FilePtr ! begin dup readln type ?PAGE eof? OR until Close ; : MORE" ( name-- ) ASCII " WORD CELL+ MORE ; \ Example: MORE" FORTH.INI" create WordStr 31 allot variable ViewPtr variable MatchEnd : VIEW ( word-- ) 0" FORTH.DOC" Open CR 0 FilePtr ! BL Word WordStr "MOVE ViewPtr @ IF ViewPtr @ over FSEEK ABORT" Seek failed" ELSE 870 0 do dup readln 2drop \ Skip 880 lines eof? if leave then loop eof? if exit then begin dup readln \ Look for vocabulary listing " --Begin--" =STRING eof? or until eof? ABORT" Vocabulary listing seems to be missing from FORTH.DOC!" FilePtr @ ViewPtr ! \ Save beginning location THEN FALSE MatchEnd ! begin dup readln \ Look for word 2dup " --End--" =STRING IF TRUE MatchEnd ! THEN 2dup WordStr @ min WordStr =STRING NOT eof? MatchEnd @ OR NOT and while 2drop repeat ( Mod 05/22/94 MAW - Better handling of word not found ) eof? MatchEnd @ OR IF 2DROP ." Sorry, can't find any information on that word" CR else TYPE CR then close ; \ VIEW shows information about Forth words: VIEW ECHO \ User ECHO to turn on/off echoing of files while they are being loaded. VARIABLE Echo \ Echo ON --> Echo file being loaded to screen \ Echo OFF --> Do not echo ( TRUE ECHO ! ) : INCLUDE ( name -- ) OPEN >R \ Load a Forth source file TIB @ FilePtr @ LINE# @ Echo @ \ save & restore TIB 0 FilePtr ! 0 LINE# ! begin i readln 1 LINE# +! EOF? not while dup if Echo @ if cr 2dup type ( 10 ms ) then 1+ SPAN ! TIB ! 0 >IN ! INTERPRET else 2drop then repeat 2drop Echo ! LINE# ! FilePtr ! TIB ! R> Close 0 #TIB ! 0 >IN ! 0 Handle ! ; : INCLUDE" ( filename-- ) ASCII " WORD CELL+ INCLUDE ; \ INCLUDE" STRUCT.4TH" : VOCABULARY ( voc_name-- ) CREATE HERE 0 , 0 , VOC-LINK @ , VOC-LINK ! IMMEDIATE DOES> <VOCABULARY> ; : DEFINITIONS ( -- ) CONTEXT @ CURRENT ! ; : ONLY ( -- ) CONTEXT @ CONTEXT ContextSize CELLS 0 FILL CONTEXT ! DEFINITIONS ; HEX : show ( -- ) dup 20 - dup 4 - @ ." {" type ." }" ; : MyExecute show key drop <execute> ; ( Install the debugger - Comment out to save lot's o headaches ) \ ' MyExecute 'Execute ! DECIMAL ( Add any file you want to load at start-up time here Due to the oddities of the way FORTH.INI is loaded, this include" never returns, thus MAIN.4th has the real list of include files...! ) include" main.4th"