# 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