( FORTH Drive build script ) EDITOR 3 CLEAR 0 NEW ********************** fig-FORTH MODEL ********************** Through the courtesy of FORTH INTEREST GROUP P. O. BOX 1105 SAN CARLOS, CA. 94070 RELEASE 1 WITH COMPILER SECURITY AND VARIABLE LENGTH NAMES Further distribution must include the above notice. FLUSH 4 CLEAR 0 NEW ( Error messages ) Empty stack Dictionary full Has incorrect address mode Isn't unique Disc range ? Full stack Disc error ! FORTH INTEREST GROUP MAY 1, 1979 FLUSH 5 CLEAR 0 NEW ( 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 FLUSH 1 CLEAR 0 NEW ( PRELIMINARY GRAPHICS WORDS PTC, CLINE ,GON ,GOFF, GCLS ) DECIMAL : GTC 10 @ 512 - 32 / 3 C@ ; ( GTC --- y x cursor pos'n) : PTC DUP 03 C! OUT ! 32 * 512 + 10 ! ; ( y x --- put cursor) : CLINE 0 PTC 10 @ 1+ 31 BLANKS ; ( y --- clear line y) : IN# BLK @ >R IN @ >R 0 BLK ! QUERY BL WORD HERE NUMBER DROP R> IN ! R> BLK ! ; HEX : GON BFF0 C@ DROP ; ( CHUNKY GRAPHICS ON) : GOFF 0 BFF3 C! ; ( AND OFF ) : GCLS GON 200 200 ERASE GOFF ; DECIMAL ( CLS IN GRAPHICS) : GSET CHUNKS OR SWAP C! ; : GCLR CHUNKS -1 XOR AND SWAP C! ; : ?GPT CHUNKS AND SWAP DROP ; : PICK SP@ SWAP 2 * + @ ; DECIMAL ;S FLUSH 2 CLEAR 0 NEW ( RANDOM NUMBER SUPPORT WANB 15AUG81 ) DECIMAL 25 VARIABLE VRND ( RANDOM NUMBER VARIABLE) : PRND ( PRIMITIVE OPERATION) 32763 M* DROP ; : RND ( LEAVES NEW RND INTEGER) VRND DUP @ PRND PRND DUP ROT ! 32767 AND ; : SRND ( SCALED RANDOM NO. N --- M . M=RANDOM NUMBER) RND 32767 */ ; ( BETWEEN 0 AND N) : RANDOMISE ( INITIAL SCRAMBLE N --- ) VRND ! 100 0 DO RND DROP LOOP ; ;S FLUSH 6 CLEAR 0 NEW ( SCREEN COPY UTILITY B.Graham 2019 ) ( source dest BCOPY --- copy block ) ( source dest SCOPY --- copy screen ) : BCOPY BLOCK UPDATE SWAP BLOCK SWAP B/BUF CMOVE ; : SCOPY B/SCR * SWAP B/SCR * SWAP B/SCR 0 DO OVER I + OVER I + BCOPY LOOP DROP DROP ; ;S FLUSH 9 CLEAR 0 NEW ( Cursor on and Cursur off routines ) HEX : COFF [ 2920 , 4CF8 , 0442 , ] ; HERE 2 - DP ! LATEST PFA DUP CFA ! : CON [ 2620 , 4CF8 , 0442 , ] ; HERE 2 - DP ! LATEST PFA DUP CFA ! DECIMAL ;S FLUSH 10 CLEAR 0 NEW ( BREAKOUT/FIGFORTH FOR MICROTAN AFTER MMSFORTH/BREAKFORTH ) ( USE "4" FOR LEFT; "6" FOR RIGHT ANDY BIGGS AUG 81 ) : TASK ; 600 @ RANDOMISE -2 CONSTANT -2 -1 CONSTANT -1 0 VARIABLE BSPEED 0 VARIABLE SPVAR 0 VARIABLE SCORE 0 VARIABLE XPOS 0 VARIABLE YPOS 1 VARIABLE PPOS 1 VARIABLE YDIR 1 VARIABLE XDIR 0 VARIABLE BEST : INIT GOFF CLS 0 CLINE ." SPEED (1-10, 1 FASTEST) " IN# 1 MAX 10 MIN 5 * BSPEED ! 0 CLINE ." HOW MANY BALLS? " IN# GCLS GON 608 32 255 FILL 64 16 DO I 0 GSET I 1 GSET I 62 GSET I 63 GSET LOOP 704 128 255 FILL 0 SCORE ! GOFF 0 CLINE ." BREAKOUT IN FORTH" 1 CLINE ." BEST: " BEST ? 2 CLINE ." SCORE: 0" 2 16 PTC ." BALL:" ; : PCLR PPOS @ 992 + 3 0 FILL ; : PSET PPOS @ 992 + 3 3 FILL ; --> FLUSH 11 CLEAR 0 NEW ( BREAKOUT 2 OF 6 WANB AUG 81) : PADDLE 01 C@ 52 = IF 0 1 C! PCLR -1 PPOS @ + 1 MAX PPOS ! PSET ENDIF 01 C@ 54 = IF 0 1 C! PCLR 1 PPOS @ + 28 MIN PPOS ! PSET ENDIF ; : CFUDGE HERE 2 - DP ! LATEST PFA DUP CFA ! ; HEX : BOPON [ B586 , 0020 , A6F0 , 4CB5 , 0442 , ] ; CFUDGE : BOPOFF [ A958 , 8D00 , BFCB , C28D , 4CBF , 0442 , ] ; CFUDGE DECIMAL : XCHK XPOS @ 2 < IF XDIR @ MINUS XDIR ! 2 XPOS ! BOPON ENDIF XPOS @ 61 > IF XDIR @ MINUS XDIR ! 61 XPOS ! BOPON ENDIF ; --> FLUSH 12 CLEAR 0 NEW ( BREAKOUT PART 3 WANB AUG81 ) : YCHK YPOS @ 16 < IF 1 YDIR ! 16 YPOS ! 1 SPVAR C! BOPON ENDIF YPOS @ 36 < IF SPVAR C@ 4 MIN SPVAR C! ENDIF YPOS @ 31 < IF SPVAR C@ 3 MIN SPVAR C! ENDIF YPOS @ 27 < IF SPVAR C@ 2 MIN SPVAR C! ENDIF ; : #CASE: SWAP 2 * + @ EXECUTE ; #CASE: GETDIR -2 -1 -1 1 1 2 ; : PCHK 0 YPOS @ 58 > IF 59 YPOS ! XPOS @ PPOS @ 2 * - DUP -1 > OVER 6 < AND IF -1 YDIR ! BOPON GETDIR XDIR ! ELSE DROP 1+ ENDIF ENDIF ; --> FLUSH 13 CLEAR 0 NEW ( BREAKOUT PART 4 WANB AUG 81 ) : CLR XPOS @ 2 - 252 AND 2+ DUP 4 + SWAP DO YPOS @ I GCLR LOOP YPOS @ 40 - ABS SCORE +! 2 7 PTC GOFF SCORE ? BOPON GON YDIR @ MINUS YDIR ! ; : BALLCHK YDIR @ YPOS +! XDIR @ XPOS +! XCHK YCHK PCHK YPOS @ XPOS @ ?GPT IF CLR ENDIF ; : BALL YPOS @ XPOS @ GCLR BALLCHK DUP 0= IF YPOS @ XPOS @ GSET BOPOFF ENDIF ; : GAMECHK SCORE @ 2040 MOD 0= IF 704 128 255 FILL ENDIF ; : DELAY BSPEED C@ SPVAR C@ * 0 DO LOOP ; --> FLUSH 14 CLEAR 0 NEW ( BREAKOUT PART5 WANB AUG 81 ) : BREAKOUT BEGIN INIT GON 0 PSET DO 2000 BSPEED C@ / 0 DO DELAY PADDLE LOOP 2 22 PTC GOFF I 1+ . GON 5 SPVAR C! 2 SRND 1 = IF 1 ELSE -1 ENDIF XDIR ! 1 YDIR ! 58 SRND 2+ XPOS ! 40 YPOS ! BEGIN 5 0 DO PADDLE LOOP BALL GAMECHK DELAY UNTIL BOPOFF LOOP SCORE @ BEST @ MAX BEST ! 11 6 PTC GOFF ." PLAY AGAIN? Y/N " 0 BEGIN DROP KEY DUP 89 = DUP ROT 78 = OR UNTIL 0= UNTIL ; ;S FLUSH 20 CLEAR 0 NEW ( TEXT,LINE ) FORTH DEFINITIONS HEX : TEXT HERE C/L 1+ BLANKS WORD HERE PAD C/L 1+ CMOVE ; : LINE DUP FFF0 AND 17 ?ERROR SCR @ (LINE) DROP ; : 2DROP DROP DROP ; : 2DUP OVER OVER ; : 2SWAP ROT >R ROT R> ; DECIMAL --> FLUSH 21 CLEAR 0 NEW ( LINE EDITOR ) VOCABULARY EDITOR IMMEDIATE HEX : WHERE DUP B/SCR / DUP SCR ! ." SCR # " DECIMAL . SWAP C/L /MOD C/L * ROT BLOCK + CR C/L TYPE CR HERE C@ - SPACES 5E EMIT [COMPILE] EDITOR QUIT ; EDITOR DEFINITIONS : #LOCATE R# @ C/L /MOD ; : #LEAD #LOCATE LINE SWAP ; : #LAG #LEAD DUP >R + C/L R> - ; : -MOVE LINE C/L CMOVE UPDATE ; --> FLUSH 22 CLEAR 0 NEW ( LINE EDITING COMMANDS ) : H LINE PAD 1+ C/L DUP PAD C! CMOVE ; : E LINE C/L BLANKS UPDATE ; : S DUP 1 - 0E DO I LINE I 1+ -MOVE -1 +LOOP E ; : D DUP H 0F DUP ROT DO I 1+ LINE I -MOVE LOOP E ; : M R# +! CR SPACE #LEAD TYPE 5F EMIT #LAG TYPE #LOCATE . DROP ; : T DUP C/L * R# ! H 0 M ; : L SCR @ LIST 0 M ; : R PAD 1+ SWAP -MOVE ; : P 1 TEXT R ; : I DUP S R ; : TOP 0 R# ! ; : CLEAR SCR ! 10 0 DO FORTH I EDITOR E LOOP ; : COPY B/SCR * OFFSET @ + SWAP B/SCR * B/SCR OVER + SWAP DO DUP FORTH I BLOCK 2 - ! 1+ UPDATE LOOP DROP FLUSH ; --> FLUSH 23 CLEAR 0 NEW ( STRING MATCH FOR EDITOR ) : -TEXT SWAP -DUP IF OVER + SWAP DO DUP C@ FORTH I C@ - IF 0= LEAVE ELSE 1+ THEN LOOP ELSE DROP 0= THEN ; : MATCH >R >R 2DUP R> R> 2SWAP OVER + SWAP DO 2DUP FORTH I -TEXT IF >R 2DROP R> - I SWAP - 0 SWAP 0 0 LEAVE THEN LOOP 2DROP SWAP 0= SWAP ; --> FLUSH 24 CLEAR 0 NEW ( STRING EDITING COMMANDS ) : 1LINE #LAG PAD COUNT MATCH R# +! ; : FIND BEGIN 3FF R# @ < IF TOP PAD HERE C/L 1+ CMOVE 0 ERROR ENDIF 1LINE UNTIL ; : DELETE >R #LAG + FORTH R - #LAG R MINUS R# +! #LEAD + SWAP CMOVE R> BLANKS UPDATE ; : N FIND 0 M ; : F 1 TEXT N ; : B PAD C@ MINUS M ; : X 1 TEXT FIND PAD C@ DELETE 0 M ; : TILL #LEAD + 1 TEXT 1LINE 0= 0 ?ERROR #LEAD + SWAP - DELETE 0 M ; --> FLUSH 25 CLEAR 0 NEW ( EDITOR EXTENSIONS KRH FEB 81) HEX : ENTER? OVER = ; : ENTER QUERY 1 TEXT ; : NULL? TIB @ C@ 0= ; : .BS 7F EMIT ; DECIMAL : NEW FORTH 16 0 DO CR I 3 .R SPACE I ENTER? IF ENTER NULL? IF .BS I SCR @ .LINE ELSE I EDITOR R FORTH 1+ ENDIF ELSE I SCR @ .LINE ENDIF LOOP DROP ; : UNDER FORTH 1+ 16 0 DO CR I 3 .R SPACE I ENTER? IF ENTER NULL? IF .BS I SCR @ .LINE ELSE I EDITOR I FORTH 1+ ENDIF ELSE I SCR @ .LINE THEN LOOP DROP ; DECIMAL --> FLUSH 26 CLEAR 0 NEW ( STRING EDITING COMMANDS ) : C 1 TEXT PAD COUNT #LAG ROT OVER MIN >R FORTH R R# +! R - >R DUP HERE R CMOVE HERE #LEAD + R> CMOVE R> CMOVE UPDATE 0 M ; FORTH DEFINITIONS DECIMAL LATEST 12 +ORIGIN ! HERE 28 +ORIGIN ! HERE 30 +ORIGIN ! ' EDITOR 6 + 32 +ORIGIN ! HERE FENCE ! CR ." EDITOR LOADED" CR ;S FLUSH 30 CLEAR 0 NEW ( ASSEMBLER FOR 6502 WITH BRANCHES AND STRUCTURES WANB82 ) FORTH DEFINITIONS VOCABULARY ASSEMBLER IMMEDIATE HEX ASSEMBLER DEFINITIONS ' ASSEMBLER CFA ' ;CODE 8 + ! 23 CONSTANT $MB 04 CONSTANT $MM : $GM $MB 0F AND 4 * ; : $GB $MB F0 AND 10 / ; : $CB C, HERE 1+ - C, ; : $!M ' $MM ! ' $MB ! ; : $AZ $MB 0D AND 10 OR ' $MB ! ; : $SD 23 04 $!M ; : $CA DUP FF00 AND 0= ; : $CC C, 3 AND -DUP IF 2 AND IF , ELSE C, THEN THEN ; : $ME $SD [COMPILE] FORTH 3 ERROR ; : $PT $GB SWAP $GM + $CC $SD ; : $CM $MM AND 0= IF $ME ENDIF ; : $DC $GM DUP 0C = SWAP 1C = OR IF $CA IF $AZ ENDIF ENDIF ; : $$M DUP C@ SWAP 1+ C@ $!M ; : $IM C@ C, ; : $BR C@ $CB ; --> FLUSH 31 CLEAR 0 NEW ( ADDRESSING MODES, MNEMONIC DEFINING WORDS ) 01 02 $$M .A 02 10 $$M # 08 27 $$M ,X 10 2B $$M () 20 26 $$M ,Y 40 14 $$M )Y 80 10 $$M X) : m1 DUP C@ >R 1+ C@ $CM R 40 = R 14 = OR 0= IF ( NOT JMP OR JSR ) $DC ENDIF $MM 2 = IF 12 ' $MB ! ENDIF R> $PT ; : m2 DUP C@ >R 1+ C@ $CM R A2 = R 82 = OR IF $GM 18 = IF 27 40 $!M ENDIF ENDIF R 82 = R 80 = OR $GM 1C = AND IF $CA IF $AZ ELSE $ME ENDIF ELSE $DC ENDIF R> $PT ; EE 61 m1 ADC, EE 21 m1 AND, EE C1 m1 CMP, EE 41 m1 EOR, EE A1 m1 LDA, EE 01 m1 ORA, EE E1 m1 SBC, EC 81 m1 STA, 14 40 m1 JMP, 04 14 m1 JSR, --> FLUSH 32 CLEAR 0 NEW ( ASSEMBLER MNEMONICS AND CONSTANTS ) 0D 02 m2 ASL, 0D 42 m2 LSR, 0D 22 m2 ROL, 0D 62 m2 ROR, 06 E0 m2 CPX, 06 C0 m2 CPY, 0C E2 m2 INC, 0C C2 m2 DEC, 26 A2 m2 LDX, 0E A0 m2 LDY, 24 82 m2 STX, 0C 80 m2 STY, 04 20 m2 BIT, 00 $IM BRK, 18 $IM CLC, D8 $IM CLD, 58 $IM CLI, B8 $IM CLV, CA $IM DEX, 88 $IM DEY, E8 $IM INX, C8 $IM INY, EA $IM NOP, 48 $IM PHA, 08 $IM PHP, 68 $IM PLA, 28 $IM PLP, 40 $IM RTI, 60 $IM RTS, 38 $IM SEC, F8 $IM SED, 78 $IM SEI, AA $IM TAX, A8 $IM TAY, 98 $IM TYA, BA $IM TSX, 8A $IM TXA, 9A $IM TXS, 90 $BR BCC, B0 $BR BCS, F0 $BR BEQ, 30 $BR BMI, D0 $BR BNE, 10 $BR BPL, 50 $BR BVC, 70 $BR BVS, : EQU CONSTANT ; B0 EQU CS F0 EQU 0= 30 EQU 0< 70 EQU VS A6 EQU N AE EQU IP B1 EQU W B3 EQU UP B5 EQU XSAVE 442 EQU NEXT 554 EQU POP 43B EQU PUSH 46A EQU SETUP 43D EQU PUT 762 EQU PUSH0A 552 EQU POPTWO --> FLUSH 33 CLEAR 0 NEW ( PSEUDO-STRUCTURES,LOOPS, LABELS WANB82 ) : NOT 20 XOR ; : BEGIN, HERE ; : UNTIL, NOT $CB ; : IF, NOT C, HERE 0 C, ; : ENDIF, HERE OVER 1+ - SWAP C! ; : ELSE, CLV, 50 C, HERE 0 C, SWAP ENDIF, ; : AGAIN, CLV, 50 $CB ; : WHILE, IF, ; : REPEAT, >R AGAIN, R> ENDIF, ; : ;C CURRENT @ CONTEXT ! ?EXEC ?CSP SMUDGE ; IMMEDIATE : KILL [COMPILE] ' NFA [ HERE 40 + ] LITERAL OVER OVER 1+ U< IF CR ." SYM ERR" CR DROP DROP ELSE OVER SWAP 2 - ! PFA LFA @ CONTEXT @ ! ENDIF ; 2 ALLOT : LABEL CURRENT @ HERE DEFINITIONS [ LATEST 2 - ] LITERAL DUP @ DP ! OVER CONSTANT HERE SWAP ! DP ! CURRENT ! ; HERE LATEST 2 - ! 100 ALLOT ( this must be the last entry in VOCAB ASSEMBLER !!! ) --> FLUSH 34 CLEAR 0 NEW ( CODE, ;C , AND TIDYING UP WANB 82 ) FORTH DEFINITIONS DECIMAL : CODE ( create assembly level word ) ?EXEC CREATE [COMPILE] ASSEMBLER ASSEMBLER $SD !CSP ; IMMEDIATE ( make it unforgettable ) LATEST 12 +ORIGIN ! ( TOP NFA ) HERE 28 +ORIGIN ! ( FENCE ) HERE 30 +ORIGIN ! ( DP ) ' ASSEMBLER 6 + 32 +ORIGIN ! ( VOCLINK ) HERE FENCE ! CR ." ASSEMBLER LOADED" CR ;S ( COPYRIGHT 1982 TANGERINE COMPUTER SYSTEMS LTD. ) ( ALL RIGHTS RESERVED ) ( SEE FORTH USER GUIDE FOR COPYRIGHT DETAILS ) FLUSH 7 CLEAR 0 NEW ( ARRAY BUILDING WORDS- 1 DIM ONLY WANB 15AUG81) : 1ARRAY ( 1-D ARRAY WITH SIZE AS FIRST IN PFA. LEAVES ) 2+ SWAP 2 * + ; : 1CARRAY 2+ + ; ( CHAR EQUIVALENT) ( IF RANGE CHECK REQUIRED FOR 1ARRAY, SUBSTITUTE THIS VERSION) ( : 1ARRAY OVER OVER @ U< ) ( IF 2+ SWAP 2 * + ) ( ELSE CR ." ARRAY ERROR IN " >R R 2 - NFA ID. . R ? CR ) ( R> 2+ ENDIF ) ( ON ERROR THIS RETURNS ADDRESS OF ZEROTH ELEMENT, PRINTS ) ( WARNING MSG, ILLEGAL VARIABLE, AND ARRAY SIZE ) ;S FLUSH 8 CLEAR 0 NEW ( CASE - MACHINE CODE ADJUSTED FOR FORTH-R) CREATE (OF) HEX E8E8 , B538 , D5FE , D000 , B506 , D5FF , F001 , 4C03 , 0539 , E8E8 , 604C , 0552, SMUDGE DECIMAL : CASE ?COMP CSP @ !CSP 4 ; IMMEDIATE : OF 4 ?PAIRS COMPILE (OF) HERE 0 , 5 ; IMMEDIATE : ENDOF 5 ?PAIRS COMPILE BRANCH HERE 0 , SWAP 2 [COMPILE] ENDIF 4 ; IMMEDIATE : ENDCASE 4 ?PAIRS COMPILE DROP BEGIN SP@ CSP @ = 0= WHILE 2 [COMPILE] ENDIF REPEAT CSP ! ; IMMEDIATE ;S FLUSH 0 CLEAR 0 NEW ( Screen 0 This directory ) ( Screen 1 Graphics extensions and PICK ) ( Screen 2 Random Number extensions ) ( Screen 3 Copyright Message ) ( Screen 4 to 5 Error Messages ) ( Screen 6 Block and Screen copy utility ) ( Screen 7 Tanforth Array Extension ) ( Screen 8 Tanforth Case Extension ) ( Screen 9 Cursor on and off ) ( Screen 10 to 14 Breakout game (needs extensions) ) ( Screen 20 to 26 Editor ) ( Screen 30 to 34 Assembler ) FLUSH