# 7 ( LOADED-BY EDIT POLYED ASM ) FORTH DEFINITIONS DECIMAL : LOADED-BY @ LOAD ; 34 LOADED-BY EDIT ( fig-FORTH ) 15 LOADED-BY POLYED ( poly-FORTH) 42 LOADED-BY ASM ( ASSEMBLER) PAGE CR ." EDIT for fig-FORTH editor" CR CR ." POLYED for poly-FORTH editor" CR CR ." ASM for 8080-Z80 assembler" CR CR 1 DENSITY ! CR CR ." DENSITY set for double " CR CR ;S # 34 ( LOAD fig-FORTH EDITOR ) 18 LOAD 19 LOAD ( COMMON BLOCKS ) 35 LOAD 36 LOAD 37 LOAD 38 LOAD 39 LOAD 40 LOAD 41 LOAD FORTH DEFINITIONS DECIMAL ;S # 35 ( fig-EDITOR H E S D ) EDITOR DEFINITIONS DECIMAL : H ( HOLD NUMBERED LINE AT PAD) LINE PAD 1+ C/L DUP PAD C! CMOVE ; : E ( ERASE LINE-1 WITH BLANKS) LINE C/L BLANKS UPDATE ; : S ( SPREAD MAKING LINE-1 BLANK) DUP 1 - ( LIMIT ) 19 ( FIRST ) DO I LINE I 1+ -MOVE -1 +LOOP E ; : D ( DELETE LINE-1, BUT HOLD IN PAD ) DUP EDITOR H 20 DUP ROT DO I 1+ LINE I -MOVE LOOP E ; ;S # 36 ( fig-EDITOR M T L R ) EDITOR DEFINITIONS HEX : M ( MOVE CURSOR BY SIGNED AMOUNT-1, PRINT ITS LINE) R# +! CR SPACE #LEAD TYPE FF EMIT #LAG TYPE #LOCATE . DROP QUIT ; : T ( TYPE LINE BY #-1, SAVE ALSO IN PAD ) DUP C/L * R# ! DUP H 0 M ; : L ( RE-LIST SCREEN ) SCR @ LIST 0 M ; DECIMAL ;S # 37 ( fig-EDITOR R P I TOP ) EDITOR DEFINITIONS DECIMAL : R ( REPLACE ON LINE-1, FROM PAD ) PAD 1+ SWAP -MOVE ; : P ( PUT FOLLOWING TEXT ON LINE-1) 1 TEXT R ; : I ( INSERT TEXT FROM PAD ONTO LINE-1) DUP S R ; : TOP ( HOME CURSOR TO TOP LEFT OF SCREEN ) 0 R# ! ; ;S # 38 ( fig-EDITOR CLEAR COPY ) EDITOR DEFINITIONS DECIMAL : CLEAR ( CLEAR SCREEN BY NUMBER-1) DUP SCR ! CLEAR UPDATE ; : COPY ( DUPLICATE SCREEN-2, ONTO SCREEN-1 ) B/SCR * OFFSET @ + SWAP B/SCR * B/SCR OVER + SWAP DO DUP FORTH I BLOCK 2 - ! 1+ UPDATE LOOP DROP FLUSH ; ;S # 39 ( fig-EDITOR advanced facilities ) DECIMAL 16 LOAD 17 LOAD ( MATCH ) EDITOR DEFINITIONS DECIMAL : 1LINE #LAG PAD COUNT MATCH R# +! ; : FIND BEGIN 755 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 ; ;S # 40 ( fig-EDITOR advanced facilities ) EDITOR DEFINITIONS DECIMAL : X 1 TEXT FIND PAD C@ DELETE 0 M ; : TILL #LEAD + 1 TEXT 1LINE 0= 0 ?ERROR #LEAD + SWAP - DELETE 0 M ; : 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 ;S # 41 ( fig-EDITOR NEW UNDER ) EDITOR DEFINITIONS DECIMAL : ENTER? ( START-LINE-2, CURRENT-LINE-1 -- f ) OVER = ; : ENTER ( - ) QUERY 1 TEXT ; : NULL? ( - f ) TIB @ C@ 0= ; : .BS ( - ) 8 EMIT ; : NEW ( START-LINE# -- ) FORTH 21 0 DO CR I 3 .R SPACE I ENTER? IF ENTER NULL? IF .BS I SCR @ .LINE ELSE I EDITOR R FORTH 1+ THEN ELSE I SCR @ .LINE THEN LOOP DROP ; : UNDER ( START-LINE# -- ) FORTH 1+ 21 0 DO CR I 3 .R SPACE I ENTER? IF ENTER NULL? IF .BS I SCR @ .LINE ELSE I EDITOR I FORTH 1+ THEN ELSE I SCR @ .LINE THEN LOOP DROP ; FORTH DEFINITIONS ;S # 42 ( LOADING BLOCK FOR ASSEMBLER ) DECIMAL : ASM ; 43 LOAD 44 LOAD 45 LOAD 46 LOAD 66 LOAD 67 LOAD ( Z80-addition ) FORTH DEFINITIONS DECIMAL ;S # 43 ( ASSEMBLER 1 ) HEX VOCABULARY ASSEMBLER IMMEDIATE ' ASSEMBLER CFA ' ;CODE 08 + ! : CODE ?EXEC CREATE /COMPILE/ ASSEMBLER !CSP ; IMMEDIATE : C; CURRENT @ CONTEXT ! ?EXEC ?CSP SMUDGE ; IMMEDIATE : LABEL ?EXEC 0 VARIABLE SMUDGE -2 ALLOT /COMPILE/ ASSEMBLER !CSP ; IMMEDIATE : 8* DUP + DUP + DUP + ; ASSEMBLER DEFINITIONS 4 CONSTANT H 5 CONSTANT L 2 CONSTANT D 3 CONSTANT E 6 CONSTANT M 6 CONSTANT SP 7 CONSTANT A 6 CONSTANT PSW 0 CONSTANT B 1 CONSTANT C : 1MI C@ C, ; : 2MI C@ + C, ; DECIMAL ;S # 44 ( ASSEMBLER 2 ) ASSEMBLER DEFINITIONS HEX : 3MI C@ SWAP 8* + C, ; : 4MI C@ C, C, ; : 5MI C@ C, , ; 00 1MI NOP 76 1MI HLT F3 1MI DI FB 1MI EI 07 1MI RLC 0F 1MI RRC 17 1MI RAL 1F 1MI RAR E9 1MI PCHL F9 1MI SPHL E3 1MI XTHL EB 1MI XCHG 27 1MI DAA 2F 1MI CMA 37 1MI STC 3F 1MI CMC 80 2MI ADD 88 2MI ADC 90 2MI SUB 98 2MI SBB A0 2MI ANA A8 2MI XRA B0 2MI ORA B8 2MI CMP 09 3MI DAD C1 3MI POP C5 3MI PUSH 02 3MI STAX 0A 3MI LDAX 04 3MI INR 05 3MI DCR 03 3MI INX 0B 3MI DCX C7 3MI RST D3 4MI OUT DB 4MI IN C6 4MI ADI CE 4MI ACI D6 4MI SUI DE 4MI SBI E6 4MI ANI EE 4MI XRI DECIMAL ;S # 45 ( ASSEMBLER 3 ) ASSEMBLER DEFINITIONS HEX F6 4MI ORI FE 4MI CPI 22 5MI SHLD 2A 5MI LHLD 32 5MI STA 3A 5MI LDA C4 5MI CNZ CC 5MI CZ D4 5MI CNC DC 5MI CC E4 5MI CPO EC 5MI CPE F4 5MI CP FC 5MI CM CD 5MI CALL C0 1MI RNZ C8 1MI RZ D0 1MI RNC D8 1MI RC E0 1MI RPO E8 1MI RPE F8 1MI RM C9 1MI RET C3 5MI JMP F0 1MI RP C2 CONSTANT 0= D2 CONSTANT CS E2 CONSTANT PE F2 CONSTANT 0< : NOT 8 + ; : MOV 8* 40 + + C, ; : MVI 8* 6 + C, C, ; : LXI 8* 1+ C, , ; : ENDIF 2 ?PAIRS HERE SWAP ! ; : THEN /COMPILE/ ENDIF ; : IF C, HERE 0 , 2 ; : ELSE 2 ?PAIRS C3 IF ROT SWAP ENDIF 2 ; DECIMAL ;S # 46 ( ASSEMBLER 4 ) ASSEMBLER DEFINITIONS HEX : BEGIN HERE 1 ; : UNTIL SWAP 1 ?PAIRS C, , ; : AGAIN 1 ?PAIRS C3 C, , ; : WHILE IF 2+ ; : REPEAT >R >R AGAIN R> R> 2 - ENDIF ; FORTH DEFINITIONS DECIMAL ;S # 47 ( assembler examples ) FORTH DEFINITIONS HEX ASM ( assembler must be loaded ) CODE >< ( WORD-1 -- SWAPS HI AND LOW BYTE ) H POP L A MOV H L MOV A H MOV NEXT 1 - JMP C; CODE LCFOLD ( addr, number -- ) ( converts lower case to upper case) D POP H POP BEGIN D A MOV E ORA 0= NOT WHILE M A MOV 60 CPI CS NOT IF 20 SUI A M MOV ENDIF D DCX H INX REPEAT NEXT JMP C; DECIMAL ;S # 48 ( assembler example ) ASM ( assembler must be loaded ) FORTH DEFINITIONS HEX 80 CONSTANT CMMD ( command byte ) F0 CONSTANT CMMDPORT ( commandport) F1 CONSTANT STATUSPORT LABEL DELAY ( delay constant in DE don't use the stack ) BEGIN D DCX D A MOV E ORA 0= UNTIL RET C; CODE STATUS ( bit-mask -- ) H POP CMMD A MVI CMMDPORT OUT 1234 D LXI DELAY CALL BEGIN STATUSPORT IN L ANA 0= NOT UNTIL NEXT JMP C; DECIMAL ;S # 49 ( HIPLOT DEMO ) FORTH DEFINITIONS DECIMAL : N 112 ASCII-OUT ; ( NORTH ) : NE 113 ASCII-OUT ; ( NORTHEAST ) : E 114 ASCII-OUT ; ( EAST ) : SE 115 ASCII-OUT ; ( SOUTHEAST ) : S 116 ASCII-OUT ; ( SOUTH ) : SW 117 ASCII-OUT ; ( SOUTHWEST ) : W 118 ASCII-OUT ; ( WEST ) : NW 119 ASCII-OUT ; ( NORTHWEST ) : DELAY 10 0 DO 32 ASCII-OUT LOOP ; : PEN-UP 121 ASCII-OUT DELAY ; : PEN-DOWN 122 ASCII-OUT DELAY ; : NS 0 DO N LOOP ; : NES 0 DO NE LOOP ; : ES 0 DO E LOOP ; : SES 0 DO SE LOOP ; : SS 0 DO S LOOP ; : SWS 0 DO SW LOOP ; : WS 0 DO W LOOP ; : NWS 0 DO NW LOOP ; ;S # 50 ( HIPLOT CONTINUED ) : CIRCLE ( STEP-LENGTH -- ) >R PEN-DOWN R NS R NES R ES R SES R SS R SWS R WS R> NWS PEN-UP ; : DRAW DUP CIRCLE 3 * ES ; : HIPLOT 9600 BAUD 255 ASCII-OUT ; 112 CVARIABLE CHAR 113 C, 114 C, 113 C, 114 C, 115 C, 116 C, 115 C, 116 C, 117 C, 118 C, 117 C, 118 C, 119 C, 112 C, 119 C, 0 VARIABLE PARAM 0 , 0 , 0 , 0 , 0 VARIABLE X 0 VARIABLE Y --> # 51 ( HIPLOT CONTINUED ) : BESTLINE ( X Y -- ) 0 PARAM ! DUP Y ! ABS SWAP DUP X ! ABS - PARAM 2+ ! Y @ 0< NOT IF 2 PARAM ! THEN X @ Y @ + DUP PARAM 4 + ! 0< NOT IF 2 PARAM +! THEN Y @ X @ - DUP PARAM 4 + ! 0< NOT IF 2 PARAM +! THEN X @ 0< IF 10 PARAM +! ELSE 8 PARAM @ - PARAM ! THEN PARAM 2+ @ 0< IF Y @ ABS PARAM 4 + ! ELSE X @ ABS PARAM 4 + ! PARAM 2+ DUP @ MINUS SWAP ! THEN 0 PARAM 8 + ! X @ ABS Y @ ABS + PARAM 6 + ! BEGIN PARAM 6 + @ 0 > WHILE PARAM DUP 4 + @ SWAP DUP 2+ @ SWAP 8 + @ DUP + + + 0< IF PARAM DUP 4 + @ SWAP 8 + +! -1 PARAM 6 + +! 2 --> # 52 ( HIPLOT CONTINUED ) ELSE PARAM DUP 2+ @ SWAP 8 + +! -2 PARAM 6 + +! 1 THEN PARAM @ SWAP - CHAR + C@ ASCII-OUT REPEAT ; ;S # 53 ( HIPAD ) FORTH DEFINITIONS DECIMAL 1130 BAUD : HIPAD 15 0 DO ASCII-IN LOOP ; : PRPAD 0 15 DO CR I 3 .R 5 .R -1 +LOOP ; ;S # 54 ( CLOCK ROUTINES SCREEN 1 OF 2 ) FORTH DEFINITIONS DECIMAL 0 VARIABLE MYCLOCK 0 , : INVERT.CLOCK ( ADDR.-1 -- ) DUP DUP C@ 1 - 255 XOR SWAP C! 1+ DUP @ 65535 XOR SWAP ! ; : SET.TIME ( hr-3, min-2, sec-1 --) SWAP 60 * + ( sec ) 50 U* ( units) ROT 60 * ( min ) 3000 U* ( units) D+ SWAP MYCLOCK ! MYCLOCK 2+ C! MYCLOCK INVERT.CLOCK MYCLOCK CLOCK 3 CMOVE ; --> # 55 ( CLOCK 2 OF 2 ) FORTH DEFINITIONS DECIMAL : CHECK.CLOCK ( -- T/F ) ( FALSE IF IDENTICAL ) 3 0 DO MYCLOCK I + C@ PAD I + C@ XOR LOOP + + ; : READ.CLOCK ( -- ) BEGIN CLOCK PAD 3 CLOCK MYCLOCK 3 CMOVE CMOVE CHECK.CLOCK 0= UNTIL MYCLOCK INVERT.CLOCK ; : READ.TIME ( -- 50 msec-4,SEC-3,MIN-2,H-1 ) READ.CLOCK MYCLOCK DUP @ SWAP 2+ C@ 3000 U/ SWAP 50 /MOD ROT 60 /MOD 24 MOD ; ;S # 56 ( CASE ) FORTH DEFINITIONS DECIMAL : CASE: SWAP 2 * + @ EXECUTE ; ;S : CASE-EXAMPLE ; : 0PET ." AARDVARK " ; : 1PET ." BEAVER " ; : 2PET ." COUGAR " ; CASE: ANIMAL 0PET 1PET 2PET ; 0 ANIMAL 1 ANIMAL 2 ANIMAL ;S # 57 ( (CASE- CASE ) FORTH DEFINITIONS DECIMAL : (CASE) OVER = IF DROP 1 ELSE 0 THEN ; : CASE COMPILE (CASE) /COMPILE/ IF ; IMMEDIATE --> # 58 ( VEDIT def. YXCUR .CUR !CUR +CUR ) FORTH DEFINITIONS DECIMAL : YXCUR ( X Y -- ) YCUR C! XCUR C! ; : .CUR ( display current curs.pos ) R# @ C/L /MOD 2+ SWAP 3 + SWAP YXCUR ; : !CUR ( N -- ) 0 MAX 755 MIN R# ! ; : +CUR ( N -- ) R# @ + !CUR ; : +.CUR ( N -- ) +CUR .CUR ; : +LIN ( start of next line ) R# @ C/L / 1+ C/L * !CUR ; : HOM 0 R# ! ; : LIMITS 21 0 DO C/L 3 + FORTH I 2+ YXCUR 127 EMIT LOOP ; : !BLK SCR @ BLOCK R# @ + C! UPDATE 1 +.CUR ; --> # 59 ( VEDIT ) FORTH DEFINITIONS DECIMAL : VEDIT PAGE LIST LIMITS HOM .CUR BEGIN KEY 0 CASE 0 23 YXCUR QUIT ELSE 19 CASE -1 +.CUR ELSE ( left) 24 CASE C/L +.CUR ELSE ( down) 5 CASE C/L MINUS +.CUR ELSE 4 CASE 1 +.CUR ELSE ( right) 13 CASE 1 +LIN .CUR ELSE DUP DUP 32 < SWAP 127 > + IF DROP 32 THEN DUP EMIT !BLK THEN THEN THEN THEN THEN THEN AGAIN ; ;S # 60 ( grafics ) FORTH DEFINITIONS DECIMAL 1 CVARIABLE PATTERN 2 C, 4 C, 8 C, 16 C, 64 C, : GRAFIK.LINE ( line# -- ) 0 SWAP CURADDR 151 SWAP C! ; : GRAFIK.SCR ( -- ) PAGE 24 0 DO I GRAFIK.LINE LOOP ; : DOT.ADDR ( X, Y -- pattern, addr) 0 MAX 71 MIN SWAP 0 MAX 77 MIN SWAP ( keep X,Y within bounds ) 3 /MOD SWAP DUP + ROT 2 /MOD 1+ ROT ROT + >R SWAP CURADDR R> PATTERN + C@ SWAP ; : SET.DOT ( X, Y -- ) DOT.ADDR DUP C@ ROT OR SWAP C! ; : CLEAR.DOT ( X, Y -- ) DOT.ADDR SWAP 255 XOR SWAP DUP C@ ROT AND SWAP C! ; : ?DOT ( X, Y -- true/false) DOT.ADDR C@ AND ; # 61 ( grafics demo ) FORTH DEFINITIONS DECIMAL : VERTICAL GRAFIK.SCR 72 0 DO 78 0 DO I J SET.DOT ?TERMINAL IF LEAVE THEN LOOP ?TERMINAL IF LEAVE THEN LOOP 72 0 DO 78 0 DO I J CLEAR.DOT ?TERMINAL IF LEAVE THEN LOOP ?TERMINAL IF LEAVE THEN LOOP ; : CROSS GRAFIK.SCR 72 0 DO I I SET.DOT LOOP 72 0 DO I DUP 71 SWAP - SET.DOT LOOP QUIT ; # 62 ( grafics documentation ) ;S GRAFIK.LINE sets one line in graphic mode. GRAFIK.SCR sets the entire screen in graphic mode. DOT.ADDR expects an X value between 0 and 77 and a Y value between 0 and 71. It first forces X and Y to be within these limits. Next, the Y value is converted to a row-value, with a bit left over, which shows which of three vertical levels within the character is mark- ed. X is then converted to a column value, with a bit to show 1 of 2 horizontal positions within the char acter is marked. The X, Y mark bits are combined and the bit pattern for the character is fetched from the CVARIABLE PATTERN. # 63 ( Y/N ) FORTH DEFINITIONS DECIMAL : Y/N ( wait for Y or N and return with 1 for Y and 0 for N ) ( --T/F) ." (Y/N) " BEGIN KEY 127 32 - AND ( small to cap) DUP 89 = IF DROP 2 ELSE 78 = IF 1 ELSE 0 THEN THEN -DUP UNTIL 1 - DUP IF ." Y" ELSE ." N" THEN CR ; ;S # 64 ( EXAMPLE OF INTERACTIVITY ) FORTH DEFINITIONS DECIMAL : PLAY PAGE ." Hit any key, and you" ." will win the game " KEY CR ." You pressed " EMIT ; : GAME BEGIN PLAY CR CR ." Do you want to play " ." again ? " Y/N 0= UNTIL CR CR ." That's all then " CR ; ;S # 65 ( ASSEMBLER examples ) FORTH DEFINITIONS DECIMAL CODE ODD.PARITY.SEND ( ascii-1 -- ) D POP ( char. in E reg ) E A MOV A ANA ( set flags ) PE IF E 7 SET THEN TXD CALL NEXT JMP END-CODE CODE ODD.PARITY.RECEIVE ( -- ascii-2, flag-1 ) RXD CALL ( char. in E ) 2 H LXI 65013 LDA A 7 BIT 0= IF H DCX E A MOV A ANA PE IF H DCX THEN THEN DPUSH JMP END-CODE ;S # 66 ( ASSEMBLER 5 ) ASSEMBLER DEFINITIONS HEX NEXT 1 - CONSTANT HPUSH NEXT 2 - CONSTANT DPUSH : END-CODE /COMPILE/ C; ; D9 1MI EXX : BITAD CB C, C@ SWAP 8* + + C, ; 40 BITAD BIT 80 BITAD RES C0 BITAD SET : 2BYTE ED C, C@ C, ; 67 2BYTE RRD 6F 2BYTE RLD A0 2BYTE LDI A1 2BYTE CPII A2 2BYTE INI A3 2BYTE OUTI A8 2BYTE LDD A9 2BYTE CPD AA 2BYTE IND AB 2BYTE OUTD B0 2BYTE LDIR B1 2BYTE CPIR FORTH DEFINITIONS DECIMAL ;S # 67 ( ASSEMBLER 6 ) ASSEMBLER DEFINITIONS HEX B2 2BYTE INIR B3 2BYTE OTIR B8 2BYTE LDDR B9 2BYTE CPDR BA 2BYTE INDR BB 2BYTE OTDR : 2BZ80 CB C, C@ + C, ; 00 2BZ80 RLCZ 08 2BZ80 RRCZ 10 2BZ80 RL 18 2BZ80 RR 20 2BZ80 SLA 28 2BZ80 SRA 38 2BZ80 SRL FORTH DEFINITIONS DECIMAL ;S Z80 mnemonics FORTH mnemonics CPI CPII RLC RLCZ RRC RRCZ # 68 ( FORTH-79 DEFINITIONS ) FORTH DEFINITIONS DECIMAL : 1- 1 - ; : 2- 2 - ; : <> = 0= ; : DEPTH ( -- n ) SP@ S0 @ SWAP - 2 / ; : PICK ( n1 -- n2 ) ( If n1 >0, get the n1th. number ) ( from the stack, and return it on) ( top of the stack ) DEPTH 1- OVER < OVER 1 < OR ( check for bad index: leave true if bad, false if OK ) IF ." INDEX OUTSIDE LIMITS" 7 EMIT QUIT ELSE DUP + SP@ + @ THEN ; : ROLL ( n -- re-arranged stack ) >R R PICK SP@ DUP 2+ R> DUP + # 69 ( FORTH-79 DEFINITIONS ) FORTH DEFINITIONS DECIMAL : >< ( swap bytes ) ( FORTH DEF. ) DUP 256 / SWAP 255 AND 256 * + ; VOCABULARY FORTH-79 IMMEDIATE FORTH-79 DEFINITIONS DECIMAL : CREATE ( agrees with Brodie ) 0 VARIABLE -2 ALLOT ; : WORD ( -- address ) WORD HERE ; ;S