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 # 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