1469 lines
50 KiB
Forth
1469 lines
50 KiB
Forth
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 ( <BUILD, DOES> WFR-79MAR20 )
|
|
1
|
|
2 : <BUILDS 0 CONSTANT ; ( CREATE HEADER FOR 'DOES>' 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 <BUILDS A081 , CURRENT @ CFA ,
|
|
6 HERE VOC-LINK @ , VOC-LINK !
|
|
7 DOES> 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
|