commit 5211f684ba4b51e672c5026d19e80016d3868191 Author: Lars Brinkhoff Date: Wed Mar 25 10:39:06 2015 +0100 Source listing. diff --git a/fig.fth b/fig.fth new file mode 100644 index 0000000..56b4f0c --- /dev/null +++ b/fig.fth @@ -0,0 +1,1468 @@ +SCR # 3 + 0 ********************** fig-FORTH MODEL ********************** + 1 + 2 Through the courtesy of + 3 + 4 FORTH INTEREST GROUP + 5 P. O. BOX 1105 + 6 SAN CARLOS, CA. 94070 + 7 + 8 + 9 RELEASE 1 + 10 WITH COMPILER SECURITY + 11 AND + 12 VARIABLE LENGTH NAMES + 13 + 14 + 15 Further distribution must include the above notice. + + +SCR # 4 + 0 ( ERROR MESSAGES ) + 1 EMPTY STACK + 2 DICTIONARY FULL + 3 HAS INCORRECT ADDRESS MODE + 4 ISN'T UNIQUE + 5 + 6 DISC RANGE ? + 7 FULL STACK + 8 DISC ERROR ! + 9 + 10 + 11 + 12 + 13 + 14 + 15 FORTH INTEREST GROUP MAY 1, 1979 + + +SCR # 5 + 0 ( ERROR MESSAGES ) + 1 COMPILATION ONLY, USE IN DEFINITION + 2 EXECUTION ONLY + 3 CONDITIONALS NOT PAIRED + 4 DEFINITION NOT FINISHED + 5 IN PROTECTED DICTIONARY + 6 USE ONLY WHEN LOADING + 7 OFF CURRENT EDITING SCREEN + 8 DECLARE VOCABULARY + 9 + 10 + 11 + 12 + 13 + 14 + 15 + + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 6 + 0 ( INPUT-OUTPUT, TIM WFR-780519 ) + 1 CODE EMIT XSAVE STX, BOT 1+ LDA, 7F # AND, + 2 72C6 JSR, XSAVE LDX, POP JMP, + 3 CODE KEY XSAVE STX, BEGIN, BEGIN, 8 # LDX, + 4 BEGIN, 6E02 LDA, .A LSR, CS END, 7320 JSR, + 5 BEGIN, 731D JSR, 0 X) CMP, 0 X) CMP, 0 X) CMP, + 6 0 X) CMP, 0 X) CMP, 6E02 LDA, .A LSR, PHP, TYA, + 7 .A LSR, PLP, CS IF, 80 # ORA, THEN, TAY, DEX, + 8 0= END, 731D JSR, FF # EOR, 7F # AND, 0= NOT END, + 9 7F # CMP, 0= NOT END, XSAVE LDX, PUSH0A JMP, + 10 CODE CR XSAVE STX, 728A JSR, XSAVE LDX, NEXT JMP, + 11 + 12 CODE ?TERMINAL 1 # LDA, 6E02 BIT, 0= NOT IF, + 13 BEGIN, 731D JSR, 6E02 BIT, 0= END, INY, THEN, + 14 TYA, PUSH0A JMP, + 15 DECIMAL ;S + + +SCR # 7 + 0 ( INPUT-OUTPUT, APPLE WFR-780730 ) + 1 CODE HOME FC58 JSR, NEXT JMP, + 2 CODE SCROLL FC70 JSR, NEXT JMP, + 3 + 4 HERE ' KEY 2 - ! ( POINT KEY TO HERE ) + 5 FD0C JSR, 7F # AND, PUSH0A JMP, + 6 HERE ' EMIT 2 - ! ( POINT EMIT TO HERE ) + 7 BOT 1+ LDA, 80 # ORA, FDED JSR, POP JMP, + 8 HERE ' CR 2 - ! ( POINT CR TO HERE ) + 9 FD8E JSR, NEXT JMP, + 10 HERE ' ?TERMINAL 2 - ! ( POINT ?TERM TO HERE ) + 11 C000 BIT, 0< + 12 IF, BEGIN, C010 BIT, C000 BIT, 0< NOT END, INY, + 13 THEN, TYA, PUSH0A JMP, + 14 + 15 DECIMAL ;S + + +SCR # 8 + 0 ( INPUT-OUTPUT, SYM-1 WFR-781015 ) + 1 HEX + 2 CODE KEY 8A58 JSR, 7F # AND, PUSH0A JMP, + 3 + 4 CODE EMIT BOT 1+ LDA, 8A47 JSR, POP JMP, + 5 + 6 CODE CR 834D JSR, NEXT JMP, + 7 + 8 CODE ?TERMINAL ( BREAK TEST FOR ANY KEY ) + 9 8B3C JSR, CS + 10 IF, BEGIN, 8B3C JSR, CS NOT END, INY, THEN, + 11 TYA, PUSH0A JMP, + 12 + 13 + 14 + 15 DECIMAL ;S + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 12 + 0 ( COLD AND WARM ENTRY, USER PARAMETERS WFR-79APR29 ) + 1 ASSEMBLER OBJECT MEM HEX + 2 NOP, HERE JMP, ( WORD ALIGNED VECTOR TO COLD ) + 3 NOP, HERE JMP, ( WORD ALIGNED VECTOR TO WARM ) + 4 0000 , 0001 , ( CPU, AND REVISION PARAMETERS ) + 5 0000 , ( TOPMOST WORD IN FORTH VOCABULARY ) + 6 7F , ( BACKSPACE CHARACTER ) + 7 3BA0 , ( INITIAL USER AREA ) + 8 009E , ( INITIAL TOP OF STACK ) + 9 01FF , ( INITIAL TOP OF RETURN STACK ) + 10 0100 , ( TERMINAL INPUT BUFFER ) + 11 001F , ( INITIAL NAME FIELD WIDTH ) + 12 0001 , ( INITIAL WARNING = 1 ) + 13 0200 , ( INITIAL FENCE ) + 14 0000 , ( COLD START VALUE FOR DP ) + 15 0000 , ( COLD START VALUE FOR VOC-LINK ) --> + + +SCR # 13 + 0 ( START OF NUCLEUS, LIT, PUSH, PUT, NEXT WFR-78DEC26 ) + 1 CODE LIT ( PUSH FOLLOWING LITERAL TO STACK *) + 2 IP )Y LDA, PHA, IP INC, 0= IF, IP 1+ INC, THEN, + 3 IP )Y LDA, IP INC, 0= IF, IP 1+ INC, THEN, + 4 LABEL PUSH ( PUSH ACCUM AS HI-BYTE, ML STACK AS LO-BYTE *) + 5 DEX, DEX, + 6 LABEL PUT ( REPLACE BOTTOM WITH ACCUM. AND ML STACK *) + 7 BOT 1+ STA, PLA, BOT STA, + 8 LABEL NEXT ( EXECUTE NEXT FORTH ADDRESS, MOVING IP *) + 9 1 # LDY, IP )Y LDA, W 1+ STA, ( FETCH CODE ADDRESS ) + 10 DEY, IP )Y LDA, W STA, + 11 CLC, IP LDA, 2 # ADC, IP STA, ( MOVE IP AHEAD ) + 12 CS IF, IP 1+ INC, THEN, + 13 W 1 - JMP, ( JUMP INDIR. VIA W THRU CODE FIELD TO CODE ) + 14 + 15 --> + + +SCR # 14 + 0 ( SETUP WFR-790225 ) + 1 HERE 2+ , ( MAKE SILENT WORD *) + 2 IP )Y LDA, PHA, TYA, 'T LIT 0B + 0= NOT END, + 3 + 4 LABEL SETUP ( MOVE # ITEMS FROM STACK TO 'N' AREA OF Z-PAGE *) + 5 .A ASL, N 1 - STA, + 6 BEGIN, BOT LDA, N ,Y STA, INX, INY, + 7 N 1 - CPY, 0= END, 0 # LDY, RTS, + 8 + 9 CODE EXECUTE ( EXECUTE A WORD BY ITS CODE FIELD *) + 10 ( ADDRESS ON THE STACK *) + 11 BOT LDA, W STA, BOT 1+ LDA, W 1+ STA, + 12 INX, INX, W 1 - JMP, + 13 + 14 + 15 --> + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 15 + 0 ( BRANCH, 0BRANCH W/16-BIT OFFSET WFR-79APR01 ) + 1 CODE BRANCH ( ADJUST IP BY IN-LINE 16 BIT LITERAL *) + 2 CLC, IP )Y LDA, IP ADC, PHA, + 3 INY, IP )Y LDA, IP 1+ ADC, IP 1+ STA, + 4 PLA, IP STA, NEXT 2+ JMP, + 5 + 6 CODE 0BRANCH ( IF BOT IS ZERO, BRANCH FROM LITERAL *) + 7 INX, INX, FE ,X LDA, FF ,X ORA, + 8 ' BRANCH 0= NOT END, ( USE 'BRANCH' FOR FALSE ) + 9 LABEL BUMP: ( TRUE JUST MOVES IP 2 BYTES *) + 10 CLC, IP LDA, 2 # ADC, IP STA, + 11 CS IF, IP 1+ INC, THEN, NEXT JMP, + 12 + 13 --> + 14 + 15 + + +SCR # 16 + 0 ( LOOP CONTROL WFR-79MAR20 ) + 1 CODE (LOOP) ( INCREMENT LOOP INDEX, LOOP UNTIL => LIMIT *) + 2 XSAVE STX, TSX, R INC, 0= IF, R 1+ INC, THEN, + 3 LABEL L1: CLC, R 2+ LDA, R SBC, R 3 + LDA, R 1+ SBC, + 4 LABEL L2: XSAVE LDX, ( LIMIT-INDEX-1 ) + 5 .A ASL, ' BRANCH CS END, ( BRANCH UNTIL D7 SIGN=1 ) + 6 PLA, PLA, PLA, PLA, BUMP: JMP, ( ELSE EXIT LOOP ) + 7 + 8 CODE (+LOOP) ( INCREMENT INDEX BY STACK VALUE +/- *) + 9 INX, INX, XSAVE STX, ( POP INCREMENT ) + 10 FF ,X LDA, PHA, PHA, FE ,X LDA, TSX, INX, INX, + 11 CLC, R ADC, R STA, PLA, R 1 + ADC, R 1 + STA, + 12 PLA, L1: 0< END, ( AS FOR POSITIVE INCREMENT ) + 13 CLC, R LDA, R 2+ SBC, ( INDEX-LIMIT-1 ) + 14 R 1+ LDA, R 3 + SBC, L2: JMP, + 15 --> + + +SCR # 17 + 0 ( (DO- WFR-79MAR30 ) + 1 + 2 CODE (DO) ( MOVE TWO STACK ITEMS TO RETURN STACK *) + 3 SEC 1+ LDA, PHA, SEC LDA, PHA, + 4 BOT 1+ LDA, PHA, BOT LDA, PHA, + 5 + 6 LABEL POPTWO INX, INX, + 7 LABEL POP INX, INX, NEXT JMP, + 8 + 9 CODE I ( COPY CURRENT LOOP INDEX TO STACK *) + 10 ( THIS WILL LATER BE POINTED TO 'R' ) + 11 + 12 --> + 13 + 14 + 15 + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 18 + 0 ( DIGIT WFR-781202 ) + 1 CODE DIGIT ( CONVERT ASCII CHAR-SECOND, WITH BASE-BOTTOM *) + 2 ( IF OK RETURN DIGIT-SECOND, TRUE-BOTTOM; *) + 3 ( OTHERWISE FALSE-BOTTOM. *) + 4 SEC, SEC LDA, 30 # SBC, + 5 0< NOT IF, 0A # CMP, ( ADJUST FOR ASCII LETTER ) + 6 0< NOT IF, SEC, 07 # SBC, 0A # CMP, + 7 0< NOT IF, + 8 SWAP ( AT COMPILE TIME ) THEN, BOT CMP, ( TO BASE ) + 9 0< IF, SEC STA, 1 # LDA, + 10 PHA, TYA, PUT JMP, + 11 ( STORE RESULT SECOND AND RETURN TRUE ) + 12 THEN, THEN, THEN, ( CONVERSION FAILED ) + 13 TYA, PHA, INX, INX, PUT JMP, ( LEAVE BOOLEAN FALSE ) + 14 + 15 --> + + +SCR # 19 + 0 ( FIND FOR VARIABLE LENGTH NAMES WFR-790225 ) + 1 CODE (FIND) ( HERE, NFA ... PFA, LEN BYTE, TRUE; ELSE FALSE *) + 2 2 # LDA, SETUP JSR, XSAVE STX, + 3 BEGIN, 0 # LDY, N )Y LDA, N 2+ )Y EOR, 3F # AND, 0= + 4 IF, ( GOOD ) BEGIN, INY, N )Y LDA, N 2+ )Y EOR, .A ASL, 0= + 5 IF, ( STILL GOOD ) SWAP CS ( LOOP TILL D7 SET ) + 6 END, XSAVE LDX, DEX, DEX, DEX, DEX, CLC, + 7 TYA, 5 # ADC, N ADC, SEC STA, 0 # LDY, + 8 TYA, N 1+ ADC, SEC 1+ STA, BOT 1+ STY, + 9 N )Y LDA, BOT STA, 1 # LDA, PHA, PUSH JMP, ( FALSE ) + 10 THEN, CS NOT ( AT LAST CHAR? ) IF, SWAP THEN, + 11 BEGIN, INY, N )Y LDA, 0< END, ( TO LAST CHAR ) + 12 THEN, INY, ( TO LINK ) N )Y LDA, TAX, INY, + 13 N )Y LDA, N 1+ STA, N STX, N ORA, ( 0 LINK ? ) + 14 0= END, ( LOOP FOR ANOTHER NAME ) + 15 XSAVE LDX, 0 # LDA, PHA, PUSH JMP, ( FALSE ) --> + + +SCR # 20 + 0 ( ENCLOSE WFR-780926 ) + 1 CODE ENCLOSE ( ENTER WITH ADDRESS-2, DELIM-1. RETURN WITH *) + 2 ( ADDR-4, AND OFFSET TO FIRST CH-3, END WORD-2, NEXT CH-1 *) + 3 2 # LDA, SETUP JSR, TXA, SEC, 8 # SBC, TAX, + 4 SEC 1+ STY, BOT 1+ STY, ( CLEAR HI BYTES ) DEY, + 5 BEGIN, INY, N 2+ )Y LDA, ( FETCH CHAR ) + 6 N CMP, 0= NOT END, ( STEP OVER LEADING DELIMITERS ) + 7 BOT 4 + STY, ( SAVE OFFSET TO FIRST CHAR ) + 8 BEGIN, N 2+ )Y LDA, 0= + 9 IF, ( NULL ) SEC STY, ( IN EW ) BOT STY, ( IN NC ) + 10 TYA, BOT 4 + CMP, 0= + 11 IF, ( Y=FC ) SEC INC, ( BUMP EW ) THEN, NEXT JMP, + 12 THEN, SEC STY, ( IN EW ) INY, N CMP, ( DELIM ? ) + 13 0= END, ( IS DELIM ) BOT STY, ( IN NC ) NEXT JMP, + 14 + 15 --> + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 21 + 0 ( TERMINAL VECTORS WFR-79MAR30 ) + 1 ( THESE WORDS ARE CREATED WITH NO EXECUTION CODE, YET. ) + 2 ( THEIR CODE FIELDS WILL BE FILLED WITH THE ADDRESS OF THEIR ) + 3 ( INSTALLATION SPECIFIC CODE. ) + 4 + 5 CODE EMIT ( PRINT ASCII VALUE ON BOTTOM OF STACK *) + 6 + 7 CODE KEY ( ACCEPT ONE TERMINAL CHARACTER TO THE STACK *) + 8 + 9 CODE ?TERMINAL ( 'BREAK' LEAVES 1 ON STACK; OTHERWISE 0 *) + 10 + 11 CODE CR ( EXECUTE CAR. RETURN, LINE FEED ON TERMINAL *) + 12 + 13 --> + 14 + 15 + + +SCR # 22 + 0 ( CMOVE, WFR-79MAR20 ) + 1 CODE CMOVE ( WITHIN MEMORY; ENTER W/ FROM-3, TO-2, QUAN-1 *) + 2 3 # LDA, SETUP JSR, ( MOVE 3 ITEMS TO 'N' AREA ) + 3 BEGIN, BEGIN, N CPY, 0= ( DECREMENT BYTE COUNTER AT 'N' ) + 4 IF, N 1+ DEC, 0< ( EXIT WHEN DONE ) + 5 IF, NEXT JMP, THEN, THEN, + 6 N 4 + )Y LDA, N 2+ )Y STA, INY, 0= + 7 END, ( LOOP TILL Y WRAPS, 22 CYCLES/BYTE ) + 8 N 5 + INC, N 3 + INC, ( BUMP HI BYTES OF POINTERS ) + 9 JMP, ( BACK TO FIRST 'BEGIN' ) + 10 + 11 --> + 12 + 13 + 14 + 15 + + +SCR # 23 + 0 ( U*, UNSIGNED MULTIPLY FOR 16 BITS RS-WFR-80AUG16 ) + 1 CODE U* ( 16 BIT MULTIPLICAND-2, 16 BIT MULTIPLIER-1 *) + 2 ( 32 BIT UNSIGNED PRODUCT: LO WORD-2, HI WORD-1 *) + 3 SEC LDA, N STA, SEC STY, + 4 SEC 1+ LDA, N 1+ STA, SEC 1+ STY, ( multiplicand to n ) + 5 10 # LDY, + 6 BEGIN, BOT 2+ ASL, BOT 3 + ROL, BOT ROL, BOT 1+ ROL, + 7 ( double product while sampling D15 of multiplier ) + 8 CS IF, ( set ) CLC, + 9 ( add multiplicand to partial product 32 bits ) + 10 N LDA, BOT 2 + ADC, BOT 2 + STA, + 11 N 1+ LDA, BOT 3 + ADC, BOT 3 + STA, + 12 CS IF, BOT INC, 0= IF, BOT 1+ INC, ENDIF, ENDIF, + 13 ENDIF, DEY, 0= ( corrected for carry bug ) + 14 UNTIL, NEXT JMP, C; + 15 --> + +FORTH INTEREST GROUP Aug 23, 1980 + +SCR # 24 + 0 ( U/, UNSIGNED DIVIDE FOR 31 BITS WFR-79APR29 ) + 1 CODE U/ ( 31 BIT DIVIDEND-2, -3, 16 BIT DIVISOR-1 *) + 2 ( 16 BIT REMAINDER-2, 16 BIT QUOTIENT-1 *) + 3 SEC 2 + LDA, SEC LDY, SEC 2 + STY, .A ASL, SEC STA, + 4 SEC 3 + LDA, SEC 1+ LDY, SEC 3 + STY, .A ROL, SEC 1+ STA, + 5 10 # LDA, N STA, + 6 BEGIN, SEC 2 + ROL, SEC 3 + ROL, SEC, + 7 SEC 2 + LDA, BOT SBC, TAY, + 8 SEC 3 + LDA, BOT 1+ SBC, + 9 CS IF, SEC 2+ STY, SEC 3 + STA, THEN, + 10 SEC ROL, SEC 1+ ROL, + 11 N DEC, 0= + 12 END, POP JMP, + 13 --> + 14 + 15 + + +SCR # 25 + 0 ( LOGICALS WFR-79APR20 ) + 1 + 2 CODE AND ( LOGICAL BITWISE AND OF BOTTOM TWO ITEMS *) + 3 BOT LDA, SEC AND, PHA, + 4 BOT 1+ LDA, SEC 1+ AND, INX, INX, PUT JMP, + 5 + 6 CODE OR ( LOGICAL BITWISE 'OR' OF BOTTOM TWO ITEMS *) + 7 BOT LDA, SEC ORA, PHA, + 8 BOT 1+ LDA, SEC 1 + ORA, INX, INX, PUT JMP, + 9 + 10 CODE XOR ( LOGICAL 'EXCLUSIVE-OR' OF BOTTOM TWO ITEMS *) + 11 BOT LDA, SEC EOR, PHA, + 12 BOT 1+ LDA, SEC 1+ EOR, INX, INX, PUT JMP, + 13 + 14 --> + 15 + + +SCR # 26 + 0 ( STACK INITIALIZATION WFR-79MAR30 ) + 1 CODE SP@ ( FETCH STACK POINTER TO STACK *) + 2 TXA, + 3 LABEL PUSH0A PHA, 0 # LDA, PUSH JMP, + 4 + 5 CODE SP! ( LOAD SP FROM 'S0' *) + 6 06 # LDY, UP )Y LDA, TAX, NEXT JMP, + 7 + 8 CODE RP! ( LOAD RP FROM R0 *) + 9 XSAVE STX, 08 # LDY, UP )Y LDA, TAX, TXS, + 10 XSAVE LDX, NEXT JMP, + 11 + 12 CODE ;S ( RESTORE IP REGISTER FROM RETURN STACK *) + 13 PLA, IP STA, PLA, IP 1+ STA, NEXT JMP, + 14 + 15 --> + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 27 + 0 ( RETURN STACK WORDS WFR-79MAR29 ) + 1 CODE LEAVE ( FORCE EXIT OF DO-LOOP BY SETTING LIMIT *) + 2 XSAVE STX, TSX, R LDA, R 2+ STA, ( TO INDEX *) + 3 R 1+ LDA, R 3 + STA, XSAVE LDX, NEXT JMP, + 4 + 5 CODE >R ( MOVE FROM COMP. STACK TO RETURN STACK *) + 6 BOT 1+ LDA, PHA, BOT LDA, PHA, INX, INX, NEXT JMP, + 7 + 8 CODE R> ( MOVE FROM RETURN STACK TO COMP. STACK *) + 9 DEX, DEX, PLA, BOT STA, PLA, BOT 1+ STA, NEXT JMP, + 10 + 11 CODE R ( COPY THE BOTTOM OF RETURN STACK TO COMP. STACK *) + 12 XSAVE STX, TSX, R LDA, PHA, R 1+ LDA, + 13 XSAVE LDX, PUSH JMP, + 14 ' R -2 BYTE.IN I ! + 15 --> + + +SCR # 28 + 0 ( TESTS AND LOGICALS WFR-79MAR19 ) + 1 + 2 CODE 0= ( REVERSE LOGICAL STATE OF BOTTOM OF STACK *) + 3 BOT LDA, BOT 1+ ORA, BOT 1+ STY, + 4 0= IF, INY, THEN, BOT STY, NEXT JMP, + 5 + 6 CODE 0< ( LEAVE TRUE IF NEGATIVE; OTHERWISE FALSE *) + 7 BOT 1+ ASL, TYA, .A ROL, BOT 1+ STY, BOT STA, NEXT JMP, + 8 + 9 + 10 --> + 11 + 12 + 13 + 14 + 15 + + +SCR # 29 + 0 ( MATH WFR-79MAR19 ) + 1 CODE + ( LEAVE THE SUM OF THE BOTTOM TWO STACK ITEMS *) + 2 CLC, BOT LDA, SEC ADC, SEC STA, BOT 1+ LDA, SEC 1+ ADC, + 3 SEC 1+ STA, INX, INX, NEXT JMP, + 4 CODE D+ ( ADD TWO DOUBLE INTEGERS, LEAVING DOUBLE *) + 5 CLC, BOT 2 + LDA, BOT 6 + ADC, BOT 6 + STA, + 6 BOT 3 + LDA, BOT 7 + ADC, BOT 7 + STA, + 7 BOT LDA, BOT 4 + ADC, BOT 4 + STA, + 8 BOT 1 + LDA, BOT 5 + ADC, BOT 5 + STA, POPTWO JMP, + 9 CODE MINUS ( TWOS COMPLEMENT OF BOTTOM SINGLE NUMBER *) + 10 SEC, TYA, BOT SBC, BOT STA, + 11 TYA, BOT 1+ SBC, BOT 1+ STA, NEXT JMP, + 12 CODE DMINUS ( TWOS COMPLEMENT OF BOTTOM DOUBLE NUMBER *) + 13 SEC, TYA, BOT 2 + SBC, BOT 2 + STA, + 14 TYA, BOT 3 + SBC, BOT 3 + STA, + 15 1 BYTE.IN MINUS JMP, --> + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 30 + 0 ( STACK MANIPULATION WFR-79MAR29 ) + 1 CODE OVER ( DUPLICATE SECOND ITEM AS NEW BOTTOM *) + 2 SEC LDA, PHA, SEC 1+ LDA, PUSH JMP, + 3 + 4 CODE DROP ( DROP BOTTOM STACK ITEM *) + 5 POP -2 BYTE.IN DROP ! ( C.F. VECTORS DIRECTLY TO 'POP' ) + 6 + 7 CODE SWAP ( EXCHANGE BOTTOM AND SECOND ITEMS ON STACK *) + 8 SEC LDA, PHA, BOT LDA, SEC STA, + 9 SEC 1+ LDA, BOT 1+ LDY, SEC 1+ STY, PUT JMP, + 10 + 11 CODE DUP ( DUPLICATE BOTTOM ITEM ON STACK *) + 12 BOT LDA, PHA, BOT 1+ LDA, PUSH JMP, + 13 + 14 --> + 15 + + +SCR # 31 + 0 ( MEMORY INCREMENT, WFR-79MAR30 ) + 1 + 2 CODE +! ( ADD SECOND TO MEMORY 16 BITS ADDRESSED BY BOTTOM *) + 3 CLC, BOT X) LDA, SEC ADC, BOT X) STA, + 4 BOT INC, 0= IF, BOT 1+ INC, THEN, + 5 BOT X) LDA, SEC 1+ ADC, BOT X) STA, POPTWO JMP, + 6 + 7 CODE TOGGLE ( BYTE AT ADDRESS-2, BIT PATTERN-1 ... *) + 8 SEC X) LDA, BOT EOR, SEC X) STA, POPTWO JMP, + 9 + 10 --> + 11 + 12 + 13 + 14 + 15 + + +SCR # 32 + 0 ( MEMORY FETCH AND STORE WFR-781202 ) + 1 CODE @ ( REPLACE STACK ADDRESS WITH 16 BIT *) + 2 BOT X) LDA, PHA, ( CONTENTS OF THAT ADDRESS *) + 3 BOT INC, 0= IF, BOT 1+ INC, THEN, BOT X) LDA, PUT JMP, + 4 + 5 CODE C@ ( REPLACE STACK ADDRESS WITH POINTED 8 BIT BYTE *) + 6 BOT X) LDA, BOT STA, BOT 1+ STY, NEXT JMP, + 7 + 8 CODE ! ( STORE SECOND AT 16 BITS ADDRESSED BY BOTTOM *) + 9 SEC LDA, BOT X) STA, BOT INC, 0= IF, BOT 1+ INC, THEN, + 10 SEC 1+ LDA, BOT X) STA, POPTWO JMP, + 11 + 12 CODE C! ( STORE SECOND AT BYTE ADDRESSED BY BOTTOM *) + 13 SEC LDA, BOT X) STA, POPTWO JMP, + 14 + 15 DECIMAL ;S + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 33 + 0 ( :, ;, WFR-79MAR30 ) + 1 + 2 : : ( CREATE NEW COLON-DEFINITION UNTIL ';' *) + 3 ?EXEC !CSP CURRENT @ CONTEXT ! + 4 CREATE ] ;CODE IMMEDIATE + 5 IP 1+ LDA, PHA, IP LDA, PHA, CLC, W LDA, 2 # ADC, + 6 IP STA, TYA, W 1+ ADC, IP 1+ STA, NEXT JMP, + 7 + 8 + 9 : ; ( TERMINATE COLON-DEFINITION *) + 10 ?CSP COMPILE ;S + 11 SMUDGE [ ; IMMEDIATE + 12 + 13 + 14 + 15 --> + + +SCR # 34 + 0 ( CONSTANT, VARIABLE, USER WFR-79MAR30 ) + 1 : CONSTANT ( WORD WHICH LATER CREATES CONSTANTS *) + 2 CREATE SMUDGE , ;CODE + 3 2 # LDY, W )Y LDA, PHA, INY, W )Y LDA, PUSH JMP, + 4 + 5 : VARIABLE ( WORD WHICH LATER CREATES VARIABLES *) + 6 CONSTANT ;CODE + 7 CLC, W LDA, 2 # ADC, PHA, TYA, W 1+ ADC, PUSH JMP, + 8 + 9 + 10 : USER ( CREATE USER VARIABLE *) + 11 CONSTANT ;CODE + 12 2 # LDY, CLC, W )Y LDA, UP ADC, PHA, + 13 0 # LDA, UP 1+ ADC, PUSH JMP, + 14 + 15 --> + + +SCR # 35 + 0 ( DEFINED CONSTANTS WFR-78MAR22 ) + 1 HEX + 2 00 CONSTANT 0 01 CONSTANT 1 + 3 02 CONSTANT 2 03 CONSTANT 3 + 4 20 CONSTANT BL ( ASCII BLANK *) + 5 40 CONSTANT C/L ( TEXT CHARACTERS PER LINE *) + 6 + 7 3BE0 CONSTANT FIRST ( FIRST BYTE RESERVED FOR BUFFERS *) + 8 4000 CONSTANT LIMIT ( JUST BEYOND TOP OF RAM *) + 9 80 CONSTANT B/BUF ( BYTES PER DISC BUFFER *) + 10 8 CONSTANT B/SCR ( BLOCKS PER SCREEN = 1024 B/BUF / *) + 11 + 12 00 +ORIGIN + 13 : +ORIGIN LITERAL + ; ( LEAVES ADDRESS RELATIVE TO ORIGIN *) + 14 --> + 15 + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 36 + 0 ( USER VARIABLES WFR-78APR29 ) + 1 HEX ( 0 THRU 5 RESERVED, REFERENCED TO $00A0 *) + 2 ( 06 USER S0 ) ( TOP OF EMPTY COMPUTATION STACK *) + 3 ( 08 USER R0 ) ( TOP OF EMPTY RETURN STACK *) + 4 0A USER TIB ( TERMINAL INPUT BUFFER *) + 5 0C USER WIDTH ( MAXIMUM NAME FIELD WIDTH *) + 6 0E USER WARNING ( CONTROL WARNING MODES *) + 7 10 USER FENCE ( BARRIER FOR FORGETTING *) + 8 12 USER DP ( DICTIONARY POINTER *) + 9 14 USER VOC-LINK ( TO NEWEST VOCABULARY *) + 10 16 USER BLK ( INTERPRETATION BLOCK *) + 11 18 USER IN ( OFFSET INTO SOURCE TEXT *) + 12 1A USER OUT ( DISPLAY CURSOR POSITION *) + 13 1C USER SCR ( EDITING SCREEN *) + 14 --> + 15 + + +SCR # 37 + 0 ( USER VARIABLES, CONT. WFR-79APR29 ) + 1 1E USER OFFSET ( POSSIBLY TO OTHER DRIVES *) + 2 20 USER CONTEXT ( VOCABULARY FIRST SEARCHED *) + 3 22 USER CURRENT ( SEARCHED SECOND, COMPILED INTO *) + 4 24 USER STATE ( COMPILATION STATE *) + 5 26 USER BASE ( FOR NUMERIC INPUT-OUTPUT *) + 6 28 USER DPL ( DECIMAL POINT LOCATION *) + 7 2A USER PLO ( OUTPUT FIELD WIDTH *) + 8 2C USER CSP ( CHECK STACK POSITION *) + 9 2E USER R# ( EDITING CURSOR POSITION *) + 10 30 USER HLD ( POINTS TO LAST CHARACTER HELD IN PAD *) + 11 --> + 12 + 13 + 14 + 15 + + +SCR # 38 + 0 ( HI-LEVEL MISC. WFR-79APR29 ) + 1 : 1+ 1 + ; ( INCREMENT STACK NUMBER BY ONE *) + 2 : 2+ 2 + ; ( INCREMENT STACK NUMBER BY TWO *) + 3 : HERE DP @ ; ( FETCH NEXT FREE ADDRESS IN DICT. *) + 4 : ALLOT DP +! ; ( MOVE DICT. POINTER AHEAD *) + 5 : , HERE ! 2 ALLOT ; ( ENTER STACK NUMBER TO DICT. *) + 6 : C, HERE C! 1 ALLOT ; ( ENTER STACK BYTE TO DICT. *) + 7 : - MINUS + ; ( LEAVE DIFF. SEC - BOTTOM *) + 8 : = - 0= ; ( LEAVE BOOLEAN OF EQUALITY *) + 9 : < - 0< ; ( LEAVE BOOLEAN OF SEC < BOT *) + 10 : > SWAP < ; ( LEAVE BOOLEAN OF SEC > BOT *) + 11 : ROT >R SWAP R> SWAP ; ( ROTATE THIRD TO BOTTOM *) + 12 : SPACE BL EMIT ; ( PRINT BLANK ON TERMINAL *) + 13 : -DUP DUP IF DUP ENDIF ; ( DUPLICATE NON-ZERO *) + 14 --> + 15 + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 39 + 0 ( VARIABLE LENGTH NAME SUPPORT WFR-79MAR30 ) + 1 : TRAVERSE ( MOVE ACROSS NAME FIELD *) + 2 ( ADDRESS-2, DIRECTION-1, I.E. -1=R TO L, +1=L TO R *) + 3 SWAP + 4 BEGIN OVER + 7F OVER C@ < UNTIL SWAP DROP ; + 5 + 6 : LATEST CURRENT @ @ ; ( NFA OF LATEST WORD *) + 7 + 8 + 9 ( FOLLOWING HAVE LITERALS DEPENDENT ON COMPUTER WORD SIZE ) + 10 + 11 : LFA 4 - ; ( CONVERT A WORDS PFA TO LFA *) + 12 : CFA 2 - ; ( CONVERT A WORDS PFA TO CFA *) + 13 : NFA 5 - -1 TRAVERSE ; ( CONVERT A WORDS PFA TO NFA *) + 14 : PFA 1 TRAVERSE 5 + ; ( CONVERT A WORDS NFA TO PFA *) + 15 --> + + +SCR # 40 + 0 ( ERROR PROCEEDURES, PER SHIRA WFR-79MAR23 ) + 1 : !CSP SP@ CSP ! ; ( SAVE STACK POSITION IN 'CSP' *) + 2 + 3 : ?ERROR ( BOOLEAN-2, ERROR TYPE-1, WARN FOR TRUE *) + 4 SWAP IF ERROR ELSE DROP ENDIF ; + 5 + 6 : ?COMP STATE @ 0= 11 ?ERROR ; ( ERROR IF NOT COMPILING *) + 7 + 8 : ?EXEC STATE @ 12 ?ERROR ; ( ERROR IF NOT EXECUTING *) + 9 + 10 : ?PAIRS - 13 ?ERROR ; ( VERIFY STACK VALUES ARE PAIRED *) + 11 + 12 : ?CSP SP@ CSP @ - 14 ?ERROR ; ( VERIFY STACK POSITION *) + 13 + 14 : ?LOADING ( VERIFY LOADING FROM DISC *) + 15 BLK @ 0= 16 ?ERROR ; --> + + +SCR # 41 + 0 ( COMPILE, SMUDGE, HEX, DECIMAL WFR-79APR20 ) + 1 + 2 : COMPILE ( COMPILE THE EXECUTION ADDRESS FOLLOWING *) + 3 ?COMP R> DUP 2+ >R @ , ; + 4 + 5 : [ 0 STATE ! ; IMMEDIATE ( STOP COMPILATION *) + 6 + 7 : ] C0 STATE ! ; ( ENTER COMPILATION STATE *) + 8 + 9 : SMUDGE LATEST 20 TOGGLE ; ( ALTER LATEST WORD NAME *) + 10 + 11 : HEX 10 BASE ! ; ( MAKE HEX THE IN-OUT BASE *) + 12 + 13 : DECIMAL 0A BASE ! ; ( MAKE DECIMAL THE IN-OUT BASE *) + 14 --> + 15 + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 42 + 0 ( ;CODE WFR-79APR20 ) + 1 + 2 : (;CODE) ( WRITE CODE FIELD POINTING TO CALLING ADDRESS *) + 3 R> LATEST PFA CFA ! ; + 4 + 5 + 6 : ;CODE ( TERMINATE A NEW DEFINING WORD *) + 7 ?CSP COMPILE (;CODE) + 8 [COMPILE] [ SMUDGE ; IMMEDIATE + 9 --> + 10 + 11 + 12 + 13 + 14 + 15 + + +SCR # 43 + 0 ( WFR-79MAR20 ) + 1 + 2 : ' WORD *) + 3 + 4 : DOES> ( REWRITE PFA WITH CALLING HI-LEVEL ADDRESS *) + 5 ( REWRITE CFA WITH 'DOES>' CODE *) + 6 R> LATEST PFA ! ;CODE + 7 IP 1+ LDA, PHA, IP LDA, PHA, ( BEGIN FORTH NESTING ) + 8 2 # LDY, W )Y LDA, IP STA, ( FETCH FIRST PARAM ) + 9 INY, W )Y LDA, IP 1+ STA, ( AS NEXT INTERP. PTR ) + 10 CLC, W LDA, 4 # ADC, PHA, ( PUSH ADDRESS OF PARAMS ) + 11 W 1+ LDA, 00 # ADC, PUSH JMP, + 12 + 13 --> + 14 + 15 + + +SCR # 44 + 0 ( TEXT OUTPUTS WFR-79APR02 ) + 1 : COUNT DUP 1+ SWAP C@ ; ( LEAVE TEXT ADDR. CHAR. COUNT *) + 2 : TYPE ( TYPE STRING FROM ADDRESS-2, CHAR.COUNT-1 *) + 3 -DUP IF OVER + SWAP + 4 DO I C@ EMIT LOOP ELSE DROP ENDIF ; + 5 : -TRAILING ( ADJUST CHAR. COUNT TO DROP TRAILING BLANKS *) + 6 DUP 0 DO OVER OVER + 1 - C@ + 7 BL - IF LEAVE ELSE 1 - ENDIF LOOP ; + 8 : (.") ( TYPE IN-LINE STRING, ADJUSTING RETURN *) + 9 R COUNT DUP 1+ R> + >R TYPE ; + 10 + 11 + 12 : ." 22 STATE @ ( COMPILE OR PRINT QUOTED STRING *) + 13 IF COMPILE (.") WORD HERE C@ 1+ ALLOT + 14 ELSE WORD HERE COUNT TYPE ENDIF ; + 15 IMMEDIATE --> + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 45 + 0 ( TERMINAL INPUT WFR-79APR29 ) + 1 + 2 : EXPECT ( TERMINAL INPUT MEMORY-2, CHAR LIMIT-1 *) + 3 OVER + OVER DO KEY DUP 0E +ORIGIN ( BS ) @ = + 4 IF DROP 08 OVER I = DUP R> 2 - + >R - + 5 ELSE ( NOT BS ) DUP 0D = + 6 IF ( RET ) LEAVE DROP BL 0 ELSE DUP ENDIF + 7 I C! 0 I 1+ ! + 8 ENDIF EMIT LOOP DROP ; + 9 : QUERY TIB @ 50 EXPECT 0 IN ! ; + 10 8081 HERE + 11 : X BLK @ ( END-OF-TEXT IS NULL *) + 12 IF ( DISC ) 1 BLK +! 0 IN ! BLK @ 7 AND 0= + 13 IF ( SCR END ) ?EXEC R> DROP ENDIF ( disc dependent ) + 14 ELSE ( TERMINAL ) R> DROP + 15 ENDIF ; ! IMMEDIATE --> + + +SCR # 46 + 0 ( FILL, ERASE, BLANKS, HOLD, PAD WFR-79APR02 ) + 1 : FILL ( FILL MEMORY BEGIN-3, QUAN-2, BYTE-1 *) + 2 SWAP >R OVER C! DUP 1+ R> 1 - CMOVE ; + 3 + 4 : ERASE ( FILL MEMORY WITH ZEROS BEGIN-2, QUAN-1 *) + 5 0 FILL ; + 6 + 7 : BLANKS ( FILL WITH BLANKS BEGIN-2, QUAN-1 *) + 8 BL FILL ; + 9 + 10 : HOLD ( HOLD CHARACTER IN PAD *) + 11 -1 HLD +! HLD @ C! ; + 12 + 13 : PAD HERE 44 + ; ( PAD IS 68 BYTES ABOVE HERE *) + 14 ( DOWNWARD HAS NUMERIC OUTPUTS; UPWARD MAY HOLD TEXT *) + 15 --> + + +SCR # 47 + 0 ( WORD, WFR-79APR02 ) + 1 : WORD ( ENTER WITH DELIMITER, MOVE STRING TO 'HERE' *) + 2 BLK @ IF BLK @ BLOCK ELSE TIB @ ENDIF + 3 IN @ + SWAP ( ADDRESS-2, DELIMITER-1 ) + 4 ENCLOSE ( ADDRESS-4, START-3, END-2, TOTAL COUNT-1 ) + 5 HERE 22 BLANKS ( PREPARE FIELD OF 34 BLANKS ) + 6 IN +! ( STEP OVER THIS STRING ) + 7 OVER - >R ( SAVE CHAR COUNT ) + 8 R HERE C! ( LENGTH STORED FIRST ) + 9 + HERE 1+ + 10 R> CMOVE ; ( MOVE STRING FROM BUFFER TO HERE+1 ) + 11 + 12 + 13 + 14 + 15 --> + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 48 + 0 ( (NUMBER-, NUMBER, -FIND, WFR-79APR29 ) + 1 : (NUMBER) ( CONVERT DOUBLE NUMBER, LEAVING UNCONV. ADDR. *) + 2 BEGIN 1+ DUP >R C@ BASE @ DIGIT + 3 WHILE SWAP BASE @ U* DROP ROT BASE @ U* D+ + 4 DPL @ 1+ IF 1 DPL +! ENDIF R> REPEAT R> ; + 5 + 6 : NUMBER ( ENTER W/ STRING ADDR. LEAVE DOUBLE NUMBER *) + 7 0 0 ROT DUP 1+ C@ 2D = DUP >R + -1 + 8 BEGIN DPL ! (NUMBER) DUP C@ BL - + 9 WHILE DUP C@ 2E - 0 ?ERROR 0 REPEAT + 10 DROP R> IF DMINUS ENDIF ; + 11 + 12 : -FIND ( RETURN PFA-3, LEN BYTE-2, TRUE-1; ELSE FALSE *) + 13 BL WORD HERE CONTEXT @ @ (FIND) + 14 DUP 0= IF DROP HERE LATEST (FIND) ENDIF ; + 15 --> + + +SCR # 49 + 0 ( ERROR HANDLER WFR-79APR20 ) + 1 + 2 : (ABORT) ABORT ; ( USER ALTERABLE ERROR ABORT *) + 3 + 4 : ERROR ( WARNING: -1=ABORT, 0=NO DISC, 1=DISC *) + 5 WARNING @ 0< ( PRINT TEXT LINE REL TO SCR #4 *) + 6 IF (ABORT) ENDIF HERE COUNT TYPE ." ? " + 7 MESSAGE SP! IN @ BLK @ QUIT ; + 8 + 9 : ID. ( PRINT NAME FIELD FROM ITS HEADER ADDRESS *) + 10 PAD 020 5F FILL DUP PFA LFA OVER - + 11 PAD SWAP CMOVE PAD COUNT 01F AND TYPE SPACE ; + 12 --> + 13 + 14 + 15 + + +SCR # 50 + 0 ( CREATE WFR-79APR28 ) + 1 + 2 : CREATE ( A SMUDGED CODE HEADER TO PARAM FIELD *) + 3 ( WARNING IF DUPLICATING A CURRENT NAME *) + 4 TIB HERE 0A0 + < 2 ?ERROR ( 6502 only ) + 5 -FIND ( CHECK IF UNIQUE IN CURRENT AND CONTEXT ) + 6 IF ( WARN USER ) DROP NFA ID. + 7 4 MESSAGE SPACE ENDIF + 8 HERE DUP C@ WIDTH @ MIN 1+ ALLOT + 9 DP C@ 0FD = ALLOT ( 6502 only ) + 10 DUP A0 TOGGLE HERE 1 - 80 TOGGLE ( DELIMIT BITS ) + 11 LATEST , CURRENT @ ! + 12 HERE 2+ , ; + 13 --> + 14 + 15 + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 51 + 0 ( LITERAL, DLITERAL, [COMPILE], ?STACK WFR-79APR29 ) + 1 + 2 : [COMPILE] ( FORCE COMPILATION OF AN IMMEDIATE WORD *) + 3 -FIND 0= 0 ?ERROR DROP CFA , ; IMMEDIATE + 4 + 5 : LITERAL ( IF COMPILING, CREATE LITERAL *) + 6 STATE @ IF COMPILE LIT , ENDIF ; IMMEDIATE + 7 + 8 : DLITERAL ( IF COMPILING, CREATE DOUBLE LITERAL *) + 9 STATE @ IF SWAP [COMPILE] LITERAL + 10 [COMPILE] LITERAL ENDIF ; IMMEDIATE + 11 + 12 ( FOLLOWING DEFINITION IS INSTALLATION DEPENDENT ) + 13 : ?STACK ( QUESTION UPON OVER OR UNDERFLOW OF STACK *) + 14 09E SP@ < 1 ?ERROR SP@ 020 < 7 ?ERROR ; + 15 --> + + +SCR # 52 + 0 ( INTERPRET, WFR-79APR18 ) + 1 + 2 : INTERPRET ( INTERPRET OR COMPILE SOURCE TEXT INPUT WORDS *) + 3 BEGIN -FIND + 4 IF ( FOUND ) STATE @ < + 5 IF CFA , ELSE CFA EXECUTE ENDIF ?STACK + 6 ELSE HERE NUMBER DPL @ 1+ + 7 IF [COMPILE] DLITERAL + 8 ELSE DROP [COMPILE] LITERAL ENDIF ?STACK + 9 ENDIF AGAIN ; + 10 --> + 11 + 12 + 13 + 14 + 15 + + +SCR # 53 + 0 ( IMMEDIATE, VOCAB, DEFIN, FORTH, ( DJK-WFR-79APR29 ) + 1 : IMMEDIATE ( TOGGLE PREC. BIT OF LATEST CURRENT WORD *) + 2 LATEST 40 TOGGLE ; + 3 + 4 : VOCABULARY ( CREATE VOCAB WITH 'V-HEAD' AT VOC INTERSECT. *) + 5 2+ CONTEXT ! ; + 8 + 9 VOCABULARY FORTH IMMEDIATE ( THE TRUNK VOCABULARY *) + 10 + 11 : DEFINITIONS ( SET THE CONTEXT ALSO AS CURRENT VOCAB *) + 12 CONTEXT @ CURRENT ! ; + 13 + 14 : ( ( SKIP INPUT TEXT UNTIL RIGHT PARENTHESIS *) + 15 29 WORD ; IMMEDIATE --> + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 54 + 0 ( QUIT, ABORT WFR-79MAR30 ) + 1 + 2 : QUIT ( RESTART, INTERPRET FROM TERMINAL *) + 3 0 BLK ! [COMPILE] [ + 4 BEGIN RP! CR QUERY INTERPRET + 5 STATE @ 0= IF ." OK" ENDIF AGAIN ; + 6 + 7 : ABORT ( WARM RESTART, INCLUDING REGISTERS *) + 8 SP! DECIMAL DR0 + 9 CR ." FORTH-65 V 4.0" + 10 [COMPILE] FORTH DEFINITIONS QUIT ; + 11 + 12 + 13 --> + 14 + 15 + + +SCR # 55 + 0 ( COLD START WFR-79APR29 ) + 1 CODE COLD ( COLD START, INITIALIZING USER AREA *) + 2 HERE 02 +ORIGIN ! ( POINT COLD ENTRY TO HERE ) + 3 0C +ORIGIN LDA, 'T FORTH 4 + STA, ( FORTH VOCAB. ) + 4 0D +ORIGIN LDA, 'T FORTH 5 + STA, + 5 15 # LDY, ( INDEX TO VOC-LINK ) 0= IF, ( FORCED ) + 6 HERE 06 +ORIGIN ! ( POINT RE-ENTRY TO HERE ) + 7 0F # LDY, ( INDEX TO WARNING ) THEN, ( FROM IF, ) + 8 10 +ORIGIN LDA, UP STA, ( LOAD UP ) + 9 11 +ORIGIN LDA, UP 1+ STA, + 10 BEGIN, 0C +ORIGIN ,Y LDA, ( FROM LITERAL AREA ) + 11 UP )Y STA, ( TO USER AREA ) + 12 DEY, 0< END, + 13 'T ABORT 100 /MOD # LDA, IP 1+ STA, + 14 # LDA, IP STA, + 15 6C # LDA, W 1 - STA, 'T RP! JMP, ( RUN ) --> + + +SCR # 56 + 0 ( MATH UTILITY DJK-WFR-79APR29 ) + 1 CODE S->D ( EXTEND SINGLE INTEGER TO DOUBLE *) + 2 BOT 1+ LDA, 0< IF, DEY, THEN, TYA, PHA, PUSH JMP, + 3 + 4 : +- 0< IF MINUS ENDIF ; ( APPLY SIGN TO NUMBER BENEATH *) + 5 + 6 : D+- ( APPLY SIGN TO DOUBLE NUMBER BENEATH *) + 7 0< IF DMINUS ENDIF ; + 8 + 9 : ABS DUP +- ; ( LEAVE ABSOLUTE VALUE *) + 10 : DABS DUP D+- ; ( DOUBLE INTEGER ABSOLUTE VALUE *) + 11 + 12 : MIN ( LEAVE SMALLER OF TWO NUMBERS *) + 13 OVER OVER > IF SWAP ENDIF DROP ; + 14 : MAX ( LEAVE LARGER OF TWO NUMBERS *) + 15 OVER OVER < IF SWAP ENDIF DROP ; --> + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 57 + 0 ( MATH PACKAGE DJK-WFR-79APR29 ) + 1 : M* ( LEAVE SIGNED DOUBLE PRODUCT OF TWO SINGLE NUMBERS *) + 2 OVER OVER XOR >R ABS SWAP ABS U* R> D+- ; + 3 : M/ ( FROM SIGNED DOUBLE-3-2, SIGNED DIVISOR-1 *) + 4 ( LEAVE SIGNED REMAINDER-2, SIGNED QUOTIENT-1 *) + 5 OVER >R >R DABS R ABS U/ + 6 R> R XOR +- SWAP R> +- SWAP ; + 7 : * U* DROP ; ( SIGNED PRODUCT *) + 8 : /MOD >R S->D R> M/ ; ( LEAVE REM-2, QUOT-1 *) + 9 : / /MOD SWAP DROP ; ( LEAVE QUOTIENT *) + 10 : MOD /MOD DROP ; ( LEAVE REMAINDER *) + 11 : */MOD ( TAKE RATION OF THREE NUMBERS, LEAVING *) + 12 >R M* R> M/ ; ( REM-2, QUOTIENT-1 *) + 13 : */ */MOD SWAP DROP ; ( LEAVE RATIO OF THREE NUMBS *) + 14 : M/MOD ( DOUBLE, SINGLE DIVISOR ... REMAINDER, DOUBLE *) + 15 >R 0 R U/ R> SWAP >R U/ R> ; --> + + +SCR # 58 + 0 ( DISC UTILITY, GENERAL USE WFR-79APR02 ) + 1 FIRST VARIABLE USE ( NEXT BUFFER TO USE, STALEST *) + 2 FIRST VARIABLE PREV ( MOST RECENTLY REFERENCED BUFFER *) + 3 + 4 : +BUF ( ADVANCE ADDRESS-1 TO NEXT BUFFER. RETURNS FALSE *) + 5 84 ( I.E. B/BUF+4 ) + DUP LIMIT = ( IF AT PREV *) + 6 IF DROP FIRST ENDIF DUP PREV @ - ; + 7 + 8 : UPDATE ( MARK THE BUFFER POINTED TO BY PREV AS ALTERED *) + 9 PREV @ @ 8000 OR PREV @ ! ; + 10 + 11 : EMPTY-BUFFERS ( CLEAR BLOCK BUFFERS; DON'T WRITE TO DISC *) + 12 FIRST LIMIT OVER - ERASE ; + 13 + 14 : DR0 0 OFFSET ! ; ( SELECT DRIVE #0 *) + 15 : DR1 07D0 OFFSET ! ; --> ( SELECT DRIVE #1 *) + + +SCR # 59 + 0 ( BUFFER WFR-79APR02 ) + 1 : BUFFER ( CONVERT BLOCK# TO STORAGE ADDRESS *) + 2 USE @ DUP >R ( BUFFER ADDRESS TO BE ASSIGNED ) + 3 BEGIN +BUF UNTIL ( AVOID PREV ) USE ! ( FOR NEXT TIME ) + 4 R @ 0< ( TEST FOR UPDATE IN THIS BUFFER ) + 5 IF ( UPDATED, FLUSH TO DISC ) + 6 R 2+ ( STORAGE LOC. ) + 7 R @ 7FFF AND ( ITS BLOCK # ) + 8 0 R/W ( WRITE SECTOR TO DISC ) + 9 ENDIF + 10 R ! ( WRITE NEW BLOCK # INTO THIS BUFFER ) + 11 R PREV ! ( ASSIGN THIS BUFFER AS 'PREV' ) + 12 R> 2+ ( MOVE TO STORAGE LOCATION ) ; + 13 + 14 --> + 15 + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 60 + 0 ( BLOCK WFR-79APR02 ) + 1 : BLOCK ( CONVERT BLOCK NUMBER TO ITS BUFFER ADDRESS *) + 2 OFFSET @ + >R ( RETAIN BLOCK # ON RETURN STACK ) + 3 PREV @ DUP @ R - DUP + ( BLOCK = PREV ? ) + 4 IF ( NOT PREV ) + 5 BEGIN +BUF 0= ( TRUE UPON REACHING 'PREV' ) + 6 IF ( WRAPPED ) DROP R BUFFER + 7 DUP R 1 R/W ( READ SECTOR FROM DISC ) + 8 2 - ( BACKUP ) + 9 ENDIF + 10 DUP @ R - DUP + 0= + 11 UNTIL ( WITH BUFFER ADDRESS ) + 12 DUP PREV ! + 13 ENDIF + 14 R> DROP 2+ ; + 15 --> + + +SCR # 61 + 0 ( TEXT OUTPUT FORMATTING WFR-79MAY03 ) + 1 + 2 : (LINE) ( LINE#, SCR#, ... BUFFER ADDRESS, 64 COUNT *) + 3 >R C/L B/BUF */MOD R> B/SCR * + + 4 BLOCK + C/L ; + 5 + 6 : .LINE ( LINE#, SCR#, ... PRINTED *) + 7 (LINE) -TRAILING TYPE ; + 8 + 9 : MESSAGE ( PRINT LINE RELATIVE TO SCREEN #4 OF DRIVE 0 *) + 10 WARNING @ + 11 IF ( DISC IS AVAILABLE ) + 12 -DUP IF 4 OFFSET @ B/SCR / - .LINE ENDIF + 13 ELSE ." MSG # " . ENDIF ; + 14 --> + 15 + + +SCR # 62 + 0 ( LOAD, --> WFR-79APR02 ) + 1 + 2 : LOAD ( INTERPRET SCREENS FROM DISC *) + 3 BLK @ >R IN @ >R 0 IN ! B/SCR * BLK ! + 4 INTERPRET R> IN ! R> BLK ! ; + 5 + 6 : --> ( CONTINUE INTERPRETATION ON NEXT SCREEN *) + 7 ?LOADING 0 IN ! B/SCR BLK @ OVER + 8 MOD - BLK +! ; IMMEDIATE + 9 + 10 --> + 11 + 12 + 13 + 14 + 15 + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 63 + 0 ( INSTALLATION DEPENDENT TERMINAL I-O, TIM WFR-79APR26 ) + 1 ( EMIT ) ASSEMBLER + 2 HERE -2 BYTE.IN EMIT ! ( VECTOR EMITS' CF TO HERE ) + 3 XSAVE STX, BOT LDA, 7F # AND, 72C6 JSR, XSAVE LDX, + 4 CLC, 1A # LDY, UP )Y LDA, 01 # ADC, UP )Y STA, + 5 INY, UP )Y LDA, 00 # ADC, UP )Y STA, POP JMP, + 6 ( AND INCREMENT 'OUT' ) + 7 ( KEY ) + 8 HERE -2 BYTE.IN KEY ! ( VECTOR KEYS' CF TO HERE ) + 9 XSAVE STX, BEGIN, 8 # LDX, + 10 BEGIN, 6E02 LDA, .A LSR, CS END, 7320 JSR, + 11 BEGIN, 731D JSR, 0 X) CMP, 0 X) CMP, 0 X) CMP, + 12 0 X) CMP, 0 X) CMP, 6E02 LDA, .A LSR, PHP, TYA, + 13 .A LSR, PLP, CS IF, 80 # ORA, THEN, TAY, DEX, + 14 0= END, 731D JSR, FF # EOR, 7F # AND, 0= NOT END, + 15 XSAVE LDX, PUSH0A JMP, --> + + +SCR # 64 + 0 ( INSTALLATION DEPENDENT TERMINAL I-O, TIM WFR-79APR02 ) + 1 + 2 ( ?TERMINAL ) + 3 HERE -2 BYTE.IN ?TERMINAL ! ( VECTOR LIKEWISE ) + 4 1 # LDA, 6E02 BIT, 0= NOT IF, + 5 BEGIN, 731D JSR, 6E02 BIT, 0= END, INY, THEN, + 6 TYA, PUSH0A JMP, + 7 + 8 ( CR ) + 9 HERE -2 BYTE.IN CR ! ( VECTOR CRS' CF TO HERE ) + 10 XSAVE STX, 728A JSR, XSAVE LDX, NEXT JMP, + 11 + 12 --> + 13 + 14 + 15 + + +SCR # 65 + 0 ( INSTALLATION DEPENDENT DISC WFR-79APR02 ) + 1 6900 CONSTANT DATA ( CONTROLLER PORT *) + 2 6901 CONSTANT STATUS ( CONTROLLER PORT *) + 3 + 4 + 5 : #HL ( CONVERT DECIMAL DIGIT FOR DISC CONTROLLER *) + 6 0 0A U/ SWAP 30 + HOLD ; + 7 + 8 --> + 9 + 10 + 11 + 12 + 13 + 14 + 15 + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 66 + 0 ( D/CHAR, ?DISC, WFR-79MAR23 ) + 1 CODE D/CHAR ( TEST CHAR-1. EXIT TEST BOOL-2, NEW CHAR-1 *) + 2 DEX, DEX, BOT 1+ STY, C0 # LDA, + 3 BEGIN, STATUS BIT, 0= NOT END, ( TILL CONTROL READY ) + 4 DATA LDA, BOT STA, ( SAVE CHAR ) + 5 SEC CMP, 0= IF, INY, THEN, SEC STY, NEXT JMP, + 6 + 7 : ?DISC ( UPON NAK SHOW ERR MSG, QUIT. ABSORBS TILL *) + 8 1 D/CHAR >R 0= ( EOT, EXCEPT FOR SOH *) + 9 IF ( NOT SOH ) R 15 = + 10 IF ( NAK ) CR + 11 BEGIN 4 D/CHAR EMIT + 12 UNTIL ( PRINT ERR MSG TIL EOT ) QUIT + 13 ENDIF ( FOR ENQ, ACK ) + 14 BEGIN 4 D/CHAR DROP UNTIL ( AT EOT ) + 15 ENDIF R> DROP ; --> + + +SCR # 67 + 0 ( BLOCK-WRITE WFR-790103 ) + 1 CODE BLOCK-WRITE ( SEND TO DISC FROM ADDRESS-2, COUNT-1 *) + 2 2 # LDA, SETUP JSR, ( WITH EOT AT END *) + 3 BEGIN, 02 # LDA, + 4 BEGIN, STATUS BIT, 0= END, ( TILL IDLE ) + 5 N CPY, 0= + 6 IF, ( DONE ) 04 # LDA, STATUS STA, DATA STA, + 7 NEXT JMP, + 8 THEN, + 9 N 2+ )Y LDA, DATA STA, INY, + 10 0= END, ( FORCED TO BEGIN ) + 11 + 12 --> + 13 + 14 + 15 + + +SCR # 68 + 0 ( BLOCK-READ, WFR-790103 ) + 1 + 2 CODE BLOCK-READ ( BUF.ADDR-1. EXIT AT 128 CHAR OR CONTROL *) + 3 1 # LDA, SETUP JSR, + 4 BEGIN, C0 # LDA, + 5 BEGIN, STATUS BIT, 0= NOT END, ( TILL FLAG ) + 6 50 ( BVC, D6=DATA ) + 7 IF, DATA LDA, N )Y STA, INY, SWAP + 8 0< END, ( LOOP TILL 128 BYTES ) + 9 THEN, ( OR D6=0, SO D7=1, ) + 10 NEXT JMP, + 11 + 12 --> + 13 + 14 + 15 + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 69 + 0 ( R/W FOR PERSCI 1070 CONTROLLER WFR-79MAY03 ) + 1 0A ALLOT HERE ( WORKSPACE TO PREPARE DISC CONTROL TEXT ) + 2 ( IN FORM: C TT SS /D, TT=TRACK, SS=SECTOR, D=DRIVE ) + 3 ( C = 1 TO READ, 0 TO WRITE *) + 4 : R/W ( READ/WRITE DISC BLOCK *) + 5 ( BUFFER ADDRESS-3, BLOCK #-2, 1=READ 0=WRITE *) + 6 LITERAL HLD ! ( JUST AFTER WORKSPACE ) SWAP + 7 0 OVER > OVER 0F9F > OR 6 ?ERROR + 8 07D0 ( 2000 SECT/DR ) /MOD #HL DROP 2F HOLD BL HOLD + 9 1A /MOD SWAP 1+ #HL #HL DROP BL HOLD ( SECTOR 01-26 ) + 10 #HL #HL DROP BL HOLD ( TRACK 00-76 ) + 11 DUP + 12 IF 49 ( 1=READ) ELSE 4F ( 0=WRITE ) ENDIF + 13 HOLD HLD @ 0A BLOCK-WRITE ( SEND TEXT ) ?DISC + 14 IF BLOCK-READ ELSE B/BUF BLOCK-WRITE ENDIF + 15 ?DISC ; --> + + +SCR # 70 + 0 ( FORWARD REFERENCES WFR-79MAR30 ) + 1 00 BYTE.IN : REPLACED.BY ?EXEC + 2 02 BYTE.IN : REPLACED.BY !CSP + 3 04 BYTE.IN : REPLACED.BY CURRENT + 4 08 BYTE.IN : REPLACED.BY CONTEXT + 5 0C BYTE.IN : REPLACED.BY CREATE + 6 0E BYTE.IN : REPLACED.BY ] + 7 10 BYTE.IN : REPLACED.BY (;CODE) + 8 00 BYTE.IN ; REPLACED.BY ?CSP + 9 02 BYTE.IN ; REPLACED.BY COMPILE + 10 06 BYTE.IN ; REPLACED.BY SMUDGE + 11 08 BYTE.IN ; REPLACED.BY [ + 12 00 BYTE.IN CONSTANT REPLACED.BY CREATE + 13 02 BYTE.IN CONSTANT REPLACED.BY SMUDGE + 14 04 BYTE.IN CONSTANT REPLACED.BY , + 15 06 BYTE.IN CONSTANT REPLACED.BY (;CODE) --> + + +SCR # 71 + 0 ( FORWARD REFERENCES WFR-79APR29 ) + 1 02 BYTE.IN VARIABLE REPLACED.BY (;CODE) + 2 02 BYTE.IN USER REPLACED.BY (;CODE) + 3 06 BYTE.IN ?ERROR REPLACED.BY ERROR + 4 0F BYTE.IN ." REPLACED.BY WORD + 5 1D BYTE.IN ." REPLACED.BY WORD + 6 00 BYTE.IN (ABORT) REPLACED.BY ABORT + 7 19 BYTE.IN ERROR REPLACED.BY MESSAGE + 8 25 BYTE.IN ERROR REPLACED.BY QUIT + 9 0C BYTE.IN WORD REPLACED.BY BLOCK + 10 1E BYTE.IN CREATE REPLACED.BY MESSAGE + 11 2C BYTE.IN CREATE REPLACED.BY MIN + 12 04 BYTE.IN ABORT REPLACED.BY DR0 + 13 2C BYTE.IN BUFFER REPLACED.BY R/W + 14 30 BYTE.IN BLOCK REPLACED.BY R/W DECIMAL ;S + 15 + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 72 + 0 ( ', FORGET, DJK-WFR-79DEC02 ) + 1 : ' ( FIND NEXT WORDS PFA; COMPILE IT, IF COMPILING *) + 2 -FIND 0= 0 ?ERROR DROP [COMPILE] LITERAL ; + 3 IMMEDIATE + 4 HEX + 5 : FORGET ( Dave Kilbridge's Smart Forget ) + 6 [COMPILE] ' NFA DUP FENCE @ U< 15 ?ERROR + 7 >R VOC-LINK @ ( start with latest vocabulary ) + 8 BEGIN R OVER U< WHILE [COMPILE] FORTH DEFINITIONS + 9 @ DUP VOC-LINK ! REPEAT ( unlink from voc list ) + 10 BEGIN DUP 4 - ( start with phantom nfa ) + 11 BEGIN PFA LFA @ DUP R U< UNTIL + 12 OVER 2 - ! @ -DUP 0= UNTIL ( end of list ? ) + 13 R> DP ! ; --> + 14 + 15 + +SCR # 72 + 0 ( ', FORGET, \ WFR-79APR28 ) + 1 HEX 3 WIDTH + 2 : ' ( FIND NEXT WORDS PFA; COMPILE IT, IF COMPILING *) + 3 -FIND 0= 0 ?ERROR DROP [COMPILE] LITERAL ; + 4 IMMEDIATE + 5 + 6 : FORGET ( FOLLOWING WORD FROM CURRENT VOCABULARY *) + 7 CURRENT @ CONTEXT @ - 18 ?ERROR + 8 [COMPILE] ' DUP FENCE @ < 15 ?ERROR + 9 DUP NFA DP ! LFA @ CURRENT @ ! ; + 10 + 11 + 12 + 13 --> + 14 + 15 + + +SCR # 73 + 0 ( CONDITIONAL COMPILER, PER SHIRA WFR-79APR01 ) + 1 : BACK HERE - , ; ( RESOLVE BACKWARD BRANCH *) + 2 + 3 : BEGIN ?COMP HERE 1 ; IMMEDIATE + 4 + 5 : ENDIF ?COMP 2 ?PAIRS HERE OVER - SWAP ! ; IMMEDIATE + 6 + 7 : THEN [COMPILE] ENDIF ; IMMEDIATE + 8 + 9 : DO COMPILE (DO) HERE 3 ; IMMEDIATE + 10 + 11 : LOOP 3 ?PAIRS COMPILE (LOOP) BACK ; IMMEDIATE + 12 + 13 : +LOOP 3 ?PAIRS COMPILE (+LOOP) BACK ; IMMEDIATE + 14 + 15 : UNTIL 1 ?PAIRS COMPILE 0BRANCH BACK ; IMMEDIATE --> + + +SCR # 74 + 0 ( CONDITIONAL COMPILER WFR-79APR01 ) + 1 : END [COMPILE] UNTIL ; IMMEDIATE + 2 + 3 : AGAIN 1 ?PAIRS COMPILE BRANCH BACK ; IMMEDIATE + 4 + 5 : REPEAT >R >R [COMPILE] AGAIN + 6 R> R> 2 - [COMPILE] ENDIF ; IMMEDIATE + 7 + 8 : IF COMPILE 0BRANCH HERE 0 , 2 ; IMMEDIATE + 9 + 10 : ELSE 2 ?PAIRS COMPILE BRANCH HERE 0 , + 11 SWAP 2 [COMPILE] ENDIF 2 ; IMMEDIATE + 12 + 13 : WHILE [COMPILE] IF 2+ ; IMMEDIATE + 14 + 15 --> + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 75 + 0 ( NUMERIC PRIMITIVES WFR-79APR01 ) + 1 : SPACES 0 MAX -DUP IF 0 DO SPACE LOOP ENDIF ; + 2 + 3 : <# PAD HLD ! ; + 4 + 5 : #> DROP DROP HLD @ PAD OVER - ; + 6 + 7 : SIGN ROT 0< IF 2D HOLD ENDIF ; + 8 + 9 : # ( CONVERT ONE DIGIT, HOLDING IN PAD * ) + 10 BASE @ M/MOD ROT 9 OVER < IF 7 + ENDIF 30 + HOLD ; + 11 + 12 : #S BEGIN # OVER OVER OR 0= UNTIL ; + 13 --> + 14 + 15 + + +SCR # 76 + 0 ( OUTPUT OPERATORS WFR-79APR20 ) + 1 : D.R ( DOUBLE INTEGER OUTPUT, RIGHT ALIGNED IN FIELD *) + 2 >R SWAP OVER DABS <# #S SIGN #> + 3 R> OVER - SPACES TYPE ; + 4 + 5 : D. 0 D.R SPACE ; ( DOUBLE INTEGER OUTPUT *) + 6 + 7 : .R >R S->D R> D.R ; ( ALIGNED SINGLE INTEGER *) + 8 + 9 : . S->D D. ; ( SINGLE INTEGER OUTPUT *) + 10 + 11 : ? @ . ; ( PRINT CONTENTS OF MEMORY *) + 12 + 13 . CFA MESSAGE 2A + ! ( PRINT MESSAGE NUMBER ) + 14 --> + 15 + + +SCR # 77 + 0 ( PROGRAM DOCUMENTATION WFR-79APR20 ) + 1 HEX + 2 : LIST ( LIST SCREEN BY NUMBER ON STACK *) + 3 DECIMAL CR DUP SCR ! + 4 ." SCR # " . 10 0 DO CR I 3 .R SPACE + 5 I SCR @ .LINE LOOP CR ; + 6 + 7 : INDEX ( PRINT FIRST LINE OF EACH SCREEN FROM-2, TO-1 *) + 8 0C EMIT ( FORM FEED ) CR 1+ SWAP + 9 DO CR I 3 .R SPACE + 10 0 I .LINE + 11 ?TERMINAL IF LEAVE ENDIF LOOP ; + 12 : TRIAD ( PRINT 3 SCREENS ON PAGE, CONTAINING # ON STACK *) + 13 0C EMIT ( FF ) 3 / 3 * 3 OVER + SWAP + 14 DO CR I LIST LOOP CR + 15 0F MESSAGE CR ; DECIMAL --> + +FORTH INTEREST GROUP MAY 1, 1979 + +SCR # 78 + 0 ( TOOLS WFR-79APR20 ) + 1 HEX + 2 : VLIST ( LIST CONTEXT VOCABULARY *) + 3 80 OUT ! CONTEXT @ @ + 4 BEGIN OUT @ C/L > IF CR 0 OUT ! ENDIF + 5 DUP ID. SPACE SPACE PFA LFA @ + 6 DUP 0= ?TERMINAL OR UNTIL DROP ; + 7 --> + 8 + 9 + 10 + 11 + 12 + 13 + 14 + 15 + + +SCR # 79 + 0 ( TOOLS WFR-79MAY03 ) + 1 HEX + 2 + 3 CREATE MON ( CALL MONITOR, SAVING RE-ENTRY TO FORTH *) + 4 0 C, 4C C, ' LIT 18 + , SMUDGE + 5 + 6 + 7 + 8 + 9 + 10 DECIMAL + 11 HERE FENCE ! + 12 HERE 28 +ORIGIN ! ( COLD START FENCE ) + 13 HERE 30 +ORIGIN ! ( COLD START DP ) + 14 LATEST 12 +ORIGIN ! ( TOPMOST WORD ) + 15 ' FORTH 6 + 32 +ORIGIN ! ( COLD VOC-LINK ) ;S + + +SCR # 80 + 0 --> + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 11 + 12 + 13 + 14 + 15 + +FORTH INTEREST GROUP MAY 1, 1979