1206 LOAD ( SEE) 1207 1208 THRU ( (PEMIT SHOW2) 1213 LOAD ( NEW-FILE) 1214 LOAD ( COPIES) 1215 1216 THRU ( L@ L! LC@ LC!) 1217 LOAD ( FLEN ) ( -ZERO ) COMPILER : -ZERO ( a - a') 6 + COMPILE I \ IF ; FORTH ( This works, but I'm not sure that it's exactly what ) ( CM intended. FIAEV shows the code for it as OCTAL 130000, ) ( which should be an unconditional branch. But, surely we want)( to test the value in top of return stack. ) ( REMEMBER; FORGET EMPTY ) ( This is the cmFORTH style FORGET. It is not used from the ) ( keyboard & it is not followed by the name of a word. Use it) ( only inside a place marking word such as EMPTY. ) ( e.g. : EMPTY FORGET REMEMBER; ) COMPILER : END \ RECURSIVE COMPILE \ EXIT ; : REMEMBER; CONTEXT 4 - 2@ , , \ END ; FORTH : FORGET ( ) POP DUP 4 + H ! 2@ CONTEXT 4 - 2! 2 CONTEXT ! ; ( a more familiar FORGET ) : FORGET ( -) 2 CONTEXT ! ( we can't forget in COMPILER) ' NFA 2 - DUP @ 2 HASH ! DUP 4 HASH @ > IF H ! THEN ; ( * we can't let here be before last word in COMPILER vocab) ( e.g. FORGET TST ) ( this version of FORGET must be followed by the name of the ) ( word that you want to FORGET. It and everything defined ) ( after it will disappear, providing no COMPILER words have ) ( been defined since that word. ) ( count words w/ fewer & greater than 3 char names) VARIABLE LOST VARIABLE GAINED VARIABLE #WORDS : CNT CONTEXT @ HASH BEGIN @ ?DUP WHILE DUP 2 + C@ 31 AND 3 - DUP 0< IF LOST ELSE GAINED THEN +! 1 #WORDS +! REPEAT ; : BAL ( -) LOST OFF GAINED OFF #WORDS OFF FORTH CNT COMPILER CNT FORTH CR ." going to 3 char names would cost us " LOST @ ABS . ." bytes because of shorter names " CR ." and gain us " GAINED ? ." bytes on the longer names " CR ." total words in dictionary = " #WORDS ? ; ( crude decompiler SEE ** use only on colon definitions! ** ) : .addr ( ... - ...) ." (" SWAP 2 + DUP @ U. ." )" SWAP ; : SEE ( -) CR ' 3 + BEGIN DUP @ DUP lit \ EXIT - WHILE ( while not the EXIT ) DUP ['] 0branch = IF CR ." IF " .addr ELSE DUP ['] branch = IF CR ." ELSE " .addr ELSE DUP ['] lit = IF SPACE SWAP 2 + DUP @ U. SWAP ELSE DUP ['] next = IF ." next " SWAP 2 + SWAP ELSE DUP ['] dot" = IF SPACE 34 EMIT SWAP 2 + TYPE 2 - SWAP 34 EMIT 2 SPACES ELSE DUP SPACE .ID THEN THEN THEN THEN THEN DROP 2 + REPEAT 2DROP ." ; " CR ; ( list blocks to printer (PEMIT SCR-LIMIT SCR<LIMIT? 2LINES) HEX : (PEMIT ( c -) ( print chr to LPT1: ) 0 0 0500 DOS IF ['] (EMIT) IS EMIT ABORT" ?" THEN DROP ; VARIABLE SCR-LIMIT : SCR<LIMIT? ( n - f) SCR-LIMIT @ < ; : .SCR# ( n -) ." scr # " . ; : .LINE ( a - a') 3F FOR DUP C@ EMIT 1+ NEXT ; : 2LINES ( a1 a2 - a1' a2') SWAP .LINE 5 SPACES SWAP .LINE CR ; HEX ( list block file to printer 2SCRS SHOW SHOW2 ) : 2SCRS ( n1 n2 -) DUP SCR<LIMIT? IF OVER .SCR# 3E SPACES DUP .SCR# CR SWAP BLOCK SWAP BLOCK 0F FOR 2LINES NEXT 2DROP CR CR ELSE DROP LIST THEN ; : SHOW ( 1st last - ) ['] (PEMIT IS EMIT DUP ( #BLKS @ MIN) 1+ SCR-LIMIT ! OVER - 3 / FOR 2 FOR DUP LIST 1+ NEXT 0C EMIT NEXT DROP ['] (EMIT) IS EMIT ; ( *** note, $1D below sets an OKI-DATA printer to small print ) : SHOW2 ( 1st last -) ['] (PEMIT IS EMIT 1D EMIT ( set printer to line = 132 ) DUP ( #BLKS @ MIN) 1+ SCR-LIMIT ! OVER - 6 / FOR 2 FOR DUP DUP 3 + 2SCRS 1+ NEXT 0C EMIT 3 + NEXT DROP ['] (EMIT) IS EMIT ; ( SAMPLE screen to set up the default files ) ( RESET-FILES ) ( 0 OPEN PYGMY.SCR ) 300 OPEN ASM.SCR 600 OPEN HELP 900 OPEN GLOSSARY 1200 OPEN STARTING.FTH 1500 OPEN SUPPL.SCR ( HIDE ) : HIDE ( -) CONTEXT @ HASH ' ( old-LF pfa1) BEGIN OVER @ ( oldLF pfa1 newLF) 2DUP 2 + DUP C@ 31 AND + 1+ ( oldLF pfa1 newLF pfa1 pfa2) - WHILE ( oldLF pfa1 newLF) ROT DROP SWAP ( newLF pfa1) REPEAT ( oldLF pfa1 newLF) SWAP DROP ( oldLF newLF) @ SWAP ! ( unlink middle word) ; ( loading the following two screens will unlink auxilary words that you might not need to look up in the dictionary ) ( HIDE some words we might not need headers for ) HIDE lit HIDE array HIDE var HIDE 0branch HIDE branch HIDE docol HIDE dodoes HIDE for HIDE next HIDE abort" HIDE dot" HIDE >FCB HIDE >F HIDE buffer HIDE block HIDE reset HIDE does HIDE F" HIDE <OPEN> HIDE SPREAD HIDE CLOSE-FILES HIDE RESET HIDE <CLOSE> HIDE INS HIDE UPDT HIDE XIN HIDE H HIDE #CUTS HIDE TILL HIDE A>B HIDE CUR-ON HIDE S! HIDE SET-CUR HIDE CK-CUR HIDE L>A HIDE A>L HIDE B>B HIDE (B>B) HIDE B<B HIDE X HIDE #REM HIDE .EOL HIDE >BEG HIDE >END HIDE BLANK HIDE INSERT HIDE SPLIT HIDE DELETE HIDE DEL-LN HIDE JOIN HIDE CUT HIDE UNCUT HIDE SLEN HIDE S$ HIDE -SRCH HIDE SRCH HIDE SET$ HIDE TILL# HIDE SRCHX HIDE RLEN HIDE R$ HIDE REPL HIDE SETR$ HIDE PgUp HIDE PgDn HIDE -INS HIDE Rt HIDE Lt HIDE Up HIDE Dn HIDE Home HIDE End HIDE SPCL HIDE DISP ( HIDE some words we might not need headers for ) HIDE IMM? HIDE ACC? HIDE ,IMM HIDE 2REGS? HIDE M1 HIDE M2 HIDE M3 HIDE M4 HIDE M5 HIDE M6 HIDE M7 HIDE M8 HIDE M9 HIDE SHORT? HIDE .F HIDE R>M HIDE 1REG? HIDE orW HIDE modDISP, HIDE orDW ( this will create a new 8 screen file ) HEX : NEW-FILE ( -) HERE 1000 + ( start) DUP 2000 20 FILL DUP 1FFF + ( start end) SAVEM ( ) ; ( follow with file name, e.g. NEW-FILE DUMMY.BLK ) ( COPIES ) : COPIES ( fr to # -) ( copy a range of screens ) ( 7 15 3 COPIES would copy 9 to 17, 8 to 16, & 7 to 15 ) ( 7 8 3 COPIES would copy 9 to 10, 8 to 9, 7 to 8 ) DUP 0 > IF 1- FOR 2DUP I + SWAP I + SWAP COPY NEXT THEN 2DROP ; ( L@ & L! ) CODE L@ ( seg offset -- n) ( offset already in BX) ES POP, ( seg) ES: 0 [BX] BX MOV, ( retrieve n) NXT, END-CODE CODE L! ( n seg offset -- ) ( offset already in BX) ES POP, ( seg) AX POP, ( n) ES: AX 0 [BX] MOV, BX POP, ( refill TOS) NXT, END-CODE ( LC@ & LC! ) CODE LC@ ( seg offset -- c) ( offset already in BX) ES POP, ( seg) ES: 0 [BX] BX MOV, ( retrieve c) BH BH SUB, NXT, END-CODE CODE LC! ( c seg offset -- ) ( offset already in BX) ES POP, ( seg) AX POP, ( c) ES: AL 0 [BX] MOV, BX POP, ( refill TOS) NXT, END-CODE ( FLEN returns length of a file in bytes ) HEX : FLEN ( relative-file-# - length-in-bytes) >FCB @ ( handle) 0 0 ROT ( #to.move-h #to.move-l handle) 4202 ( ie move file pointer to eof plus offset of zero) DOS2 ( dx ax flg) IF ABORT" flen error" ELSE SWAP ( double.number.length) THEN ;
