FigForth 1.1#
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 0 00 ****** fig-FORTH MODEL ****** 01 02 Through the courtesy of 03 04 05 FORTH INTEREST GROUP 06 P. O. BOX 1105 07 SAN CARLOS, CA. 94070 08 09 Implemented on the 0A ATARI 800/400 0B by 0C Steve Calfee 0D 1/26/81 0E 0F Copywrite 1981 10 11 RELEASE 1 12 WITH COMPILER SECURITY 13 AND 14 VARIABLE LENGTH NAMES 15 16 17 18 19 Further distribution must 1A include the above notice. 1B 1C 1D 1E 1F ****** fig-FORTH MODEL ****** Through the courtesy of FORTH INTEREST GROUP P. O. BOX 1105 SAN CARLOS, CA. 94070 Implemented on the ATARI 800/400 by Steve Calfee 1/26/81 Copywrite 1981 RELEASE 1 WITH COMPILER SECURITY AND VARIABLE LENGTH NAMES Further distribution must include the above notice. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 1 00 ****** fig-FORTH MODEL ****** 01 02 Through the courtesy of 03 04 05 FORTH INTEREST GROUP 06 P. O. BOX 1105 07 SAN CARLOS, CA. 94070 08 09 Implemented on the 0A ATARI 800/400 0B by 0C Steve Calfee 0D 1/26/81 0E 0F Copywrite 1981 10 11 RELEASE 1 12 WITH COMPILER SECURITY 13 AND 14 VARIABLE LENGTH NAMES 15 16 17 18 19 Further distribution must 1A include the above notice. 1B 1C 1D 1E 1F ****** fig-FORTH MODEL ****** Through the courtesy of FORTH INTEREST GROUP P. O. BOX 1105 SAN CARLOS, CA. 94070 Implemented on the ATARI 800/400 by Steve Calfee 1/26/81 Copywrite 1981 RELEASE 1 WITH COMPILER SECURITY AND VARIABLE LENGTH NAMES Further distribution must include the above notice. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 2 00 BREAK Abort. 01 02 IOCB already open. 03 04 Non-existant device. 05 06 IOCB is write-only. 07 08 Invalid command (for this device 09 ) 0A Device or file not open. 0B 0C Bad IOCB # 0D 0E IOCB is read-only 0F 10 End Of File 11 12 Truncated Record 13 14 Device Timeout 15 16 Device NAK (Negative AcKnowledge 17 ) 18 Serial Bus input framing error 19 1A Cursor out of range 1B 1C Serial Bus data-frame overrun 1D 1E Serial Bus data-frame checksum e 1F rror. BREAK Abort. IOCB already open. Non-existant device. IOCB is write-only. Invalid command (for this device) Device or file not open. Bad IOCB # IOCB is read-only End Of File Truncated Record Device Timeout Device NAK (Negative AcKnowledge) Serial Bus input framing error Cursor out of range Serial Bus data-frame overrun Serial Bus data-frame checksum error. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 3 00 Device-done error 01 02 Read-after-write compare error 03 04 Function not implemented in hand 05 ler 06 Insufficient RAM 07 08 09 0A 0B 0C 0D 0E 0F 10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F Device-done error Read-after-write compare error Function not implemented in handler Insufficient RAM * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 4 00 ( ERROR MESSAGES ) 135 159 01 9 8 7 10 ;S 02 empty stack 03 04 dictionary full 05 06 has incorrect address mode 07 08 isn't unique 09 0A 0B 0C disc range ?? 0D 0E full stack ! 0F 10 disc error ! 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F ( ERROR MESSAGES ) 135 159 9 8 7 10 ;S empty stack dictionary full has incorrect address mode isn't unique disc range ?? full stack ! disc error ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 5 00 ( ERROR MESSAGES ) 01 02 compilation only, use in definit 03 ion 04 execution only 05 06 conditionals not paired 07 08 definition not finished 09 0A in protected dictionary 0B 0C use only when loading 0D 0E off current editing screen 0F 10 declare vocabulary 11 12 outside allocated file space 13 14 writing off current line 15 16 17 18 19 1A string stack empty !! 1B 1C 1D 1E 1F ( ERROR MESSAGES ) compilation only, use in definition execution only conditionals not paired definition not finished in protected dictionary use only when loading off current editing screen declare vocabulary outside allocated file space writing off current line string stack empty !! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 6 00 ( TARGET COMPILER ERROR MESSAGE 01 S WFR-79JUN02 ) 02 03 04 below lower bound of virtual mem 05 ory 06 disc compiler assembly error in 07 mode of 08 can't find in TARGET 09 0A target redef. 0B 0C T: error, is it paired with T; 0D ? 0E above virtual memory bounds 0F 10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F ( TARGET COMPILER ERROR MESSAGES WFR-79JUN02 ) below lower bound of virtual memory disc compiler assembly error in mode of can't find in TARGET target redef. T: error, is it paired with T; ? above virtual memory bounds * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 7 00 ( <UNUSED> ) ;S 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F 10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F ( <UNUSED> ) ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 8 00 ( <UNUSED> ) ;S 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F 10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F ( <UNUSED> ) ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 9 00 ( compile assembler 01 and editor SRC 7/6/80 ) 02 BASE @ ( PRESERVE THE RADIX ) 03 04 DECIMAL 31 WIDTH ! 05 06 13 LOAD ( ASSEMBLER ) 07 08 HEX 1E LOAD ( DECUS FORTH ADDS) 09 0A HEX 15 LOAD ( EDITOR ) 0B 0C FORTH DEFINITIONS 0D 0E 25 CONSTANT LPWORDS 0F 10 27 CONSTANT FORMY 11 : SAVENFAs ( MOVE FORTH NFAS TO 12 ORIGIN AREA ) #LINKS 0 DO 13 ' FORTH 4 + I 4 * + @ 14 22 I 2* + +ORIGIN ! LOOP ; 15 DECIMAL 16 HERE 28 +ORIGIN ! ( FENCE ) 17 18 HERE 30 +ORIGIN ! ( DP ) 19 1A HERE FENCE ! 1B 1 WARNING ! ( DISK WARNINGS ) 1C SAVENFAs : TASK ; 1D BASE ! 1E ;S 1F ( compile assembler and editor SRC 7/6/80 ) BASE @ ( PRESERVE THE RADIX ) DECIMAL 31 WIDTH ! 13 LOAD ( ASSEMBLER ) HEX 1E LOAD ( DECUS FORTH ADDS) HEX 15 LOAD ( EDITOR ) FORTH DEFINITIONS 25 CONSTANT LPWORDS 27 CONSTANT FORMY : SAVENFAs ( MOVE FORTH NFAS TO ORIGIN AREA ) #LINKS 0 DO ' FORTH 4 + I 4 * + @ 22 I 2* + +ORIGIN ! LOOP ; DECIMAL HERE 28 +ORIGIN ! ( FENCE ) HERE 30 +ORIGIN ! ( DP ) HERE FENCE ! 1 WARNING ! ( DISK WARNINGS ) SAVENFAs : TASK ; BASE ! ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # A 00 ( <UNUSED> ) ;S 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F 10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F ( <UNUSED> ) ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # B 00 ( CLONING WORDS 7/21/80-SRC ) 01 HEX FORTH DEFINITIONS 02 : COPYDISK DR0 4E 0 DO I I 0800 03 + EDITOR COPY FORTH LOOP ; 04 : CLONE DR0 0 PHYSOFF ! 05 4E B + 0 DO I I 0800 + 06 EDITOR COPY FORTH LOOP DR0 ; 07 : 1.2TO1.3 DR0 8 OFFSET ! 4E 0 08 DO I I 0803 + EDITOR COPY 09 FORTH LOOP DR0 ; 0A : 1.3TO1.4 DR0 B PHYSOFF ! 4E 0 0B DO I I 0801 + COPY LOOP DR0 ; 0C 0D : OBJ DR0 0 PHYSOFF ! 0E C 0 DO I I 0800 + EDITOR 0F COPY FORTH LOOP DR0 ; 10 CR 11 ." INSERT SRCE DISK IN DRIVE 1 12 " CR 13 ." INSERT DEST DISK IN DRIVE 2" 14 CR 15 ." TYPE CLONE TO COPY ALL OF IT 16 " CR ." INCLUDING BOOT PROGRAM" 17 CR ." TYPE COPYDISK TO COPY" 18 CR ." SCREENS 0 TO 4E" 19 CR ." TYPE OBJ TO COPY JUST" 1A CR ." THE BOOTSTRAP B BLOCKS" 1B CR ." TYPE 1.2TO1.3 TO COPY " 1C CR ." OR TYPE 1.3TO1.4 TO COPY" 1D CR ." YOUR OLD DISK SOURCES " 1E CR ." TO THE NEW VERSION " 1F CR ;S ( CLONING WORDS 7/21/80-SRC ) HEX FORTH DEFINITIONS : COPYDISK DR0 4E 0 DO I I 0800 + EDITOR COPY FORTH LOOP ; : CLONE DR0 0 PHYSOFF ! 4E B + 0 DO I I 0800 + EDITOR COPY FORTH LOOP DR0 ; : 1.2TO1.3 DR0 8 OFFSET ! 4E 0 DO I I 0803 + EDITOR COPY FORTH LOOP DR0 ; : 1.3TO1.4 DR0 B PHYSOFF ! 4E 0 DO I I 0801 + COPY LOOP DR0 ; : OBJ DR0 0 PHYSOFF ! C 0 DO I I 0800 + EDITOR COPY FORTH LOOP DR0 ; CR ." INSERT SRCE DISK IN DRIVE 1 " CR ." INSERT DEST DISK IN DRIVE 2" CR ." TYPE CLONE TO COPY ALL OF IT" CR ." INCLUDING BOOT PROGRAM" CR ." TYPE COPYDISK TO COPY" CR ." SCREENS 0 TO 4E" CR ." TYPE OBJ TO COPY JUST" CR ." THE BOOTSTRAP B BLOCKS" CR ." TYPE 1.2TO1.3 TO COPY " CR ." OR TYPE 1.3TO1.4 TO COPY" CR ." YOUR OLD DISK SOURCES " CR ." TO THE NEW VERSION " CR ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # C 00 ( <UNUSED> ) ;S 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F 10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F ( <UNUSED> ) ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # D 00 ( FORTH-65 ASSEMBLER 01 WFR-79JUN03 ) 02 HEX 03 04 VOCABULARY ASSEMBLER IMMEDIATE 05 ASSEMBLER DEFINITIONS 06 07 08 ( LOCATE EXISTING REGISTERS ) 09 0A FF CONSTANT XSAVE 0FB CONS 0B TANT W 0FD CONSTANT UP 0C F8 CONSTANT IP F0 CO 0D NSTANT N 0E 0F 10 ( LOCATE EXISTING CODE PROCEEDU 11 RES ) 12 ' (DO) 0E + CONSTANT POP 13 ( FROM COMPUTATION STACK *) 14 ' (DO) 0C + CONSTANT POPT 15 WO 16 ' LIT 13 + CONSTANT PUT 17 18 ' LIT 11 + CONSTANT PUSH 19 1A ' LIT 18 + CONSTANT NEXT 1B 1C ' EXECUTE NFA 11 - CONSTANT 1D SETUP 1E --> 1F ( FORTH-65 ASSEMBLER WFR-79JUN03 ) HEX VOCABULARY ASSEMBLER IMMEDIATE ASSEMBLER DEFINITIONS ( LOCATE EXISTING REGISTERS ) FF CONSTANT XSAVE 0FB CONSTANT W 0FD CONSTANT UP F8 CONSTANT IP F0 CONSTANT N ( LOCATE EXISTING CODE PROCEEDURES ) ' (DO) 0E + CONSTANT POP ( FROM COMPUTATION STACK *) ' (DO) 0C + CONSTANT POPTWO ' LIT 13 + CONSTANT PUT ' LIT 11 + CONSTANT PUSH ' LIT 18 + CONSTANT NEXT ' EXECUTE NFA 11 - CONSTANT SETUP --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # E 00 ( ASSEMBLER, CONT. 01 WFR-780CT03 ) 02 0 VARIABLE INDEX -2 AL 03 LOT 04 0909 , 1505 , 0115 , 8011 , 8009 05 , 1D0D , 8019 , 8080 , 06 0080 , 1404 , 8014 , 8080 , 8080 07 , 1C0C , 801C , 2C80 , 08 09 0A 2 VARIABLE MODE 0B 0C : .A 0 MODE ! ; : # 1 MO 0D DE ! ; : MEM 2 MODE ! ; 0E : ,X 3 MODE ! ; : ,Y 4 MO 0F DE ! ; : X) 5 MODE ! ; 10 : )Y 6 MODE ! ; : ) F MO 11 DE ! ; 12 13 14 : BOT ,X 0 ; ( ADD 15 RESS THE BOTTOM OF THE STACK *) 16 : SEC ,X 2 ; ( 17 ADDRESS SECOND ITEM ON STACK *) 18 : RP) ,X 101 ; ( AD 19 DRESS BOTTOM OF RETURN STACK *) 1A --> 1B 1C 1D 1E 1F ( ASSEMBLER, CONT. WFR-780CT03 ) 0 VARIABLE INDEX -2 ALLOT 0909 , 1505 , 0115 , 8011 , 8009 , 1D0D , 8019 , 8080 , 0080 , 1404 , 8014 , 8080 , 8080 , 1C0C , 801C , 2C80 , 2 VARIABLE MODE : .A 0 MODE ! ; : # 1 MODE ! ; : MEM 2 MODE ! ; : ,X 3 MODE ! ; : ,Y 4 MODE ! ; : X) 5 MODE ! ; : )Y 6 MODE ! ; : ) F MODE ! ; : BOT ,X 0 ; ( ADDRESS THE BOTTOM OF THE STACK *) : SEC ,X 2 ; ( ADDRESS SECOND ITEM ON STACK *) : RP) ,X 101 ; ( ADDRESS BOTTOM OF RETURN STACK *) --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # F 00 ( UPMODE, CPU 01 WFR-78OCT23 ) 02 03 04 : UPMODE IF MODE C@ 8 AND 05 0= IF 8 MODE +! ENDIF ENDIF 06 1 MODE C@ 0F AND -DUP IF 07 0 DO DUP + LOOP ENDIF 08 OVER 1+ @ AND 0= ; 09 0A 0B 0C : CPU <BUILDS C, DOES> C@ 0D C, MEM ; 0E 00 CPU BRK, 18 CPU CLC, 0F D8 CPU CLD, 58 CPU CLI, 10 B8 CPU CLV, CA CPU DEX, 11 88 CPU DEY, E8 CPU INX, 12 C8 CPU INY, EA CPU NOP, 13 48 CPU PHA, 08 CPU PHP, 14 68 CPU PLA, 28 CPU PLP, 15 40 CPU RTI, 60 CPU RTS, 16 38 CPU SEC, F8 CPU SED, 17 78 CPU SEI, AA CPU TAX, 18 A8 CPU TAY, BA CPU TSX, 19 8A CPU TXA, 9A CPU TXS, 1A 98 CPU TYA, 1B 1C --> 1D 1E 1F ( UPMODE, CPU WFR-78OCT23 ) : UPMODE IF MODE C@ 8 AND 0= IF 8 MODE +! ENDIF ENDIF 1 MODE C@ 0F AND -DUP IF 0 DO DUP + LOOP ENDIF OVER 1+ @ AND 0= ; : CPU <BUILDS C, DOES> C@ C, MEM ; 00 CPU BRK, 18 CPU CLC, D8 CPU CLD, 58 CPU CLI, B8 CPU CLV, CA CPU DEX, 88 CPU DEY, E8 CPU INX, C8 CPU INY, EA CPU NOP, 48 CPU PHA, 08 CPU PHP, 68 CPU PLA, 28 CPU PLP, 40 CPU RTI, 60 CPU RTS, 38 CPU SEC, F8 CPU SED, 78 CPU SEI, AA CPU TAX, A8 CPU TAY, BA CPU TSX, 8A CPU TXA, 9A CPU TXS, 98 CPU TYA, --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 10 00 ( M/CPU, MULTI-MODE OP-CODES 01 WFR-79MAR26 ) 02 : M/CPU <BUILDS C, , DOES> 03 04 DUP 1+ C@ 80 AND IF 05 10 MODE +! ENDIF OVER 06 FF00 AND UPMODE UPMODE 07 IF MEM CR LATEST ID. 08 3 ERROR ENDIF C@ MODE 09 C@ 0A INDEX + C@ + C, MODE 0B C@ 7 AND IF MODE C@ 0C 0F AND 7 < IF C, EL 0D SE , ENDIF ENDIF MEM ; 0E 0F 10 1C6E 60 M/CPU ADC, 1C6E 20 M 11 /CPU AND, 1C6E C0 M/CPU CMP, 12 1C6E 40 M/CPU EOR, 1C6E A0 M 13 /CPU LDA, 1C6E 00 M/CPU ORA, 14 1C6E E0 M/CPU SBC, 1C6C 80 M 15 /CPU STA, 0D0D 01 M/CPU ASL, 16 0C0C C1 M/CPU DEC, 0C0C E1 M 17 /CPU INC, 0D0D 41 M/CPU LSR, 18 0D0D 21 M/CPU ROL, 0D0D 61 M 19 /CPU ROR, 0414 81 M/CPU STX, 1A 0486 E0 M/CPU CPX, 0486 C0 M 1B /CPU CPY, 1496 A2 M/CPU LDX, 1C 0C8E A0 M/CPU LDY, 048C 80 M 1D /CPU STY, 0480 14 M/CPU JSR, 1E 8480 40 M/CPU JMP, 0484 20 M 1F /CPU BIT, --> ( M/CPU, MULTI-MODE OP-CODES WFR-79MAR26 ) : M/CPU <BUILDS C, , DOES> DUP 1+ C@ 80 AND IF 10 MODE +! ENDIF OVER FF00 AND UPMODE UPMODE IF MEM CR LATEST ID. 3 ERROR ENDIF C@ MODE C@ INDEX + C@ + C, MODE C@ 7 AND IF MODE C@ 0F AND 7 < IF C, ELSE , ENDIF ENDIF MEM ; 1C6E 60 M/CPU ADC, 1C6E 20 M/CPU AND, 1C6E C0 M/CPU CMP, 1C6E 40 M/CPU EOR, 1C6E A0 M/CPU LDA, 1C6E 00 M/CPU ORA, 1C6E E0 M/CPU SBC, 1C6C 80 M/CPU STA, 0D0D 01 M/CPU ASL, 0C0C C1 M/CPU DEC, 0C0C E1 M/CPU INC, 0D0D 41 M/CPU LSR, 0D0D 21 M/CPU ROL, 0D0D 61 M/CPU ROR, 0414 81 M/CPU STX, 0486 E0 M/CPU CPX, 0486 C0 M/CPU CPY, 1496 A2 M/CPU LDX, 0C8E A0 M/CPU LDY, 048C 80 M/CPU STY, 0480 14 M/CPU JSR, 8480 40 M/CPU JMP, 0484 20 M/CPU BIT, --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 11 00 ( ASSEMBLER CONDITIONALS 01 WFR-79MAR26 ) 02 : BEGIN, HERE 1 ; IMMEDIATE 03 : UNTIL, ?EXEC >R 1 ?PAIRS R> 04 C, HERE 1+ - C, ; IMMEDIATE 05 : IF, C, HERE 0 C, 2 ; IMMEDIATE 06 : ENDIF, ?EXEC 2 ?PAIRS HERE 07 OVER C@ 08 IF SWAP ! ELSE OVER 1+ - 09 SWAP C! ENDIF ; IMMEDIATE 0A : ELSE, 2 ?PAIRS HERE 1+ 1 JMP, 0B SWAP HERE OVER 1+ - SWAP C! 2 ; 0C IMMEDIATE 0D : THEN, [COMPILE] ENDIF, ; 0E IMMEDIATE : END, [COMPILE] 0F UNTIL, ; IMMEDIATE 10 : NOT 20 + ; 11 ( REVERSE ASSEMBLY TEST ) 12 90 CONSTANT CS ( ASSEMBLER 13 TEST FOR CARRY SET ) 14 D0 CONSTANT 0= ( ASSEMBLER 15 TEST FOR EQUAL ZERO ) 16 10 CONSTANT 0< ( ASSEMBLER 17 TEST FOR LESS THAN ZERO ) 18 90 CONSTANT >= ( ASSEMBLER 19 TEST FOR GREATER OR EQUAL ZERO ) 1A ( >= IS ONLY CORRECT AFTER SUB, 1B OR CMP, ) 1C 50 CONSTANT VS ( ASSEMBLER 1D TEST FOR OVERFLOW BIT SET ) 1E --> 1F ( ASSEMBLER CONDITIONALS WFR-79MAR26 ) : BEGIN, HERE 1 ; IMMEDIATE : UNTIL, ?EXEC >R 1 ?PAIRS R> C, HERE 1+ - C, ; IMMEDIATE : IF, C, HERE 0 C, 2 ; IMMEDIATE : ENDIF, ?EXEC 2 ?PAIRS HERE OVER C@ IF SWAP ! ELSE OVER 1+ - SWAP C! ENDIF ; IMMEDIATE : ELSE, 2 ?PAIRS HERE 1+ 1 JMP, SWAP HERE OVER 1+ - SWAP C! 2 ; IMMEDIATE : THEN, [COMPILE] ENDIF, ; IMMEDIATE : END, [COMPILE] UNTIL, ; IMMEDIATE : NOT 20 + ; ( REVERSE ASSEMBLY TEST ) 90 CONSTANT CS ( ASSEMBLER TEST FOR CARRY SET ) D0 CONSTANT 0= ( ASSEMBLER TEST FOR EQUAL ZERO ) 10 CONSTANT 0< ( ASSEMBLER TEST FOR LESS THAN ZERO ) 90 CONSTANT >= ( ASSEMBLER TEST FOR GREATER OR EQUAL ZERO ) ( >= IS ONLY CORRECT AFTER SUB, OR CMP, ) 50 CONSTANT VS ( ASSEMBLER TEST FOR OVERFLOW BIT SET ) --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 12 00 ( USE OF ASSEMBLER 01 WFR-79APR28 ) 02 : C; 03 ( END OF CODE DEFINITION *) 04 CURRENT @ CONTEXT ! ?EXEC 05 ?CSP SMUDGE ; IMMEDIATE 06 07 08 FORTH DEFINITIONS 09 0A : CODE ( CREATE WORD AT ASS 0B EMBLY CODE LEVEL *) 0C ?EXEC CREATE [COMPILE] 0D ASSEMBLER 0E ASSEMBLER MEM !CSP ; 0F IMMEDIATE 10 DECIMAL 11 ' ASSEMBLER CFA ' ;CODE 8 12 + ! ( OVER-WRITE SMUDGE ) 13 14 --> 15 16 17 18 19 1A 1B 1C 1D 1E 1F ( USE OF ASSEMBLER WFR-79APR28 ) : C; ( END OF CODE DEFINITION *) CURRENT @ CONTEXT ! ?EXEC ?CSP SMUDGE ; IMMEDIATE FORTH DEFINITIONS : CODE ( CREATE WORD AT ASSEMBLY CODE LEVEL *) ?EXEC CREATE [COMPILE] ASSEMBLER ASSEMBLER MEM !CSP ; IMMEDIATE DECIMAL ' ASSEMBLER CFA ' ;CODE 8 + ! ( OVER-WRITE SMUDGE ) --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 13 00 ( EXEC, routines ) BASE @ HEX 01 ASSEMBLER DEFINITIONS 02 CODE xec IP LDA, W STA, IP 1+ 03 LDA, W 1+ STA, ( save IP ) 04 PLA, CLC, 1 # ADC, IP STA, 05 PLA, 06 0 # ADC, IP 1+ STA, ( get new 07 IP) 08 W 1+ LDA, PHA, W LDA, PHA, 09 ( save last IP ) NEXT JMP, C; 0A CODE xec2 IP LDA, W STA, IP 1+ 0B LDA, W 1+ STA, ( save IP to 0C continue in the code routine ) 0D PLA, IP STA, PLA, IP 1+ STA, 0E ( Restore old IP ) 0F W ) JMP, C; 10 11 : EXEC, ( addr -- ^ EXECUTE 12 COLON WORD IN A CODE DEF ) 13 ( addr = PFA OF COLON WORD ) 14 ' xec JSR, 15 CFA , ' xec2 CFA , ; 16 17 FORTH DEFINITIONS DECIMAL 18 19 HERE 28 +ORIGIN ! ( FENCE ) 1A 1B HERE 30 +ORIGIN ! ( DP ) 1C 1D ' ASSEMBLER 2 + 1E 32 +ORIGIN ! ( VOC-LINK ) 1F HERE FENCE ! BASE ! ;S ( EXEC, routines ) BASE @ HEX ASSEMBLER DEFINITIONS CODE xec IP LDA, W STA, IP 1+ LDA, W 1+ STA, ( save IP ) PLA, CLC, 1 # ADC, IP STA, PLA, 0 # ADC, IP 1+ STA, ( get new IP) W 1+ LDA, PHA, W LDA, PHA, ( save last IP ) NEXT JMP, C; CODE xec2 IP LDA, W STA, IP 1+ LDA, W 1+ STA, ( save IP to continue in the code routine ) PLA, IP STA, PLA, IP 1+ STA, ( Restore old IP ) W ) JMP, C; : EXEC, ( addr -- ^ EXECUTE COLON WORD IN A CODE DEF ) ( addr = PFA OF COLON WORD ) ' xec JSR, CFA , ' xec2 CFA , ; FORTH DEFINITIONS DECIMAL HERE 28 +ORIGIN ! ( FENCE ) HERE 30 +ORIGIN ! ( DP ) ' ASSEMBLER 2 + 32 +ORIGIN ! ( VOC-LINK ) HERE FENCE ! BASE ! ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 14 00 ( LPWORDS FOR JOYSTICK CONTROLLE 01 R JACKS ) 02 CODE STROBE BOT LDA, D301 STA, 03 80 # ORA, D301 STA, 04 POP JMP, C; : PRT D303 C@ FB 05 AND D303 C! FF D301 C! D303 06 C@ 4 OR D303 C! BEGIN D013 C@ 1 07 AND 0= UNTIL 7F AND STROBE ; 08 : LYP1 DUP IF 0 DO DUP I + C@ PR 09 T LOOP DROP 0A ELSE DROP DROP THEN ; 0B : LYPE LYP1 20 PRT ; 0C : CRLP 0D PRT 0A PRT ; : FFLP 0C 0D PRT CRLP ; 0E : .LP S->D SWAP OVER DABS <# #S 0F SIGN #> 10 LYPE ; 11 12 : LISTLP DUP SCR ! CRLP 13 0E PRT ( [ SCREEN ] LYPE ) .LP 14 0F PRT 10 0 DO CRLP I DUP .LP 15 LINE C/L -TRAILING LYPE LOOP 16 CRLP ; : SHOWLP 1+ SWAP 17 DO I LISTLP 3 0 DO CRLP 18 LOOP LOOP ; 19 1A ;S 1B 1C 1D 1E 1F ( LPWORDS FOR JOYSTICK CONTROLLER JACKS ) CODE STROBE BOT LDA, D301 STA, 80 # ORA, D301 STA, POP JMP, C; : PRT D303 C@ FB AND D303 C! FF D301 C! D303 C@ 4 OR D303 C! BEGIN D013 C@ 1 AND 0= UNTIL 7F AND STROBE ; : LYP1 DUP IF 0 DO DUP I + C@ PRT LOOP DROP ELSE DROP DROP THEN ; : LYPE LYP1 20 PRT ; : CRLP 0D PRT 0A PRT ; : FFLP 0C PRT CRLP ; : .LP S->D SWAP OVER DABS <# #S SIGN #> LYPE ; : LISTLP DUP SCR ! CRLP 0E PRT ( [ SCREEN ] LYPE ) .LP 0F PRT 10 0 DO CRLP I DUP .LP LINE C/L -TRAILING LYPE LOOP CRLP ; : SHOWLP 1+ SWAP DO I LISTLP 3 0 DO CRLP LOOP LOOP ; ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 15 00 HEX VOCABULARY EDITOR IMMEDIATE 01 02 1A LOAD 1B LOAD ( GRAPHICS ) 03 04 : EDIT SCR ! [COMPILE] EDITOR ; 05 06 EDITOR DEFINITIONS 07 0 VARIABLE TOPFLAG 08 : ULL DUP TOPFLAG ! 0 GR. 2203 09 LMARGN ! 3 0 POS. ( 32 CHAR ) 0A 1 2FE C! ( PRINT ALL CHARS ) 0B SCR @ BLOCK + 200 TYPE ( PRINT ) 0C 0 2FE C! ( CURSOR CNTRLS ) 0D CR ." DOIT" CR 0AAAA 2B2 ! ; 0E : UL 0 ULL ; ( SHOW UPPER 16 0F LINES ) 10 : LL 200 ULL ; ( SHOW LOWER 16 11 LINES ) 12 : DOIT 10 0 DO -1 2B2 ! 13 14 3 I POS. ( POINT CURSOR ) 15 16 SCR @ BLOCK I 20 * + TOPFLAG @ + 17 18 ICBAL ! 20 ICBLL ! GET DROP 19 1A LOOP UPDATE 0 GR. TOPFLAG @ 0= 1B IF UL ELSE LL ENDIF ; 1C : FLUSH 2602 LMARGN ! 1D [COMPILE] FORTH FLUSH ; 1E --> 1F HEX VOCABULARY EDITOR IMMEDIATE 1A LOAD 1B LOAD ( GRAPHICS ) : EDIT SCR ! [COMPILE] EDITOR ; EDITOR DEFINITIONS 0 VARIABLE TOPFLAG : ULL DUP TOPFLAG ! 0 GR. 2203 LMARGN ! 3 0 POS. ( 32 CHAR ) 1 2FE C! ( PRINT ALL CHARS ) SCR @ BLOCK + 200 TYPE ( PRINT ) 0 2FE C! ( CURSOR CNTRLS ) CR ." DOIT" CR 0AAAA 2B2 ! ; : UL 0 ULL ; ( SHOW UPPER 16 LINES ) : LL 200 ULL ; ( SHOW LOWER 16 LINES ) : DOIT 10 0 DO -1 2B2 ! 3 I POS. ( POINT CURSOR ) SCR @ BLOCK I 20 * + TOPFLAG @ + ICBAL ! 20 ICBLL ! GET DROP LOOP UPDATE 0 GR. TOPFLAG @ 0= IF UL ELSE LL ENDIF ; : FLUSH 2602 LMARGN ! [COMPILE] FORTH FLUSH ; --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 16 00 ( TEXT, LINE, WHERE USED IN 01 EDITOR 7/7/80-SRC ) 02 FORTH DEFINITIONS HEX 03 04 05 06 : TEXT ( ACCEPT 07 FOLLOWING TEXT TO PAD *) 08 HERE C/L 1+ BLANKS WORD 09 HERE PAD C/L 1+ CMOVE ; 0A : #OFLINES B/BUF B/SCR * C/L / ; 0B 0C : LINE ( RELATIVE TO 0D SCR, LEAVE ADDRESS OF LINE *) 0E DUP #OFLINES MINUS 0F AND IF ." NOT ON SCREEN" ABORT 10 ENDIF ( KEEP ON THIS SCREEN ) 11 SCR @ (LINE) DROP ; 12 13 --> 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F ( TEXT, LINE, WHERE USED IN EDITOR 7/7/80-SRC ) FORTH DEFINITIONS HEX : TEXT ( ACCEPT FOLLOWING TEXT TO PAD *) HERE C/L 1+ BLANKS WORD HERE PAD C/L 1+ CMOVE ; : #OFLINES B/BUF B/SCR * C/L / ; : LINE ( RELATIVE TO SCR, LEAVE ADDRESS OF LINE *) DUP #OFLINES MINUS AND IF ." NOT ON SCREEN" ABORT ENDIF ( KEEP ON THIS SCREEN ) SCR @ (LINE) DROP ; --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 17 00 ( LINE EDITING COMMANDS ) 01 EDITOR DEFINITIONS 02 : -MOVE ( MOVE IN BLOCK BUFFER 03 ADDR FROM-2, LINE TO-1 *) 04 LINE C/L CMOVE UPDATE ; 05 06 : HL ( HOLD 07 NUMBERED LINE AT PAD *) 08 LINE PAD 1+ C/L DUP PAD 09 C! CMOVE ; 0A : BL ( ERASE 0B LINE-1 WITH BLANKS *) 0C LINE C/L BLANKS UPDATE ; 0D 0E : SL ( SPREAD 0F MAKING LINE # BLANK *) 10 DUP 1 - ( LIMIT ) 11 #OFLINES 2 - ( FIRST TO MOVE ) 12 DO I LINE I 1+ -MOVE 13 -1 +LOOP BL ; 14 : DL ( DELETE LINE-1, 15 BUT HOLD IN PAD *) 16 DUP HL #OFLINES 1 - 17 DUP ROT 18 DO I 1+ LINE I -MOVE 19 LOOP BL ; 1A : CL ( COPY LINE-2 OF SCREEN-1 1B TO PAD ) 1C SCR @ >R SCR ! HL R> SCR ! ; 1D 1E --> 1F ( LINE EDITING COMMANDS ) EDITOR DEFINITIONS : -MOVE ( MOVE IN BLOCK BUFFER ADDR FROM-2, LINE TO-1 *) LINE C/L CMOVE UPDATE ; : HL ( HOLD NUMBERED LINE AT PAD *) LINE PAD 1+ C/L DUP PAD C! CMOVE ; : BL ( ERASE LINE-1 WITH BLANKS *) LINE C/L BLANKS UPDATE ; : SL ( SPREAD MAKING LINE # BLANK *) DUP 1 - ( LIMIT ) #OFLINES 2 - ( FIRST TO MOVE ) DO I LINE I 1+ -MOVE -1 +LOOP BL ; : DL ( DELETE LINE-1, BUT HOLD IN PAD *) DUP HL #OFLINES 1 - DUP ROT DO I 1+ LINE I -MOVE LOOP BL ; : CL ( COPY LINE-2 OF SCREEN-1 TO PAD ) SCR @ >R SCR ! HL R> SCR ! ; --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 18 00 ( LINE EDITING COMMANDS 01 WFR-790105 ) 02 : RL 03 ( REPLACE ON LINE-1, FROM PAD ) 04 PAD 1+ SWAP -MOVE ; 05 06 07 08 : $ ( PUT 09 FOLLOWING TEXT ON LINE-1 ) 0A 1 TEXT RL QUIT ; 0B 0C 0D 0E : % ( INSERT TEXT 0F FOLLOWING AFTER LINE-1 *) 10 1 TEXT 1+ DUP SL RL ; 11 12 13 14 : IL ( INSERT PAD AFTER 15 LINE-1 ) 1+ DUP SL RL ; 16 17 18 : TL ( TYPE LINE BY #-1, SAVE 19 ALSO IN PAD *) 1A DUP . ." $ " 1B DUP C/L * R# ! HL 1C PAD 1+ C/L TYPE CR ; 1D 1E --> 1F ( LINE EDITING COMMANDS WFR-790105 ) : RL ( REPLACE ON LINE-1, FROM PAD ) PAD 1+ SWAP -MOVE ; : $ ( PUT FOLLOWING TEXT ON LINE-1 ) 1 TEXT RL QUIT ; : % ( INSERT TEXT FOLLOWING AFTER LINE-1 *) 1 TEXT 1+ DUP SL RL ; : IL ( INSERT PAD AFTER LINE-1 ) 1+ DUP SL RL ; : TL ( TYPE LINE BY #-1, SAVE ALSO IN PAD *) DUP . ." $ " DUP C/L * R# ! HL PAD 1+ C/L TYPE CR ; --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 19 00 ( SCREEN EDITING COMMANDS ) 01 FORTH DEFINITIONS 02 03 04 : COPY ( DUPLICATE SCREEN-2, 05 ONTO SCREEN-1 *) 06 SWAP BLOCK DROP PREV @ ! 07 UPDATE FLUSH ; 08 09 0A : LIST 2602 LMARGN ! LIST ; 0B 0C 0D : SHOW 1+ SWAP DO I LIST LOOP ; 0E 0F 10 : L SCR @ LIST ( RE-LIST SCR ) ; 11 12 : N SCR @ 1+ LIST ; ( LIST NEXT 13 SCR) 14 15 : WHERE ( OFFSET BLK --- ) DUP 16 SCR ! ." SCR # " . CR C/L /MOD 17 EDITOR TL FORTH 2 + SPACES 18 5E EMIT [COMPILE] EDITOR QUIT ; 19 1A BASE @ DECIMAL 1B ' EDITOR 2 + 32 +ORIGIN ! 1C ( VOC-LINK ) BASE ! 1D ;S 1E 1F ( SCREEN EDITING COMMANDS ) FORTH DEFINITIONS : COPY ( DUPLICATE SCREEN-2, ONTO SCREEN-1 *) SWAP BLOCK DROP PREV @ ! UPDATE FLUSH ; : LIST 2602 LMARGN ! LIST ; : SHOW 1+ SWAP DO I LIST LOOP ; : L SCR @ LIST ( RE-LIST SCR ) ; : N SCR @ 1+ LIST ; ( LIST NEXT SCR) : WHERE ( OFFSET BLK --- ) DUP SCR ! ." SCR # " . CR C/L /MOD EDITOR TL FORTH 2 + SPACES 5E EMIT [COMPILE] EDITOR QUIT ; BASE @ DECIMAL ' EDITOR 2 + 32 +ORIGIN ! ( VOC-LINK ) BASE ! ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 1A 00 ( OS & HDW CONSTANTS ) : CN CONS 01 TANT ; 02 D200 CN F1AUD D201 CN C1AUD 03 04 D202 CN F2AUD D203 CN C2AUD 05 06 D204 CN F3AUD D205 CN C3AUD 07 08 D206 CN F4AUD D207 CN C4AUD 09 0A D20F CN SKCTL D208 CN AUDCTL 0B 0C 230 CN DLST 22F CN DMCT 0D 0E 14 CN RTCLK 2F0 CN CRSINH 0F 10 2F4 CN CHBAS 2C4 CN COL0 11 12 2C5 CN COL1 2C6 CN COL2 13 14 2C7 CN COL3 2C8 CN COL4 15 16 D01F CN CONSOL 2FC CN CH 17 18 2BF CN BOTSC 52 CN LMARGN 19 1A 2FB CN ATACHR 1B 1C ;S 1D 1E 1F ( OS & HDW CONSTANTS ) : CN CONSTANT ; D200 CN F1AUD D201 CN C1AUD D202 CN F2AUD D203 CN C2AUD D204 CN F3AUD D205 CN C3AUD D206 CN F4AUD D207 CN C4AUD D20F CN SKCTL D208 CN AUDCTL 230 CN DLST 22F CN DMCT 14 CN RTCLK 2F0 CN CRSINH 2F4 CN CHBAS 2C4 CN COL0 2C5 CN COL1 2C6 CN COL2 2C7 CN COL3 2C8 CN COL4 D01F CN CONSOL 2FC CN CH 2BF CN BOTSC 52 CN LMARGN 2FB CN ATACHR ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 1B 00 ( CIO CALL ROUTINES ) 01 02 340 VARIABLE IOC 0 VARIABLE IOB 03 04 : IOCB 7 MIN 0 MAX 10 * DUP IOB 05 ! 340 + IOC ! ; 06 : .IOC <BUILDS , DOES> @ IOC @ + 07 ; 08 1 .IOC ICDNO 2 .IOC ICCOM 3 .IOC 09 ICSTA 0A 4 .IOC ICBAL 6 .IOC ICPTL 0B 0C 8 .IOC ICBLL A .IOC I1CAX B .IOC 0D I2CAX 0E CODE CIO TXA, PHA, IOB LDX, E456 0F JSR, PLA, TAX, NEXT JMP, C; 10 CODE Get XSAVE STX, IOB LDX, E45 11 6 JSR, 12 XSAVE LDX, PHA, 0 # LDA, PUSH JM 13 P, C; 14 : GET 7 ICCOM C! Get ; 15 16 : CLOSE 0C ICCOM C! CIO ; 17 18 : OPEN 3 ICCOM C! ICBAL ! I1CAX 19 C! I2CAX C! CIO ; 1A CODE ACIO XSAVE STX, BOT LDA, IO 1B B LDX, E456 JSR, 1C XSAVE LDX, POP JMP, C; 1D 1E --> 1F ( CIO CALL ROUTINES ) 340 VARIABLE IOC 0 VARIABLE IOB : IOCB 7 MIN 0 MAX 10 * DUP IOB ! 340 + IOC ! ; : .IOC <BUILDS , DOES> @ IOC @ + ; 1 .IOC ICDNO 2 .IOC ICCOM 3 .IOC ICSTA 4 .IOC ICBAL 6 .IOC ICPTL 8 .IOC ICBLL A .IOC I1CAX B .IOC I2CAX CODE CIO TXA, PHA, IOB LDX, E456 JSR, PLA, TAX, NEXT JMP, C; CODE Get XSAVE STX, IOB LDX, E456 JSR, XSAVE LDX, PHA, 0 # LDA, PUSH JMP, C; : GET 7 ICCOM C! Get ; : CLOSE 0C ICCOM C! CIO ; : OPEN 3 ICCOM C! ICBAL ! I1CAX C! I2CAX C! CIO ; CODE ACIO XSAVE STX, BOT LDA, IOB LDX, E456 JSR, XSAVE LDX, POP JMP, C; --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 1C 00 ( COLLEEN GRAPHICS ) 01 02 3A53 VARIABLE S: 2FD CONSTANT 03 FILDAT 0 VARIABLE Qbase 04 : PBASE Qbase @ ; : SPB HIMEM @ 05 1+ F800 AND 800 - DUP 06 Qbase ! 17F + HIMEM ! ; SPB 07 : POS. 54 C! 55 ! ; 08 : GR. 1 IOCB CLOSE 0 ICBLL ! DUP 09 F AND SWAP 30 AND 10 0A XOR 0C + S: OPEN SPB ; 0B : GRAPHICS GR. ; 0C : LOC. POS. GET ; 1 VARIABLE Col 0D or 0E : C. DUP Color C! FILDAT C! ; 0F : PUT 0B ICCOM C! ACIO ; 10 : PL. POS. ICBLL 0SET Color C@ P 11 UT ; 12 : SE. SWAP 10 * + SWAP 2C4 + C! 13 ; 14 : DR. POS. 11 ICCOM C! Color C@ 15 DUP 2FB C! FILDAT C! CIO ; 16 : PLOT PL. ; : LOCATE LOC. 17 ; 18 : SETCOLOR SE. ; : COLOR C. ; 19 1A : POSITION POS. ; : DRAWTO DR. ; 1B 1C : CLEAR 0 0 POS. 7D PUT ; 1D 1E : XIO18 ( FILL ) DUP 2FD C! 2FB 1F C! 12 ICCOM C! CIO ; --> ( COLLEEN GRAPHICS ) 3A53 VARIABLE S: 2FD CONSTANT FILDAT 0 VARIABLE Qbase : PBASE Qbase @ ; : SPB HIMEM @ 1+ F800 AND 800 - DUP Qbase ! 17F + HIMEM ! ; SPB : POS. 54 C! 55 ! ; : GR. 1 IOCB CLOSE 0 ICBLL ! DUP F AND SWAP 30 AND 10 XOR 0C + S: OPEN SPB ; : GRAPHICS GR. ; : LOC. POS. GET ; 1 VARIABLE Color : C. DUP Color C! FILDAT C! ; : PUT 0B ICCOM C! ACIO ; : PL. POS. ICBLL 0SET Color C@ PUT ; : SE. SWAP 10 * + SWAP 2C4 + C! ; : DR. POS. 11 ICCOM C! Color C@ DUP 2FB C! FILDAT C! CIO ; : PLOT PL. ; : LOCATE LOC. ; : SETCOLOR SE. ; : COLOR C. ; : POSITION POS. ; : DRAWTO DR. ; : CLEAR 0 0 POS. 7D PUT ; : XIO18 ( FILL ) DUP 2FD C! 2FB C! 12 ICCOM C! CIO ; --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 1D 00 ( SOUND CONTROLLERS RND PLAYER/M 01 ISSILES ) 02 : SOUND 3 D20F C! 0 D208 C! SWAP 03 04 10 * + 100 * + SWAP 2 * D200 + ! 05 ; 06 : PADDLE 270 + C@ ; 07 : PTRIG 27C + C@ ; 08 : STICK 278 + C@ ; 09 : STRIG 284 + C@ ; 0A : RND D20A C@ ; 0B 22F CONSTANT DMACTL 0C D01D CONSTANT GRACTL 0D D407 CONSTANT PMBASE 0E D01B CONSTANT PRIOR 0F D016 CONSTANT VDELAY 10 2C0 CONSTANT COLPM 11 26F CONSTANT GPRIOR 12 PBASE 1 - HIMEM ! 13 14 : PLAYER Qbase 1+ C@ PMBASE C! 3 15 GRACTL C! 2 - IF 1C 16 ELSE 0C ENDIF DMACTL @ E3 AND 17 OR DMACTL C! ; 18 : HPOS! D000 + C! ; 19 ( H-posn plyr# -> ) 1A : SIZE! D008 + C! ; 1B ( size-code plyr# -> ) 1C : COLPM! COLPM + C! ; 1D ( color plyr# -> ) 1E : NOPLY GRACTL 0SET D000 11 0 FI 1F LL ; ;S ( SOUND CONTROLLERS RND PLAYER/MISSILES ) : SOUND 3 D20F C! 0 D208 C! SWAP 10 * + 100 * + SWAP 2 * D200 + ! ; : PADDLE 270 + C@ ; : PTRIG 27C + C@ ; : STICK 278 + C@ ; : STRIG 284 + C@ ; : RND D20A C@ ; 22F CONSTANT DMACTL D01D CONSTANT GRACTL D407 CONSTANT PMBASE D01B CONSTANT PRIOR D016 CONSTANT VDELAY 2C0 CONSTANT COLPM 26F CONSTANT GPRIOR PBASE 1 - HIMEM ! : PLAYER Qbase 1+ C@ PMBASE C! 3 GRACTL C! 2 - IF 1C ELSE 0C ENDIF DMACTL @ E3 AND OR DMACTL C! ; : HPOS! D000 + C! ; ( H-posn plyr# -> ) : SIZE! D008 + C! ; ( size-code plyr# -> ) : COLPM! COLPM + C! ; ( color plyr# -> ) : NOPLY GRACTL 0SET D000 11 0 FILL ; ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 1E 00 ( DECUS-FORTH ADDITIONS ) 01 02 : 1+! 1 SWAP +! ; : 1- 1 - ; 03 04 : 0SET 0 SWAP ! ; : 2* DUP + ; 05 06 : HD DUP 0A < IF 30 ELSE 37 07 ENDIF + EMIT ; 08 : CHH DUP 0F0 AND 10 / HD 0F AND 09 HD ; 0A : CH? C@ CHH ; 0B 0C : HH DUP 0FF00 AND 100 / 0FF AND 0D CHH CHH ; 0E : H? @ HH ; 0F 10 : BDUMP 1+ SWAP DO I HH SPACE I 11 12 8 0 DO DUP I + CH? SPACE LOOP 13 DROP ." \" CR 8 +LOOP ; 14 15 : \ 10 0 DO SP@ 0E + I - @ SP@ 16 12 + @ I 2 / + C! 17 2 +LOOP DROP DROP DROP 18 DROP DROP DROP DROP DROP DROP 19 QUIT ; 1A : TBL <BUILDS DOES> ; 1B 1C : ALLOC DUP + ALLOT ; ( FOR RAM 1D BASED SYSTEMS,) 1E : ARRAY <BUILDS ALLOC DOES> ; 1F ;S ( DECUS-FORTH ADDITIONS ) : 1+! 1 SWAP +! ; : 1- 1 - ; : 0SET 0 SWAP ! ; : 2* DUP + ; : HD DUP 0A < IF 30 ELSE 37 ENDIF + EMIT ; : CHH DUP 0F0 AND 10 / HD 0F AND HD ; : CH? C@ CHH ; : HH DUP 0FF00 AND 100 / 0FF AND CHH CHH ; : H? @ HH ; : BDUMP 1+ SWAP DO I HH SPACE I 8 0 DO DUP I + CH? SPACE LOOP DROP ." \" CR 8 +LOOP ; : \ 10 0 DO SP@ 0E + I - @ SP@ 12 + @ I 2 / + C! 2 +LOOP DROP DROP DROP DROP DROP DROP DROP DROP DROP QUIT ; : TBL <BUILDS DOES> ; : ALLOC DUP + ALLOT ; ( FOR RAM BASED SYSTEMS,) : ARRAY <BUILDS ALLOC DOES> ; ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 1F 00 ( DISPLAY LIST STUFF ) 01 02 0 VARIABLE 3BYT 0 VARIABLE DLADR 03 04 : DINST DLADR @ C@ DUP 0F AND IF 05 06 DUP 0F AND 1 = IF 40 AND IF ." J 07 VB " 08 ELSE ." JMP " ENDIF DLADR 1+! DL 09 ADR @ 0A @ DUP DLADR ! HH 3BYT 0SET ELSE 0B DUP 0F AND 0C 8 OVER < IF ." MAP" ELSE ." CHR" 0D 0E ENDIF 7 AND . DUP 10 AND IF ." H 0F " 10 THEN DUP 20 AND IF ." V" THEN DU 11 P 12 80 AND IF ." I" ENDIF DUP 0B0 13 14 AND IF DUP 40 AND IF ." ," ENDIF 15 16 ENDIF 40 AND IF 3 DLADR @ 1+ H? 17 ELSE 18 1 ENDIF 3BYT ! ENDIF ELSE ." BLK 19 " 1A DUP 80 AND IF ." I," ENDIF 70 1B 1C AND 10 / . 1 3BYT ! ENDIF CR 1D 1E 3BYT @ DLADR +! ; ;S 1F ( DISPLAY LIST STUFF ) 0 VARIABLE 3BYT 0 VARIABLE DLADR : DINST DLADR @ C@ DUP 0F AND IF DUP 0F AND 1 = IF 40 AND IF ." JVB " ELSE ." JMP " ENDIF DLADR 1+! DLADR @ @ DUP DLADR ! HH 3BYT 0SET ELSE DUP 0F AND 8 OVER < IF ." MAP" ELSE ." CHR" ENDIF 7 AND . DUP 10 AND IF ." H" THEN DUP 20 AND IF ." V" THEN DUP 80 AND IF ." I" ENDIF DUP 0B0 AND IF DUP 40 AND IF ." ," ENDIF ENDIF 40 AND IF 3 DLADR @ 1+ H? ELSE 1 ENDIF 3BYT ! ENDIF ELSE ." BLK" DUP 80 AND IF ." I," ENDIF 70 AND 10 / . 1 3BYT ! ENDIF CR 3BYT @ DLADR +! ; ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 20 00 ( WRITE BOOTABLE OBJECT 1 OF 2 ) 01 02 BASE @ FORTH DEFINITIONS HEX 03 SAVENFAs ( PRESERV ALL NFAS ) 04 ( LATEST 0C +ORIGIN ! ) 05 ( TOP NFA ) 06 HERE 1C +ORIGIN ! ( FENCE ) 07 08 HERE 1E +ORIGIN ! ( DP ) 09 0A HERE DUP FENCE ! 0 +ORIGIN - 80 0B / 1+ CONSTANT #SECT 0C CODE CALLDK XSAVE STX, E453 JSR, 0D TYA, PHA, ( STATUS ) 0E XSAVE LDX, PUSH JMP, C; 0F 10 : DKIO 301 ! ( CMD, DRIVE # ) 11 30A ! ( SECT. # ) 12 304 ! ( RAM BUFFER ADDR ) 13 CALLDK ( JSR DKHND) 14 DUP 0< IF ." ERROR " 0FF AND 15 BASE @ SWAP DECIMAL 16 . BASE ! QUIT ENDIF DROP ; 17 18 : WTSEC 5701 DKIO ; 19 : RDSEC 5201 DKIO ; 1A : FORMAT ." FORMAT DRIVE " DUP . 1B 1C ." -ARE YOU SURE?" 0 PAD ! PAD 1D 1 EXPECT PAD C@ 59 ( Y) = 1E IF 2100 OR PAD 0 ROT DKIO ELSE 1F DROP THEN ; --> ( WRITE BOOTABLE OBJECT 1 OF 2 ) BASE @ FORTH DEFINITIONS HEX SAVENFAs ( PRESERV ALL NFAS ) ( LATEST 0C +ORIGIN ! ) ( TOP NFA ) HERE 1C +ORIGIN ! ( FENCE ) HERE 1E +ORIGIN ! ( DP ) HERE DUP FENCE ! 0 +ORIGIN - 80 / 1+ CONSTANT #SECT CODE CALLDK XSAVE STX, E453 JSR, TYA, PHA, ( STATUS ) XSAVE LDX, PUSH JMP, C; : DKIO 301 ! ( CMD, DRIVE # ) 30A ! ( SECT. # ) 304 ! ( RAM BUFFER ADDR ) CALLDK ( JSR DKHND) DUP 0< IF ." ERROR " 0FF AND BASE @ SWAP DECIMAL . BASE ! QUIT ENDIF DROP ; : WTSEC 5701 DKIO ; : RDSEC 5201 DKIO ; : FORMAT ." FORMAT DRIVE " DUP . ." -ARE YOU SURE?" 0 PAD ! PAD 1 EXPECT PAD C@ 59 ( Y) = IF 2100 OR PAD 0 ROT DKIO ELSE DROP THEN ; --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 21 00 ( WRITE BOOTABLE OBJECT 2 OF 2 ) 01 02 0 VARIABLE BOOT ( ->CODE) 03 : WTOBJ FLUSH EMPTY-BUFFERS 04 ." INSERT NEW DISK, TYPE Y" CR 05 0 PAD ! ( DEFAULT ) 06 PAD 3 EXPECT PAD C@ 59 = IF BOO 07 T @ 1 WTSEC #SECT 0 DO I 08 80 * +ORIGIN I 2 + WTSEC I 2 + 09 . LOOP ." DONE" CR THEN ; 0A ( FOLLOWING IS BOOT SECTOR CODE 0B ) HERE BOOT ! ( PT TO US ) 0C ASSEMBLER 1FF , 480 , E4C0 , #SE 0D CT # LDA, 0= IF, 0 +ORIGIN , 0E 1 , ENDIF, N STA, 52 # LDA, 302 0F STA, 48C LDA, 30A STA, 10 48D LDA, 30B STA, ( FIRST SECTO 11 R) 1 # LDA, ( DRV) 301 STA, 12 48A LDA, 304 STA, 48B LDA, 13 305 STA, ( ORIGIN) 14 BEGIN, 30A INC, 0= IF, 30B INC, 15 ENDIF, E453 JSR, 303 LDA, 16 .A ASL, CS IF, RTS, ( FRETURN ) 17 ENDIF, 304 LDA, 80 # EOR, 18 304 STA, 0< NOT IF, 305 INC, 19 ENDIF, ( BUMP PTR.) 1A N DEC, 0= UNTIL, 48A LDA, 0A ST 1B A, 48B LDA, 0B STA, CLC, 1C RTS, FORTH BASE ! ." n FORMAT" 1D CR ." to Format Disk Drive n" CR 1E ." WTOBJ to write boot version 1F of current object" CR ;S ( WRITE BOOTABLE OBJECT 2 OF 2 ) 0 VARIABLE BOOT ( ->CODE) : WTOBJ FLUSH EMPTY-BUFFERS ." INSERT NEW DISK, TYPE Y" CR 0 PAD ! ( DEFAULT ) PAD 3 EXPECT PAD C@ 59 = IF BOOT @ 1 WTSEC #SECT 0 DO I 80 * +ORIGIN I 2 + WTSEC I 2 + . LOOP ." DONE" CR THEN ; ( FOLLOWING IS BOOT SECTOR CODE ) HERE BOOT ! ( PT TO US ) ASSEMBLER 1FF , 480 , E4C0 , #SECT # LDA, 0= IF, 0 +ORIGIN , 1 , ENDIF, N STA, 52 # LDA, 302 STA, 48C LDA, 30A STA, 48D LDA, 30B STA, ( FIRST SECTOR) 1 # LDA, ( DRV) 301 STA, 48A LDA, 304 STA, 48B LDA, 305 STA, ( ORIGIN) BEGIN, 30A INC, 0= IF, 30B INC, ENDIF, E453 JSR, 303 LDA, .A ASL, CS IF, RTS, ( FRETURN ) ENDIF, 304 LDA, 80 # EOR, 304 STA, 0< NOT IF, 305 INC, ENDIF, ( BUMP PTR.) N DEC, 0= UNTIL, 48A LDA, 0A STA, 48B LDA, 0B STA, CLC, RTS, FORTH BASE ! ." n FORMAT" CR ." to Format Disk Drive n" CR ." WTOBJ to write boot version of current object" CR ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 22 00 ( <UNUSED> ) ;S 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F 10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F ( <UNUSED> ) ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 23 00 ( COLLEEN TO DEVSYS COMMUNICATIO 01 NS WORDS -- SEND ) 02 D303 CONSTANT PIADIR D301 CONSTA 03 NT PIA 04 : NIBSEND ( SEND LOW NIBBLE OF 05 TOS ) 06 80 OR PIA C! ( SEND DATA ) 07 BEGIN PIA C@ 40 AND ( WAIT FOR 08 ACK ) END 0 PIA C! ( ACK-ACK) 09 BEGIN PIA C@ 40 AND 0= END 0A ( WAIT FOR ACK-ACK-ACK ) ; 0B : DBSND ( TOS=BLOCK PTR ) 0C 400 0 DO I OVER + ( DATA PTR ) 0D C@ DUP NIBSEND 0E ( LOW NIBBLE ) 10 / NIBSEND ( 0F HIGH NIBBLE ) LOOP DROP ; 10 : BSND ( SET UP PIA AND SEND A 11 BLOCK -- TOS = BLOCK NUMBER ) 12 PIADIR C@ FB AND PIADIR C! 13 8F PIA C! ( SET DATA DIRECTION) 14 PIADIR C@ 4 OR PIADIR C! 15 0 PIA C! 16 BEGIN PIA C@ 40 AND 0= END 17 BLOCK DBSND ( SEND THE BLOCK ) 18 ; 19 1A ( FRST LAST SMOV MOVE BLOCKS ) 1B : SMOV 1+ SWAP DO I . I BSND 1C LOOP ; 1D 1E --> 1F ( COLLEEN TO DEVSYS COMMUNICATIONS WORDS -- SEND ) D303 CONSTANT PIADIR D301 CONSTANT PIA : NIBSEND ( SEND LOW NIBBLE OF TOS ) 80 OR PIA C! ( SEND DATA ) BEGIN PIA C@ 40 AND ( WAIT FOR ACK ) END 0 PIA C! ( ACK-ACK) BEGIN PIA C@ 40 AND 0= END ( WAIT FOR ACK-ACK-ACK ) ; : DBSND ( TOS=BLOCK PTR ) 400 0 DO I OVER + ( DATA PTR ) C@ DUP NIBSEND ( LOW NIBBLE ) 10 / NIBSEND ( HIGH NIBBLE ) LOOP DROP ; : BSND ( SET UP PIA AND SEND A BLOCK -- TOS = BLOCK NUMBER ) PIADIR C@ FB AND PIADIR C! 8F PIA C! ( SET DATA DIRECTION) PIADIR C@ 4 OR PIADIR C! 0 PIA C! BEGIN PIA C@ 40 AND 0= END BLOCK DBSND ( SEND THE BLOCK ) ; ( FRST LAST SMOV MOVE BLOCKS ) : SMOV 1+ SWAP DO I . I BSND LOOP ; --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 24 00 ( COLLEEN TO DEVSYS COMMUNICATIO 01 NS WORDS -- RECEIVE ) 02 CODE NIBRECV 0 # LDA, PIA STA, 03 BEGIN, PIA BIT, 0< UNTIL, 04 PIA LDA, 0F # AND, 40 # LDY, 05 PIA STY, 06 BEGIN, PIA BIT, 0< NOT UNTIL, 07 PHA, 0 # LDA, PIA STA, 08 PUSH JMP, C; 09 ( READY TO RECEIVE ) 0A : DBREC ( TOS - BLOCK POINTER ) 0B 400 0 DO NIBRECV NIBRECV 10 * + 0C ( GET A BYTE ) OVER I + 0D C! ( AND STORE IT IN BUFFER ) 0E LOOP DROP ; 0F 10 : BREC ( SET UP PIA AND RECV A 11 BLOCK -- TOS = BLOCK NUMBER ) 12 PIADIR C@ FB AND PIADIR C! 13 40 PIA C! ( ONLY SEND ACK BIT ) 14 PIADIR C@ 4 OR PIADIR C! 15 BUFFER DBREC ( RECV THE BLOCK ) 16 UPDATE FLUSH ( WRITE TO DISK ) 17 ; 18 ( FRST LAST RMOV -- MOVE A SET 19 OF BLOCKS ) 1A : RMOV 1+ SWAP DO I . I BREC 1B LOOP ; ;S 1C 1D 1E 1F ( COLLEEN TO DEVSYS COMMUNICATIONS WORDS -- RECEIVE ) CODE NIBRECV 0 # LDA, PIA STA, BEGIN, PIA BIT, 0< UNTIL, PIA LDA, 0F # AND, 40 # LDY, PIA STY, BEGIN, PIA BIT, 0< NOT UNTIL, PHA, 0 # LDA, PIA STA, PUSH JMP, C; ( READY TO RECEIVE ) : DBREC ( TOS - BLOCK POINTER ) 400 0 DO NIBRECV NIBRECV 10 * + ( GET A BYTE ) OVER I + C! ( AND STORE IT IN BUFFER ) LOOP DROP ; : BREC ( SET UP PIA AND RECV A BLOCK -- TOS = BLOCK NUMBER ) PIADIR C@ FB AND PIADIR C! 40 PIA C! ( ONLY SEND ACK BIT ) PIADIR C@ 4 OR PIADIR C! BUFFER DBREC ( RECV THE BLOCK ) UPDATE FLUSH ( WRITE TO DISK ) ; ( FRST LAST RMOV -- MOVE A SET OF BLOCKS ) : RMOV 1+ SWAP DO I . I BREC LOOP ; ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 25 00 ( LINE PRINTER WORDS 1/27/81 01 SRC ) 3A50 VARIABLE P: 02 CODE PCIO XSAVE STX, 70 # LDX, 03 E456 JSR, XSAVE LDX, TYA, PHA, 04 PUSH JMP, C; 0 VARIABLE LPCNT 05 : PERR? DUP 0< IF FF AND 06 ." P: ERROR " ERROR THEN 07 DROP ; 08 : LPOPEN 3 3B2 C! P: 3B4 ! 2 3B8 09 ! 8 3BA ! PCIO PERR? ; 0A : LYP1 3B8 ! 3B4 ! 0B 3B2 C! PCI 0B O PERR? ; : LPEMIT SP@ 1 LYP1 DR 0C OP ; : LPCR 9B LPEMIT 1 LPCNT +! 0D ; : LYPE DUP IF DUP 50 > IF 0E 1 LPCNT +! THEN LYP1 ELSE DROP 0F DROP THEN 20 SP@ 1 LYP1 DROP ; 10 : CRLP LPCR LPCNT @ 3D > IF 11 LPCR LPCR LPCR LPCR 0 LPCNT ! 12 THEN ; 13 : FFLP CRLP BEGIN LPCNT @ WHILE 14 CRLP REPEAT ; 15 : SHRINK 1B LPEMIT 14 LPEMIT 16 CRLP ; : EXPAND 1B LPEMIT 13 17 LPEMIT CRLP ; 18 : .CLP 0 <# # # #> LYPE ; 19 : .LP 0 <# #S #> LYPE ; 1A : LINELP DUP .CLP SCR @ (LINE) 1B -TRAILING 1 MAX LYPE CRLP ; 1C 4353 VARIABLE SCR# 2052 , 2023 , 1D : LISTLP DUP SCR ! SCR# 6 LYPE 1E .LP LPCR B/SCR B/BUF * C/L / 1F 0 DO I LINELP LOOP ; --> ( LINE PRINTER WORDS 1/27/81 SRC ) 3A50 VARIABLE P: CODE PCIO XSAVE STX, 70 # LDX, E456 JSR, XSAVE LDX, TYA, PHA, PUSH JMP, C; 0 VARIABLE LPCNT : PERR? DUP 0< IF FF AND ." P: ERROR " ERROR THEN DROP ; : LPOPEN 3 3B2 C! P: 3B4 ! 2 3B8 ! 8 3BA ! PCIO PERR? ; : LYP1 3B8 ! 3B4 ! 0B 3B2 C! PCIO PERR? ; : LPEMIT SP@ 1 LYP1 DROP ; : LPCR 9B LPEMIT 1 LPCNT +! ; : LYPE DUP IF DUP 50 > IF 1 LPCNT +! THEN LYP1 ELSE DROP DROP THEN 20 SP@ 1 LYP1 DROP ; : CRLP LPCR LPCNT @ 3D > IF LPCR LPCR LPCR LPCR 0 LPCNT ! THEN ; : FFLP CRLP BEGIN LPCNT @ WHILE CRLP REPEAT ; : SHRINK 1B LPEMIT 14 LPEMIT CRLP ; : EXPAND 1B LPEMIT 13 LPEMIT CRLP ; : .CLP 0 <# # # #> LYPE ; : .LP 0 <# #S #> LYPE ; : LINELP DUP .CLP SCR @ (LINE) -TRAILING 1 MAX LYPE CRLP ; 4353 VARIABLE SCR# 2052 , 2023 , : LISTLP DUP SCR ! SCR# 6 LYPE .LP LPCR B/SCR B/BUF * C/L / 0 DO I LINELP LOOP ; --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 26 00 ( MORE LINE PRINTER WORDS 01 1/27/81 SRC ) 02 : LPSPC 0 DO 20 LPEMIT LOOP ; 03 : SHOWLP 1+ SWAP C/L 20 = IF 04 DO CRLP 05 SCR# 6 LYPE I .LP 06 1F LPSPC SCR# 6 LYPE I 1+ 07 .LP CRLP 08 I 20 0 DO DUP SCR ! I .CLP 09 I SCR @ (LINE) LYPE 0A 5 LPSPC 0B DUP 1+ SCR ! I LINELP LOOP 0C DROP 2 +LOOP 0D ELSE DO CRLP I LISTLP LOOP 0E ENDIF FFLP ; 0F 10 : LPINDEX 1+ SWAP DO I .LP 11 0 I (LINE) -TRAILING LYPE LPCR 12 LOOP ; 13 LPOPEN 14 ;S 15 16 17 18 19 1A 1B 1C 1D 1E 1F ( MORE LINE PRINTER WORDS 1/27/81 SRC ) : LPSPC 0 DO 20 LPEMIT LOOP ; : SHOWLP 1+ SWAP C/L 20 = IF DO CRLP SCR# 6 LYPE I .LP 1F LPSPC SCR# 6 LYPE I 1+ .LP CRLP I 20 0 DO DUP SCR ! I .CLP I SCR @ (LINE) LYPE 5 LPSPC DUP 1+ SCR ! I LINELP LOOP DROP 2 +LOOP ELSE DO CRLP I LISTLP LOOP ENDIF FFLP ; : LPINDEX 1+ SWAP DO I .LP 0 I (LINE) -TRAILING LYPE LPCR LOOP ; LPOPEN ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 27 00 ( FORMATTED LIST PROGRAM) : THAT 01 ; VOCABULARY FORMX IMMEDIATE 02 FORMX DEFINITIONS : CN CONSTANT 03 ; : OCTAL 8 BASE ! ; 04 BASE @ OCTAL 40 CN SPACBYT 54 05 CN COMCHR : IARRAY 0 VARIABLE -2 06 ALLOT ; : 0> DUP 0= IF DROP 0 07 ELSE 0< 0= THEN ; 08 0 VARIABLE INDENT 106 CN FCONS 09 111 CN ICONS 0 VARIABLE TLFLG 0A 0 VARIABLE KERKNT 100 CN MAXLIN 0B : NXSPACE >R 1+ >R 0 R> R> DO 0C SPACBYT I C@ = IF DROP I LEAVE 0D THEN LOOP ; : NXNSPACE >R 1+ >R 0E 0 R> R> DO SPACBYT I C@ = 0= IF 0F 10 DROP I LEAVE THEN LOOP ; : GTNX 11 WD DUP IF + OVER SWAP NXSPACE 12 ELSE DROP THEN DUP IF OVER SWAP 13 NXNSPACE DUP IF OVER OVER 14 NXSPACE DUP IF OVER - ELSE DROP 15 OVER OVER - 1+ THEN ELSE DUP 16 THEN ELSE DUP THEN ; : TORLCR TL 17 FLG @ IF CRLP ELSE CR THEN KERKN 18 T 0SET ; : TORLY DUP 1+ KERKNT + 19 ! TLFLG @ IF LYPE ELSE TYPE SPAC 1A E THEN ; : DOIND INDENT @ 0> IF 1B INDENT @ 0 DO 0 0 TORLY LOOP THE 1C N ; : PRWORD DUP 1+ KERKNT @ + M 1D AXLIN > IF TORLCR THEN KERKNT @ 1E 0= IF DOIND THEN OVER OVER TORLY 1F ; : 1SET 1 SWAP ! ; --> ( FORMATTED LIST PROGRAM) : THAT ; VOCABULARY FORMX IMMEDIATE FORMX DEFINITIONS : CN CONSTANT ; : OCTAL 8 BASE ! ; BASE @ OCTAL 40 CN SPACBYT 54 CN COMCHR : IARRAY 0 VARIABLE -2 ALLOT ; : 0> DUP 0= IF DROP 0 ELSE 0< 0= THEN ; 0 VARIABLE INDENT 106 CN FCONS 111 CN ICONS 0 VARIABLE TLFLG 0 VARIABLE KERKNT 100 CN MAXLIN : NXSPACE >R 1+ >R 0 R> R> DO SPACBYT I C@ = IF DROP I LEAVE THEN LOOP ; : NXNSPACE >R 1+ >R 0 R> R> DO SPACBYT I C@ = 0= IF DROP I LEAVE THEN LOOP ; : GTNXWD DUP IF + OVER SWAP NXSPACE ELSE DROP THEN DUP IF OVER SWAP NXNSPACE DUP IF OVER OVER NXSPACE DUP IF OVER - ELSE DROP OVER OVER - 1+ THEN ELSE DUP THEN ELSE DUP THEN ; : TORLCR TLFLG @ IF CRLP ELSE CR THEN KERKNT 0SET ; : TORLY DUP 1+ KERKNT +! TLFLG @ IF LYPE ELSE TYPE SPACE THEN ; : DOIND INDENT @ 0> IF INDENT @ 0 DO 0 0 TORLY LOOP THEN ; : PRWORD DUP 1+ KERKNT @ + MAXLIN > IF TORLCR THEN KERKNT @ 0= IF DOIND THEN OVER OVER TORLY ; : 1SET 1 SWAP ! ; --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 28 00 : ( 51 WORD 6 ALLOT ; 01 02 : IA IARRAY ; IA L1G 10 , ( :) 03 ( CODE) ( ,CODE) ( SUBROUTINE) 04 ( IA) ( IARRAY) ( LABEL) ( TBL) 05 IA L2G 2 , ( ;) ( C;) 06 IA L3G 2 , ( NXT,) ( NEXT,) IA 07 L4G 6 , ( IF) ( DO) ( IF,) 08 ( CASE) ( BEGIN) ( BEGIN,) IA 09 L5G 3 , ( ELSE,) ( ELSE) 0A ( WHILE) IA L6G 16 , ( THEN,) 0B ( THEN) ( END,) ( END) ( SOB,) 0C ( BACK) ( UNTIL) ( AGAIN) ( REPE 0D AT) ( ENDIF,) 0E ( UNTIL,) ( LOOP) ( +LOOP) ( E 0F NDIF) IA L7G 7 , ( CONSTANT) 10 ( IR) ( VARIABLE) ( CN) 11 ( ARRAY) ( INTEGER) ( ORCON) 12 IA L8G 1 , ( () IA L9G 3 , ( 13 LD,) ( ST,) ( LOAD) 14 IA LAG 1 , ( ;CODE) 15 16 : CMPWORD DUP >R C@ OVER = R> 17 SWAP IF >R OVER 18 R> SWAP OVER DUP C@ DUP 4 > IF 19 DROP 4 THEN 0 1A DO I OVER + 1+ C@ >R OVER R> 1B SWAP I + C@ 1C = 0= IF 0 LEAVE THEN LOOP 1D 1E 0= IF DROP DROP 0 THEN ELSE 0 1F THEN ; --> : ( 51 WORD 6 ALLOT ; : IA IARRAY ; IA L1G 10 , ( :) ( CODE) ( ,CODE) ( SUBROUTINE) ( IA) ( IARRAY) ( LABEL) ( TBL) IA L2G 2 , ( ;) ( C;) IA L3G 2 , ( NXT,) ( NEXT,) IA L4G 6 , ( IF) ( DO) ( IF,) ( CASE) ( BEGIN) ( BEGIN,) IA L5G 3 , ( ELSE,) ( ELSE) ( WHILE) IA L6G 16 , ( THEN,) ( THEN) ( END,) ( END) ( SOB,) ( BACK) ( UNTIL) ( AGAIN) ( REPEAT) ( ENDIF,) ( UNTIL,) ( LOOP) ( +LOOP) ( ENDIF) IA L7G 7 , ( CONSTANT) ( IR) ( VARIABLE) ( CN) ( ARRAY) ( INTEGER) ( ORCON) IA L8G 1 , ( () IA L9G 3 , ( LD,) ( ST,) ( LOAD) IA LAG 1 , ( ;CODE) : CMPWORD DUP >R C@ OVER = R> SWAP IF >R OVER R> SWAP OVER DUP C@ DUP 4 > IF DROP 4 THEN 0 DO I OVER + 1+ C@ >R OVER R> SWAP I + C@ = 0= IF 0 LEAVE THEN LOOP 0= IF DROP DROP 0 THEN ELSE 0 THEN ; --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 29 00 : GSCAN DUP @ SWAP 2+ SWAP 0 DO 01 CMPWORD IF LEAVE 02 0 ELSE 6 + THEN LOOP IF 0 ELSE 03 DROP 1 THEN ; 04 : NEWCR KERKNT @ IF TORLCR THEN 05 ; 06 : DUPBC OVER >R >R OVER R> SWAP 07 R> ; 08 : FINDCHAR SWAP >R SWAP 1+ R> 09 DO DUP I C@ = 0A IF DROP I LEAVE 0 THEN LOOP IF 0B 0 THEN ; 0C : PRNEWL PRWORD TORLCR ; 0D 0E : >= OVER OVER = IF DROP DROP 0F 1 ELSE > THEN ; --> 10 11 12 13 14 15 16 17 18 19 1A 1B 1C 1D 1E 1F : GSCAN DUP @ SWAP 2+ SWAP 0 DO CMPWORD IF LEAVE 0 ELSE 6 + THEN LOOP IF 0 ELSE DROP 1 THEN ; : NEWCR KERKNT @ IF TORLCR THEN ; : DUPBC OVER >R >R OVER R> SWAP R> ; : FINDCHAR SWAP >R SWAP 1+ R> DO DUP I C@ = IF DROP I LEAVE 0 THEN LOOP IF 0 THEN ; : PRNEWL PRWORD TORLCR ; : >= OVER OVER = IF DROP DROP 1 ELSE > THEN ; --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 2A 00 : EL1G NEWCR INDENT 0SET PRWORD 01 GTNXWD PRNEWL 02 10 INDENT ! ; 03 04 : EL2G NEWCR PRNEWL INDENT 0SET 05 ; 06 : EL3G NEWCR PRNEWL ; 07 08 : EL4G NEWCR PRNEWL 2 INDENT +! 09 ; 0A : EL5G NEWCR -2 INDENT +! PRNEWL 0B 2 INDENT +! ; 0C : EL6G NEWCR -2 INDENT +! PRNEWL 0D ; 0E : EL7G PRWORD GTNXWD PRNEWL INDE 0F NT 0SET ; 10 : EL8G DUPBC 51 FINDCHAR DUP 11 12 IF SWAP DROP OVER - 1+ PRNEWL 13 ELSE DROP PRWORD THEN ; 14 : EL9G PRNEWL ; 15 16 : ELAG NEWCR 10 INDENT ! PRNEWL 17 ; 18 : ASSWRD DUP 4 >= IF OVER OVER + 19 1- C@ COMCHR = IF 1A OVER DUP C@ ICONS = SWAP 1+ 1B C@ FCONS = AND 1C IF 2 ELSE 1 THEN ELSE 0 THEN E 1D LSE 0 THEN ; 1E --> 1F : EL1G NEWCR INDENT 0SET PRWORD GTNXWD PRNEWL 10 INDENT ! ; : EL2G NEWCR PRNEWL INDENT 0SET ; : EL3G NEWCR PRNEWL ; : EL4G NEWCR PRNEWL 2 INDENT +! ; : EL5G NEWCR -2 INDENT +! PRNEWL 2 INDENT +! ; : EL6G NEWCR -2 INDENT +! PRNEWL ; : EL7G PRWORD GTNXWD PRNEWL INDENT 0SET ; : EL8G DUPBC 51 FINDCHAR DUP IF SWAP DROP OVER - 1+ PRNEWL ELSE DROP PRWORD THEN ; : EL9G PRNEWL ; : ELAG NEWCR 10 INDENT ! PRNEWL ; : ASSWRD DUP 4 >= IF OVER OVER + 1- C@ COMCHR = IF OVER DUP C@ ICONS = SWAP 1+ C@ FCONS = AND IF 2 ELSE 1 THEN ELSE 0 THEN ELSE 0 THEN ; --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 2B 00 : PRCWRD L1G GSCAN IF EL1G ELSE 01 L2G GSCAN IF EL2G ELSE 02 L3G GSCAN IF EL3G ELSE L4G GSC 03 AN IF EL4G ELSE L5G GSCAN 04 IF EL5G ELSE L6G GSCAN IF EL6G 05 ELSE L7G GSCAN IF EL7G 06 ELSE L8G GSCAN IF EL8G ELSE L9 07 G GSCAN IF EL9G ELSE 08 LAG GSCAN IF ELAG ELSE ASSWRD 09 IF ASSWRD 2 = 0A IF EL4G ELSE PRNEWL THEN ELSE 0B PRWORD 0C THEN THEN THEN THEN THEN THEN 0D THEN THEN THEN THEN THEN ; 0E : FORLST TORLCR DUP TLFLG @ IF L 0F ISTLP ELSE 10 TORLCR LIST THEN TORLCR TORLCR 11 DUP BLK ! 12 BLOCK DUP 1777 + SWAP KERKNT 0 13 SET INDENT 0SET 0 BEGIN GTNXWD 14 DUP IF PRCWRD THEN DUP 0= END 15 DROP DROP DROP BLK 0SET ; 16 : ASTER TORLCR 40 0 DO 52 SP@ 1 17 TORLY DROP LOOP TORLCR ; 18 : FORSHW 1+ OVER DO ASTER I FORL 19 ST TORLCR LOOP DROP ; 1A FORTH DEFINITIONS : FLST FORMX T 1B LFLG 0SET FORLST ; : FLSTLP FORM 1C X TLFLG 1SET FORLST FFLP ; : FSH 1D W FORMX TLFLG 0SET FORSHW ; : FS 1E HWLP FORMX TLFLG 1SET FORSHW 1F FFLP ; BASE ! ;S : PRCWRD L1G GSCAN IF EL1G ELSE L2G GSCAN IF EL2G ELSE L3G GSCAN IF EL3G ELSE L4G GSCAN IF EL4G ELSE L5G GSCAN IF EL5G ELSE L6G GSCAN IF EL6G ELSE L7G GSCAN IF EL7G ELSE L8G GSCAN IF EL8G ELSE L9G GSCAN IF EL9G ELSE LAG GSCAN IF ELAG ELSE ASSWRD IF ASSWRD 2 = IF EL4G ELSE PRNEWL THEN ELSE PRWORD THEN THEN THEN THEN THEN THEN THEN THEN THEN THEN THEN ; : FORLST TORLCR DUP TLFLG @ IF LISTLP ELSE TORLCR LIST THEN TORLCR TORLCR DUP BLK ! BLOCK DUP 1777 + SWAP KERKNT 0SET INDENT 0SET 0 BEGIN GTNXWD DUP IF PRCWRD THEN DUP 0= END DROP DROP DROP BLK 0SET ; : ASTER TORLCR 40 0 DO 52 SP@ 1 TORLY DROP LOOP TORLCR ; : FORSHW 1+ OVER DO ASTER I FORLST TORLCR LOOP DROP ; FORTH DEFINITIONS : FLST FORMX TLFLG 0SET FORLST ; : FLSTLP FORMX TLFLG 1SET FORLST FFLP ; : FSHW FORMX TLFLG 0SET FORSHW ; : FSHWLP FORMX TLFLG 1SET FORSHW FFLP ; BASE ! ;S * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 2C 00 ( RS232 SUPPORT ) 01 02 CODE SIO XSAVE STX, BOT LDA, E45 03 9 JSR, ( SIOV) XSAVE LDX, 04 BOT STA, BOT 1+ STY, NEXT JMP, 05 C; 06 : SERR DUP 0< IF 0 100 U/ BASE @ 07 DECIMAL ." SIO ERROR " 08 . BASE ! QUIT ELSE DROP THEN ; 09 0A CODE DORL XSAVE STX, 506 JSR, 0B 0C HERE 8 + JSR, XSAVE LDX, NEXT 0D JMP, 0C ) JMP, C; 0E : GETR: HERE 2E7 ! ( SET MEMLO ) 0F FLUSH EMPTY-BUFFERS 10 150 300 ! ( DDEVIC,DUNIT) 11 12 403F 302 ! ( ? CMD,EXPECT DATA 13 ) 5 306 C! ( TIMEOUT) 14 500 304 ! ( BUFFER ADDR) 15 16 0C 308 ! ( LENGTH ) 17 18 0 30A ! ( AUXES ) 19 0 SIO SERR ( ERRORS?) 1A 500 300 0C CMOVE 0 SIO SERR DOR 1B L 1C ( RUN RELOCATOR ) 2E7 @ HERE - 1D 1E ALLOT HERE FENCE ! ; --> 1F ( RS232 SUPPORT ) CODE SIO XSAVE STX, BOT LDA, E459 JSR, ( SIOV) XSAVE LDX, BOT STA, BOT 1+ STY, NEXT JMP, C; : SERR DUP 0< IF 0 100 U/ BASE @ DECIMAL ." SIO ERROR " . BASE ! QUIT ELSE DROP THEN ; CODE DORL XSAVE STX, 506 JSR, HERE 8 + JSR, XSAVE LDX, NEXT JMP, 0C ) JMP, C; : GETR: HERE 2E7 ! ( SET MEMLO ) FLUSH EMPTY-BUFFERS 150 300 ! ( DDEVIC,DUNIT) 403F 302 ! ( ? CMD,EXPECT DATA) 5 306 C! ( TIMEOUT) 500 304 ! ( BUFFER ADDR) 0C 308 ! ( LENGTH ) 0 30A ! ( AUXES ) 0 SIO SERR ( ERRORS?) 500 300 0C CMOVE 0 SIO SERR DORL ( RUN RELOCATOR ) 2E7 @ HERE - ALLOT HERE FENCE ! ; --> * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCR # 2D 00 ( RS232 ) 01 02 : R1: " R1: " DROP ; 03 04 : R1OPEN 0 8 R1: OPEN ICSTA CH? 05 ; 06 : RYPE -DUP IF 1 IOCB 0B ICCOM C 07 ! ICBLL ! ICBAL ! CIO 08 20 ICCOM C! 0 I1CAX ! CIO ELSE 09 DROP THEN ; 0A : CRR 0A9B SP@ 2 RYPE DROP ; 0B : REMIT SP@ 1 RYPE DROP ; 0C : SET9600 1 IOCB 0E I1CAX ! 24 0D ICCOM C! R1: ICBAL ! 0E CIO ICSTA CH? ; 0F 10 : LINER SCR @ (LINE) -TRAILING 11 RYPE ; 12 100 VARIABLE LSPD 13 14 : LISTR DUP SCR ! CRR " SCR#" RY 15 PE 0 <# #S #> RYPE CRR 10 0 16 DO I 0 <# # # #> RYPE I LINER 17 CRR LOOP ; 18 ;S 19 1A 1B 1C 1D 1E 1F ( RS232 ) : R1: " R1: " DROP ; : R1OPEN 0 8 R1: OPEN ICSTA CH? ; : RYPE -DUP IF 1 IOCB 0B ICCOM C! ICBLL ! ICBAL ! CIO 20 ICCOM C! 0 I1CAX ! CIO ELSE DROP THEN ; : CRR 0A9B SP@ 2 RYPE DROP ; : REMIT SP@ 1 RYPE DROP ; : SET9600 1 IOCB 0E I1CAX ! 24 ICCOM C! R1: ICBAL ! CIO ICSTA CH? ; : LINER SCR @ (LINE) -TRAILING RYPE ; 100 VARIABLE LSPD : LISTR DUP SCR ! CRR " SCR#" RYPE 0 <# #S #> RYPE CRR 10 0 DO I 0 <# # # #> RYPE I LINER CRR LOOP ; ;S
'Screens'
SCR # 14 0 ( ERROR MESSAGES ) 1 Stack empty 2 Dictionary full 3 Wrong address mode 4 Isn't unique 5 Value error 6 Disk address error 7 Stack full 8 Disk Error! 9 10 11 12 13 14 15 SCR # 15 0 ( ERROR MESSAGES ) 1 Use only in Definitions 2 Execution only 3 Conditionals not paired 4 Definition not finished 5 In protected dictionary 6 Use only when loading 7 Off current screen 8 Declare VOCABULARY 9 10 11 12 13 14 15 SCR # 16 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 17 0 ( CASSETTE LOAD ) 1 2 3 4 ( LOAD DEBUG ) 5 21 LOAD 6 7 ( LOAD ASSEMBLER ) 8 39 LOAD 9 10 11 12 13 ;S 14 15 SCR # 18 0 ( FULL LOAD ) 1 2 3 4 ( LOAD DEBUG ) 5 21 LOAD 6 7 ( LOAD EDITOR ) 8 27 LOAD 9 10 ( LOAD ASSEMBLER ) 11 39 LOAD 12 13 ;S 14 15 SCR # 19 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 20 0 ( ATARI FORTH DEFS ) 1 BASE @ HEX 2 3 : PON 1 PFLAG ! ; ( PRT ON ) 4 : POFF 0 PFLAG ! ; ( PRT OFF ) 5 6 : BEEP 0C0 0 DO 7 08 0D01F C! 6 0 DO LOOP 8 00 0D01F C! 6 0 DO LOOP 9 LOOP ; 10 11 : ASCII BL WORD HERE 1+ C@ 12 STATE @ IF COMPILE CLIT C, 13 THEN ; IMMEDIATE 14 15 BASE ! ;S SCR # 21 0 ( DEBUGGER AIDS -- DUMP , CDUMP ) 1 2 BASE @ HEX 3 4 5 6 7 8 : H. BASE @ HEX OVER U. BASE ! ; 9 10 : B? BASE @ DUP DECIMAL . BASE ! ; 11 : FREE 2E5 @ HERE - U. ." bytes" CR ; 12 13 14 --> 15 SCR # 22 0 ( DEBUGGER AIDS -- DUMP , CDUMP ) 1 DECIMAL 2 : ?EXIT ?TERMINAL 3 IF LEAVE ENDIF ; 4 : U.R 0 SWAP D.R ; 5 : LDMP DUP 8 + SWAP DO I C@ 4 .R 6 LOOP ; 7 : DUMP OVER + SWAP DO CR I 5 U.R I 8 LDMP ?EXIT 8 +LOOP CR ; 9 : CDMP DUP 16 + SWAP DO 10 I C@ EMIT LOOP ; 11 HEX 12 : CDUMP OVER + SWAP DO CR I 5 U.R I 13 SPACE 1 2FE C! CDMP 0 2FE C! 14 ?EXIT 10 +LOOP CR ; 15 DECIMAL --> SCR # 23 0 ( STACK PRINTER ) 1 2 HEX 3 4 : DEPTH SP@ 12 +ORIGIN @ SWAP - 2 / ; 5 : S. ( PRINTS THE STACK ) 6 DEPTH -DUP IF 7 0 DO CR ." TOP+" I . 8 SP@ I 2 * + @ U. LOOP 9 ELSE ." Stack Empty" THEN CR ; 10 11 12 13 BASE ! 14 15 --> SCR # 24 0 ( DEFINITION TRACER ) 1 BASE @ HEX 2 0 VARIABLE .WORD 3 ' CLIT CFA CONSTANT .CLIT 4 ' 0BRANCH CFA CONSTANT ZBRAN 5 ' BRANCH CFA CONSTANT BRAN 6 ' ;S CFA CONSTANT SEMIS 7 ' (LOOP) CFA CONSTANT PLOOP 8 ' (+LOOP) CFA CONSTANT PPLOOP 9 ' (.") CFA CONSTANT PDOTQ 10 : PWORD 2+ NFA ID. ; 11 : 1BYTE PWORD .WORD @ C@ . 1 .WORD +! ; 12 : 1WORD PWORD .WORD @ @ . 2 .WORD +! ; 13 : NP DUP SEMIS = IF PWORD CR CR 14 PROMPT QUIT THEN ?TERMINAL IF 15 PROMPT QUIT THEN ; --> SCR # 25 0 ( DEFINITION TRACER ) 1 2 : BRNCH PWORD ." to " .WORD @ .WORD @ @ + . 2 .WORD +! ; 3 4 : STG PWORD 22 EMIT .WORD @ DUP COUNT TYPE 22 EMIT 5 C@ .WORD @ + 1+ .WORD ! ; 6 7 ' LIT CFA CONSTANT .LIT 8 9 : CKIT DUP ZBRAN = OVER BRAN = 10 OR OVER PLOOP = OR OVER PPLOOP = 11 OR IF BRNCH ELSE DUP .LIT = 12 IF 1WORD ELSE DUP .CLIT = 13 IF 1BYTE ELSE DUP PDOTQ = IF STG 14 ELSE PWORD THEN THEN THEN THEN ; 15 --> SCR # 26 0 ( DEFINITION TRACER ) 1 ' : 12 + CONSTANT DOCOL 2 3 : T?PR CR CR ." Primitive" CR CR ; 4 : ?DOCOL DUP 2 - @ DOCOL - IF 5 T?PR PROMPT QUIT THEN ; 6 7 : .SETUP ~[COMPILE] ' ?DOCOL .WORD ! ; 8 9 : NXT1 .WORD @ U. 2 SPACES .WORD 10 @ @ 2 .WORD +! ; 11 12 : DECOMP .SETUP CR CR BEGIN NXT1 NP 13 CKIT CR AGAIN ; 14 15 BASE ! ;S SCR # 27 0 ( ** EDITOR ** ) 1 2 BASE @ HEX 3 4 ( THIS EDITOR IS PATTERNED AFTER 5 ( THE EXAMPLE EDITOR IN THE fig 6 ( "INSTALLATION MANUAL" 8/80 WFR 7 8 : TEXT HERE C/L 1+ BLANKS WORD 9 HERE PAD C/L 1+ CMOVE ; 10 11 : LINE DUP FFF0 AND 17 ?ERROR SCR 12 @ (LINE) DROP ; 13 14 : MARK 10 0 DO I LINE UPDATE 15 DROP LOOP ; --> SCR # 28 0 ( EDITOR ) 1 VOCABULARY EDITOR IMMEDIATE 2 : WHERE DUP B/SCR / DUP SCR ! ." SCR # " DECIMAL . 3 SWAP C/L /MOD C/L * ROT BLOCK + CR C/L -TRAILING TYPE CR HERE 4 C@ - SPACES 1 2FE C! 1C EMIT 0 2FE C! ~[COMPILE] EDITOR QUIT ; 5 6 EDITOR DEFINITIONS 7 8 : #LOCATE R# @ C/L /MOD ; 9 : #LEAD #LOCATE LINE SWAP ; 10 : #LAG #LEAD DUP >R + C/L R> - ; 11 12 13 : -MOVE LINE C/L CMOVE UPDATE ; 14 15 --> SCR # 29 0 ( EDITOR ) 1 : H LINE PAD 1+ C/L DUP PAD C! 2 CMOVE ; 3 : E LINE C/L BLANKS UPDATE ; 4 : S DUP 1 - 0E DO I LINE I 1+ 5 -MOVE -1 +LOOP E ; 6 : D DUP H 0F DUP ROT 7 DO I 1+ LINE I -MOVE LOOP E ; 8 9 10 --> 11 12 13 14 15 SCR # 30 0 ( EDITOR ) 1 2 : M R# +! CR SPACE #LEAD TYPE 3 17 EMIT #LAG TYPE #LOCATE 4 . DROP ; 5 : T DUP C/L * R# ! DUP H 0 M ; 6 : L SCR @ LIST 0 M ; 7 : R PAD 1+ SWAP -MOVE ; 8 : P 1 TEXT R ; 9 : I DUP S R ; 10 : TOP 0 R# ! ; 11 12 13 --> 14 15 SCR # 31 0 ( EDITOR ) 1 2 3 : CLEAR SCR ! 10 0 DO FORTH I 4 EDITOR E LOOP ; 5 6 7 8 9 10 : COPY B/SCR * OFFSET @ + SWAP 11 B/SCR * B/SCR OVER + 12 SWAP DO DUP FORTH I 13 BLOCK 2 - ! 1+ UPDATE 14 LOOP DROP FLUSH ; 15 --> SCR # 32 0 ( EDITOR ) 1 2 : 1LINE #LAG PAD COUNT MATCH R# 3 +! ; 4 5 6 : FIND BEGIN 3FF R# @ < IF TOP 7 PAD HERE C/L 1+ CMOVE 0 8 ERROR ENDIF 1LINE UNTIL 9 ; 10 11 : DELETE >R #LAG + FORTH R - 12 #LAG R MINUS R# +! #LEAD 13 + SWAP CMOVE R> BLANKS 14 UPDATE ; 15 --> SCR # 33 0 ( EDITOR ) 1 2 : N FIND 0 M ; 3 4 : F 1 TEXT N ; 5 6 : B PAD C@ MINUS M ; 7 8 : X 1 TEXT FIND PAD C@ DELETE 9 0 M ; 10 11 : TILL #LEAD + 1 TEXT 1LINE 0= 12 0 ?ERROR #LEAD + SWAP - 13 DELETE 0 M ; 14 15 --> SCR # 34 0 ( END OF EDITOR ) 1 2 : C 1 TEXT PAD COUNT #LAG ROT 3 OVER MIN >R FORTH R R# +! 4 R - >R DUP HERE R CMOVE 5 HERE #LEAD + R> CMOVE R> 6 CMOVE UPDATE 0 M ; 7 8 9 FORTH DEFINITIONS DECIMAL 10 11 LATEST 12 +ORIGIN ! 12 HERE 28 +ORIGIN ! 13 HERE 30 +ORIGIN ! 14 ' EDITOR 6 + 32 +ORIGIN ! 15 HERE FENCE ! BASE ! ;S SCR # 35 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 36 0 ( DISK COPY ROUTINE 32K RAM ) 1 2 BASE @ DECIMAL 3 16384 CONSTANT BUFHEAD 4 0 VARIABLE BLK# 0 VARIABLE ADRS 5 : GET ADRS @ BLK# @ ; 6 : RD GET DUP 718 = IF LEAVE THEN 1 R/W ; 7 : WRT GET DUP 718 = IF LEAVE THEN 0 R/W ; 8 : +BLK 1 BLK# +! 128 ADRS +! ; 9 : DSETUP BLK# ! BUFHEAD ADRS ! ; 10 : GKEY ." HIT ANY KEY " KEY CR DROP ; 11 : RDIN CR ." Insert SOURCE disk " GKEY DSETUP 12 90 0 DO RD +BLK LOOP ; 13 : WRTO CR ." Insert DESTINATION disk " GKEY DSETUP 14 90 0 DO WRT +BLK LOOP ; 15 --> SCR # 37 0 ( DISK COPY ROUTINE ) 1 2 ( INSERT SOURCE DISK IN DRIVE #1 3 4 ( SIMPLY TYPE "DISKCOPY" ! 5 6 : MS1 CR CR 7 ." SINGLE-DRIVE DISK COPY" CR CR ; 8 9 10 : %COPY 0 DO I 90 * 11 DUP DUP RDIN WRTO 12 90 + . LOOP ; 13 : DISKCOPY CR MS1 CR 8 %COPY ; 14 15 BASE ! ;S SCR # 38 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 39 0 ( ** ASSEMBLER ** IN FORTH ) 1 2 ( ASSEMBLER COMFORMS TO THE 3 ( fig "INSTALLATION GUIDE" WITH 4 ( THE FOLLOWING EXCEPTIONS: 5 6 ( SHIFTS ARE: "XXX.A" FOR A-REG. 7 ( SHIFTS. 8 ( CONDITIONAL BRANCHES ARE 9 ( PATTERNED AFTER THE BRANCH OP- 10 ( CODES: "IFEQ," IS USED IN- 11 ( STEAD OF "0= IF," FOR BETTER 12 ( CLARITY. SEE SCREEN 43. 13 14 15 --> SCR # 40 0 ( ASSEMBLER ) 1 2 VOCABULARY ASSEMBLER IMMEDIATE 3 4 BASE @ HEX 5 6 : CODE ~[COMPILE] ASSEMBLER 7 CREATE SMUDGE ; 8 9 ASSEMBLER DEFINITIONS 10 11 : SB <BUILDS C, DOES> @ C, ; 12 ( SINGLE BYTE OPERATORS) 13 14 15 --> SCR # 41 0 ( ASSEMBLER ) 1 2 00 SB BRK, 18 SB CLC, D8 SB CLD, 3 58 SB CLI, B8 SB CLV, CA SB DEX, 4 88 SB DEY, E8 SB INX, C8 SB INY, 5 EA SB NOP, 48 SB PHA, 08 SB PHP, 6 68 SB PLA, 28 SB PLP, 40 SB RTI, 7 60 SB RTS, 38 SB SEC, F8 SB SED, 8 78 SB SEI, A8 SB TAX, BA SB TSX, 9 8A SB TXA, 9A SB TXS, 98 SB TYA, 10 11 0A SB ASL.A, 2A SB ROL.A, 12 4A SB LSR.A, 6A SB ROR.A, 13 14 : NOT 0= ; ( REVERSE LOGICAL ) 15 : 0= 1 ; ( PUSH A TRUE ) --> SCR # 42 0 ( ASSEMBLER ) 1 2 : 3BY <BUILDS C, DOES> @ C, , ; 3 4 4C 3BY JMP, 6C 3BY JMP(), 5 20 3BY JSR, 6 7 : ?ER5 5 ?ERROR ; 8 9 : IF. <BUILDS C, DOES> C@ C, 0 10 C, HERE ; 11 : THEN, DUP HERE SWAP - DUP 12 7F > ?ER5 DUP -80 < ?ER5 13 SWAP -1 + C! ; IMMEDIATE 14 : ENDIF, ~[COMPILE] THEN, ; IMMEDIATE 15 --> SCR # 43 0 ( ASSEMBLER ) 1 2 30 IF. IFPL, ( BPL ) 3 10 IF. IFMI, ( BMI ) 4 70 IF. IFVC, ( BVC ) 5 50 IF. IFVS, ( BVS ) 6 B0 IF. IFCC, ( BCC ) 7 90 IF. IFCS, ( BCS ) 8 F0 IF. IFNE, ( BNE ) 9 D0 IF. IFEQ, ( BEQ ) 10 11 : BEGIN, HERE ; IMMEDIATE 12 : END, IF D0 ELSE F0 THEN C, 13 HERE 1+ - DUP 14 -80 < ?ER5 C, ; IMMEDIATE 15 : UNTIL, ~[COMPILE] END, ; IMMEDIATE --> SCR # 44 0 ( ASSEMBLER ) 1 2 0D VARIABLE MODE ( ABS. MODE ) 3 4 : MODE= MODE @ = ; ( CK MODE ) 5 : 256< DUP 100 ( HEX) U< ; 6 : MODEFIX 256< IF -08 MODE +! 7 THEN ; 8 ( MODE=MODE-8 IF ADR<256 ) 9 : CKMODE MODE= IF MODEFIX 10 THEN ; 11 : M0 <BUILDS C, DOES> SWAP 12 0D CKMODE 1D CKMODE SWAP 13 C@ MODE @ OR C, 256< IF 14 C, ELSE , THEN 0D MODE ! ; 15 DECIMAL 46 LOAD ;S SCR # 45 0 B jDISKNAMEDAT 1 2 APX-20029fig-FORTH 1.1 Rev. 2.0Patrick L. Mullarky01/15/821 3 J 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 46 0 ( ASSEMBLER ) 1 HEX 2 : X) 01 MODE ! ; ( ~[ADDR,X] ) 3 : # 09 MODE ! ; ( IMMEDIATE ) 4 : )Y 11 MODE ! ; ( ~[ADDR],Y ) 5 : ,X 1D MODE ! ; ( ADDR,X ) 6 : ,Y 19 MODE ! ; ( ADDR,Y ) 7 8 9 00 M0 ORA, 20 M0 AND, 40 M0 EOR, 10 60 M0 ADC, 80 M0 STA, A0 M0 LDA, 11 C0 M0 CMP, E0 M0 SBC, 12 13 : BIT, 256< IF 24 C, C, ELSE 14 2C C, , THEN ; 15 --> SCR # 47 0 ( ASSEMBLER ) 1 2 : STOREADD C, 256< IF C, ELSE , 3 THEN 0D MODE ! ; 4 5 : ZPAGE OVER 100 < IF F7 AND 6 THEN ; 7 : XYMODE MODE @ 19 = MODE @ 1D 8 = OR ; 9 : M1 <BUILDS C, DOES> C@ MODE @ 10 1D = IF 10 ELSE 0 THEN OR 11 ZPAGE STOREADD ; 12 13 0E M1 ASL, 2E M1 ROL, 4E M1 LSR, 14 6E M1 ROR, CE M1 DEC, EE M1 INC, 15 --> SCR # 48 0 ( ASSEMBLER ) 1 2 : OPCODE C@ ZPAGE XYMODE IF 10 3 OR THEN ; 4 : M2 <BUILDS C, DOES> OPCODE 5 MODE @ 9 = IF 4 - THEN 6 STOREADD ; 7 8 AC M2 LDY, AE M2 LDX, 9 CC M2 CPY, EC M2 CPX, 10 11 : M3 <BUILDS C, DOES> OPCODE 12 STOREADD ; 13 14 8C M3 STY, 8E M3 STX, 15 --> SCR # 49 0 ( END OF ASSEMBLER ) 1 2 FORTH DEFINITIONS 3 4 5 LATEST 0C +ORIGIN ! ( NTOP ) 6 7 HERE 1C +ORIGIN ! ( FENCE ) 8 9 HERE 1E +ORIGIN ! ( DP ) 10 11 12 13 14 15 BASE ! ;S SCR # 50 0 ( COLOR COMMANDS ) 1 BASE @ HEX 2 : SETCOLOR 2 * SWAP 10 * OR SWAP 3 02C4 ( COLPF0 ) + C! ; 4 : SE. SETCOLOR ; ( ALIAS ) 5 6 ( REGISTER#-3, COLOR-2, LUM-1 7 8 ( 0-3 0-F 0-7 9 10 --> 11 12 13 14 15 SCR # 51 0 ( GRAPHICS COMMANDS ) 1 E456 CONSTANT CIO 2 1C VARIABLE MASK 3 340 CONSTANT IOCX 4 53 VARIABLE SNAME 5 6 CODE GR. 1 # LDA, GFLAG STA, 7 XSAVE STX, 0 ,X LDA, 8 # 30 LDX, IOCX 0B + ,X STA, 9 # 3 LDA, IOCX 2 + ,X STA, 10 SNAME FF AND # LDA, IOCX 4 + ,X 11 STA, SNAME 100 / # LDA, 12 IOCX 5 + ,X STA, MASK LDA, 13 IOCX 0A + ,X STA, CIO JSR, 14 XSAVE LDX, 0 # LDY, POP JMP, 15 --> SCR # 52 0 ( GRAPHICS COMMANDS ) 1 2 CODE &GR XSAVE STX, # 30 LDX, 3 # C LDA, IOCX 2 + 4 ,X STA, CIO JSR, 5 XSAVE LDX, 0 # LDA, 6 GFLAG STA, NEXT JMP, 7 8 : XGR &GR 0 GR. &GR ; 9 ( EXIT GRAPHICS MODE ) 10 11 --> 12 13 14 15 SCR # 53 0 ( GRAPHICS I/O ) 1 2 CODE CPUT 0 ,X LDA, PHA, 3 XSAVE STX, # 30 LDX, 4 # B LDA, IOCX 2 + ,X STA, TYA, 5 IOCX 8 + ,X STA, IOCX 9 + ,X 6 STA, PLA, CIO JSR, XSAVE LDX, 7 POP JMP, 8 9 54 CONSTANT ROWCRS 10 55 CONSTANT COLCRS 11 12 : POS ROWCRS C! COLCRS ! ; 13 : PLOT POS CPUT ; 14 15 --> SCR # 54 0 ( GRAPHICS I/O ) 1 2 : GTYPE -DUP IF OVER + SWAP 3 DO I C@ CPUT LOOP ELSE 4 DROP ENDIF ; 5 6 : (G") R COUNT DUP 1+ R> + >R 7 GTYPE ; 8 9 : G" 22 STATE @ IF COMPILE (G") 10 WORD HERE C@ 1+ ALLOT 11 ELSE WORD HERE COUNT GTYPE 12 ENDIF ; IMMEDIATE 13 14 15 --> SCR # 55 0 ( DRAW, FIL ) 1 2 2FB CONSTANT ATACHR 3 2FD CONSTANT FILDAT 4 5 CODE GCOM XSAVE STX, 0 ,X LDA, 6 # 30 LDX, IOCX 2 + ,X STA, 7 CIO JSR, XSAVE LDX, POP JMP, 8 9 : DRAW POS ATACHR C! 11 GCOM ; 10 11 : FIL FILDAT C! 12 GCOM ; 12 13 14 BASE ! ;S 15 SCR # 56 0 ( SOUND COMMANDS ) 1 BASE @ HEX 2 3 D208 CONSTANT AUDCTL 4 D200 CONSTANT AUDBASE 5 6 : SOUND ( CH# FREQ DIST VOL --- ) 7 3 DUP 0D20F C! 232 C! 8 SWAP 16 * + ROT DUP + AUDBASE + 9 ROT OVER C! 1+ C! ; 10 11 : FILTER! AUDCTL C! ; 12 ( N --- ) 13 14 15 BASE ! ;S SCR # 57 0 ( GRAPHICS TESTS ) 1 2 : BOX 0 10 10 PLOT 1 50 10 DRAW 3 1 50 25 DRAW 1 10 25 DRAW 4 1 10 10 DRAW ; 5 6 : FBOX XGR 5 GR. BOX 7 10 25 POS 2 FIL ; 8 9 10 11 12 13 14 15 SCR # 58 0 ( DOS OBJECT READER ) 1 2 BASE @ HEX 3 4 0 VARIABLE BLOCK# 0 VARIABLE BYTES 0 VARIABLE BYTPTR 5 0 VARIABLE ADDRSS 0 VARIABLE #BYTES 6 : GETCOUNT 7F + C@ 7F AND BYTES ! 0 BYTPTR ! ; 7 : FNEXTBLK 7D + DUP C@ 100 * SWAP 1+ C@ + 3FF AND 1 - ; 8 : LINKBLOCK FNEXTBLK 9 DUP BLOCK# ! DUP 0 > IF BLOCK THEN ; 10 : BLK-CK BYTES @ 0= IF BLOCK# @ BLOCK LINKBLOCK 11 GETCOUNT THEN ; 12 : NEXTBYTE BLK-CK -1 BYTES +! BYTPTR @ 1 BYTPTR +! 13 BLOCK# @ BLOCK + C@ ; 14 : NEXTWORD NEXTBYTE NEXTBYTE 100 * + ; 15 --> SCR # 59 0 ( DOS OBJECT READER ) 1 2 : ADRCALC NEXTWORD DUP ADDRSS ! NEXTWORD SWAP - 1+ #BYTES ! ; 3 4 : BLOCKSET DUP BLOCK# ! BLOCK GETCOUNT ; 5 6 : LOADOBJ BLOCKSET NEXTWORD 1+ IF CR ." Not an Object file" 7 CR QUIT THEN 8 BEGIN 9 ADRCALC 10 #BYTES @ 0 DO NEXTBYTE ADDRSS @ C! 1 ADDRSS +! LOOP 11 BLOCK# @ BLOCK FNEXTBLK 12 1+ 0= BYTES @ 0= AND END ; 13 14 15 BASE ! ;S SCR # 60 0 ( FLOATING POINT WORDS ) 1 BASE @ HEX 2 : FDROP DROP DROP DROP ; 3 : FDUP >R >R DUP R> DUP ROT 4 SWAP R ROT ROT R> ; 5 CODE FSWAP 6 XSAVE STX, # 6 LDY, 7 BEGIN, 0 ,X LDA, PHA, INX, DEY, 8 0= END, XSAVE LDX, # 6 LDY, 9 BEGIN, 6 ,X LDA, 0 ,X STA, INX, 10 DEY, 0= END, XSAVE LDX, # 6 LDY, 11 BEGIN, PLA, 0B ,X STA, DEX, DEY, 12 0= END, XSAVE LDX, NEXT JMP, 13 14 XSAVE 100 * 86 + CONSTANT XSAV 15 : XS, XSAV , ; --> SCR # 61 0 ( FLOATING POINT WORDS ) 1 CODE FOVER DEX, DEX, DEX, 2 DEX, DEX, DEX, XSAVE STX, 3 # 6 LDY, BEGIN, 0C ,X LDA, 4 0 ,X STA, INX, DEY, 0= END, 5 XSAVE LDX, NEXT JMP, 6 7 XSAVE 100 * A6 + CONSTANT XLD 8 : XL, XLD , ; 9 10 CODE AFP XS, D800 JSR, XL, NEXT JMP, 11 CODE FASC XS, D8E6 JSR, XL, NEXT JMP, 12 CODE IFP XS, D9AA JSR, XL, NEXT JMP, --> 13 14 15 SCR # 62 0 ( FLOATING POINT WORDS ) 1 2 CODE FPI XS, D9D2 JSR, XL, NEXT JMP, 3 CODE FADD XS, DA66 JSR, XL, NEXT JMP, 4 CODE FSUB XS, DA60 JSR, XL, NEXT JMP, 5 CODE FMUL XS, DADB JSR, XL, NEXT JMP, 6 CODE FDIV XS, DB28 JSR, XL, NEXT JMP, 7 CODE FLG XS, DECD JSR, XL, NEXT JMP, 8 CODE FLG10 XS, DED1 JSR, XL, NEXT JMP, 9 CODE FEX XS, DDC0 JSR, XL, NEXT JMP, 10 CODE FEX10 XS, DDCC JSR, XL, NEXT JMP, 11 CODE FPOLY XS, DD40 JSR, XL, NEXT JMP, 12 --> 13 14 15 SCR # 63 0 ( FLOATING POINT WORDS ) 1 2 D4 CONSTANT FR0 3 E0 CONSTANT FR1 4 FC CONSTANT FLPTR 5 F3 CONSTANT INBUF 6 F2 CONSTANT CIX 7 8 --> 9 10 11 12 13 14 15