TITLE	'8080 FIG-FORTH 1.1 VERSION A0 17SEP79'
;
;	FIG-FORTH  RELEASE 1.1  FOR THE 8080 PROCESSOR
;
;	ALL PUBLICATIONS OF THE FORTH INTEREST GROUP
;	ARE PUBLIC DOMAIN.  THEY MAY BE FURTHER
;	DISTRIBUTED BY THE INCLUSION OF THIS CREDIT
;	NOTICE:
;
;	THIS PUBLICATION HAS BEEN MADE AVAILABLE BY THE
;		     FORTH INTEREST GROUP
;		     P. O. BOX 1105
;		     SAN CARLOS, CA 94070
;
;	IMPLEMENTATION BY:
;		JOHN CASSADY
;                FOR THE FORTH IMPLEMENTATION TEAM (FIT) MARCH 1979
;	MODIFIED for CP/M by:
;	   	KIM HARRIS
;               FIT LIBRARIAN SEPT 1979
;	ACKNOWLEDGEMENTS:
;		GEORGE FLAMMER
;		ROBT. D. VILLWOCK
;               Microsystems inc. Pasadena Ca.
;
;        DISTRIBUTED BY    FORTH POWER
;               P.O. BOX 2455 SAN RAFAEL CA
;               94902   415-471-1762
;               SUPPORT, SYSTEMS PROGRAMMING, 
;               APPLICATIONS PROGRAMMING
;
;  UNLESS OTHERWISE INDICATED, THIS DISTRIBUTION IS SUPPORTED
;  SOLELY BY THE FORTH INTEREST GROUP (LISTINGS) AND BY
;  FORTH POWER (MACHINE READABLE COPIES AND EXTENSIONS).
;
;   COPYRIGHT AND TRADEMARK NOTICES:
;   FORTH (C) 1974,1975,1976,1977,1978,1979 FORTH INC.
;   FIST (C) 1979 FORTH INTERNATIONAL STANDARDS TEAM
;   FIG, FORTH DIMENSIONS, FIT, (C) 1978, 1979 FORTH INTEREST GROUP
;   FORTH POWER (C) 1978, 1979 MARIN SERVICES, INC.
;   FORTH 77, FORTH 78, FORTH 79, STANDARD FORTH, FORTH INTERNATIONAL
;   STANDARD, (C) 1976, 1977, 1978, 1979, FIST
;   MULTI-FORTH (C) 1978, 1979 CREATIVE SOLUTIONS
;   CP/M (C) 1979 DIGITAL RESEARCH INC.
;   MOST ANYTHING WITH AN 11 IN IT (C) DIGITAL EQUIPMENT CORP
;   THERE MAY BE OTHERS ! !
;   MINIFORTH, MICROFORTH, POLYFORTH, FORTH  TM FORTH INC.
;   FIG-FORTH (C) 1978 1979 FORTH INTEREST GROUP
;   ALL RIGHTS RESERVED EXCEPT AS EXPRESSLY INDICATED !
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;               UPDATES, PATCHES, BUG REPORTS, EXTENSIONS
;               FOR THIS SOFTWARE IN  FORTH DIMENSIONS  
;               NEWSLETTER OF FORTH INTEREST GROUP (FIG)
;               6 issues $5.00 includes fig membership
;
;          DOCUMENTATION FROM FIG or FORTH POWER
;        
;               FORTH PRIMER (240pp) Richard Stevens
;               KITT PEAK NATIONAL OBSERVATORY    $20.00
;    
;               FORTH IMPLEMENTATION TEAM LANGUAGE MODEL, EDITOR SOURCE,
;               LANGUAGE GLOSSARY, AND IMPLEMENTATION GUIDE  $10.00
;
;               FORTH FOR MICROCOMPUTERS by JOHN S JAMES
;               reprint from DDJ #25          $2.00
;
;               FORTH POCKET PROGRAMMERS CARD  FREE W/ S.A.S.E.
;
;               SOURCE CODE FOR TI990, 6502, 6800, PDP11, PACE,
;               8080 (included here)    $10.00/ LISTING
;
;          DOCUMENTATION FROM FIG
;
;               USING FORTH by ELIZABETH RATHER (200pp)
;               FORTH INC. 1979               $20.00
;
;          DOCUMENTATION FROM FORTH POWER
;               
;
;               CP/M MULTI-FORTH USERS MANUAL  $20.00
;               FORTH 79 INTERNATIONAL STANDARD 
;
;               CP/M 8080 FORTH BY FIG 8" DISKETT IBM STD.
;               WITH EDITOR AND ASSEMBLER, COPY AND PRINT,
;               AND USERS GUIDE                $65.00
;
;               also on 5" CP/M, 5 & 8 Northstar DOS
;
;               CP/M Multi-Forth, Full 79 International
;               Standard with extensions, Strings, Prom burner,
;               Real time clock, VIDEO EDITOR, UTILITIES
;               A PROFESSIONAL LEVEL PRODUCT    $150.00
;               includes manual
;
;               PDP 11 FORTH by JOHN S. JAMES
;               8" RX01 diskett or 9 track 800 bpi DOS tape
;               runs under OS or stand alone
;               WITH USERS GUIDE                $150.00
;
;               FIG TRS 80 FORTH cassette or diskette
;               WRITE FOR PRICES
;
;               APPLE FORTH BY CapN' SOFTWARE   $40.00
;               EASYWRITER (word processor for APPLE
;               by CapN' SOFTWARE)        $100.00
;
;               APPLE FORTH BY UNIVERSITY OF UTRECHT,
;               includes floating pt and many extensions
;               A PROFESSIONAL LEVEL PRODUCT  $100.00
;
;               FORTH FOR MICROPROSSOR DEVELOPMENT SYSTEMS,
;               FORTH FOR D.G., VAX 11, INTERDATA, Series 1,
;               C.A., HONEYWELL LEVEL 6, and others,   Write for prices
;
;          DOCUMENTATION FROM CALTECH
;                CALTECH FORTH MANUAL $6.00
;               CAL TECH BOOKSTORE PASADENA CA
;               by MARTIN S. EWING 100pp postpaid
;
;  CALL FOR PAPERS, ARTICLES, SPEAKERS: FOR FORTH DIMENSIONS
;   AND TRADE PUBLICATIONS SEND TO FIG.  FOR SPEAKERS, WORKSHOPS,
;   SHOWS AND CONVENTIONS CONTACT FIG.  FIG SOLICITES FORTH SOFTWARE
;   FOR INCLUSION IN THIS EFFORT.
;               FORTH INTERNATIONAL STANDARDS TEAM (FIT)
;              FORTH 79 INTERNATIONAL STANDARD, REQUIRED AND
;              RESERVED WORD GLOSSARY, AND STANDARDS ACTIVITY
;              DISTRIBUTION.  $30.00 TO FIT c/o FIG or to
;
;              CAROLYN ROSENBERG, FIT SECRETARY
;              c/o FORTH INC. MANHATTAN BEACH CA.
;
;
;-----------------------------------------------------
;	LABELS USED WHICH DIFFER FROM FIG-FORTH PUBLISHED
;	8080 LISTING 1.0:
;
;	REL 1.1		REL 1.0
;	-------		-------
;	ANDD		AND
;	CSPP		CSP
;	ELSEE		ELSE
;	ENDD		END
;	ENDIFF		ENDIF
;	ERASEE		ERASE
;	IDO		I
;	IFF		IF
;	INN		IN
;	MODD		MOD
;	ORR		OR
;	OUTT		OUT
;	RR		R
;	RPP		RP
;	SUBB		SUB
;	XORR		XOR
;
;	SEE ALSO:
;		RELEASE & VERSION NUMBERS
;		ASCII CHARACTER EQUATES
;		MEMORY ALLOCATION
;		DISK INTERFACE
;		CONSOLE & PRINTER INTERFACE
;
	PAGE
;
;----------------------------------------------------------
;
;	RELEASE & VERSION NUMBERS
;
FIGREL	EQU	1	; FIG RELEASE #
FIGREV	EQU	1	; FIG REVISION #
USRVER	EQU	0	; USER VERSION #
;
;	ASCII CHARACTERS USED
;
ABL	EQU	20H	; SPACE
ACR	EQU	0DH	; CARRIAGE RETURN
ADOT	EQU	02EH	; PERIOD
BELL	EQU	07H	; (^G)
BSIN	EQU	7FH	; INPUT BACKSPACE CHR = RUBOUT
BSOUT	EQU	08H	; OUTPUT BACKSPACE (^H)
DLE	EQU	10H	; (^P)
LF	EQU	0AH	; LINE FEED
FF	EQU	0CH	; FORM FEED (^L)
;
;	MEMORY ALLOCATION
;
EM	EQU	4000H	; TOP OF MEMORY + 1 = LIMIT
NSCR	EQU	1	; NUMBER OF 1024 BYTE SCREENS
KBBUF	EQU	128	; DATA BYTES PER DISK BUFFER
US	EQU	40H	; USER VARIABLES SPACE
RTS	EQU	0A0H	; RETURN STACK & TERM BUFF SPACE
;
CO	EQU	KBBUF+4	; DISK BUFFER + 2 HEADER + 2 TAIL
NBUF	EQU	NSCR*400H/KBBUF	; NUMBER OF BUFFERS
BUF1	EQU	EM-CO*NBUF	; ADDR FIRST DISK BUFFER
INITR0	EQU	BUF1-US		; (R0)
INITS0	EQU	INITR0-RTS	; (S0)
;
	PAGE
;
;-------------------------------------------------------
;
	ORG	100H
ORIG	NOP
	JMP	CLD	; VECTOR TO COLD START
	NOP
	JMP	WRM	; VECTOR TO WARM START
	DB	FIGREL	; FIG RELEASE #
	DB	FIGREV	; FIG REVISION #
	DB	USRVER	; USER VERSION #
	DB	0EH	; IMPLEMENTATION ATTRIBUTES
	DW	TASK-7  ; TOPMOST WORD IN FORTH VOCABULARY
	DW	BSIN	; BKSPACE CHARACTER
	DW	INITR0	; INIT (UP)
;<<<<<< FOLLOWING USED BY COLD;
;	MUST BE IN SAME ORDER AS USER VARIABLES
	DW	INITS0	; INIT (S0)
	DW	INITR0	; INIT (R0)
	DW	INITS0	; INIT (TIB)
	DW	20H		; INIT (WIDTH)
	DW	0		; INIT (WARNING)
	DW	INITDP		; INIT (FENCE)
	DW	INITDP		; INIT (DP)
	DW	FORTH+6		; INIT (VOC-LINK)
;<<<<<< END DATA USED BY COLD
	DW	5H,0B320H	; CPU NAME	( HW,LW )
;				  ( 32 BIT, BASE 36 INTEGER )
;
;
;			+---------------+
;	B +ORIGIN	| . . .W:I.E.B.A|	IMPLEMENTATION
;			+---------------+	ATTRIBUTES
;			       ^ ^ ^ ^ ^
;			       | | | | +-- PROCESSOR ADDR =
;			       | | | |     { 0 BYTE | 1 WORD }
;			       | | | +---- HIGH BYTE AT
;			       | | |       { 0 LOW ADDR |
;			       | | |	     1 HIGH ADDR }
;			       | | +------ ADDR MUST BE EVEN
;			       | |	   { 0 YES | 1 NO }
;			       | +-------- INTERPRETER IS
;			       |	   { 0 PRE | 1 POST }
;			       |	   INCREMENTING
;			       +---------- { 0 ABOVE SUFFICIENT
;					     | 1 OTHER DIFFER-
;					     ENCES EXIST }
;
	PAGE
;
;------------------------------------------------------
;
;	FORTH REGISTERS
;
;	FORTH	8080	FORTH PRESERVATION RULES
;	-----	----	------------------------------------------------------------------------HH+	;	IP	BC	SHOULD BE PRESERVED ACROSS
;			  FORTH WORDS
;	W	DE	SOMETIMES OUTPUT FROM NEXT
;			MAY BE ALTERED BEFORE JMP'ING TO NEXT
;			INPUT ONLY WHEN 'DPUSH' CALLED
;	SP	SP	SHOULD BE USED ONLY AS DATA STACK
;			  ACROSS FORTH WORDS
;			MAY BE USED WITHIN FORTH WORDS
;			  IF RESTORED BEFORE 'NEXT'
;		HL	NEVER OUTPUT FROM NEXT
;			INPUT ONLY WHEN 'HPUSH' CALLED
;
UP	DW	INITR0	; USER AREA POINTER
RPP	DW	INITR0	; RETURN STACK POINTER
;
;------------------------------------------------------
;
;	COMMENT CONVENTIONS:
;
;	=	MEANS	"IS EQUAL TO"
;	<-	MEANS	ASSIGNMENT
;
;	NAME	=	ADDRESS OF NAME
;	(NAME)	=	CONTENTS AT NAME
;	((NAME))=	INDIRECT CONTENTS
;
;	CFA	=	ADDRESS OF CODE FIELD
;	LFA	=	ADDRESS OF LINK FIELD
;	NFA	=	ADDR OF START OF NAME FIELD
;	PFA	=	ADDR OF START OF PARAMETER FIELD
;
;	S1	=	ADDR OF 1ST WORD OF PARAMETER STACK
;	S2	=	ADDR OF 2ND WORD OF PARAMETER STACK
;	R1	=	ADDR OF 1ST WORD OF RETURN STACK
;	R2	=	ADDR OF 2ND WORD OF RETURN STACK
;	( ABOVE STACK POSITIONS VALID BEFORE & AFTER EXECUTION
;	OF ANY WORD, NOT DURING. )
;
;	LSB	=	LEAST SIGNIFICANT BIT
;	MSB	=	MOST SIGNIFICANT BIT
;	LB	=	LOW BYTE
;	HB	=	HIGH BYTE
;	LW	=	LOW WORD
;	HW	=	HIGH WORD
;	( MAY BE USED AS SUFFIX TO ABOVE NAMES )
;
	PAGE
;
;---------------------------------------------------
;	DEBUG SUPPORT
;
;	TO USE:
;	(1)	SET 'BIP' TO IP VALUE TO HALT, CANNOT BE CFA
;	(2)	SET MONITOR'S BREAKPOINT PC TO 'BREAK'
;			OR PATCH 'HLT' INSTR. THERE
;	(3)	PATCH A 'JMP TNEXT' AT 'NEXT'
;	WHEN (IP) = (BIP) CPU WILL HALT
;
BIP	DW	0	; BREAKPOINT ON IP VALUE
;
TNEXT	LXI	H,BIP
	MOV	A,M	; LB
	CMP	C
	JNZ	TNEXT1
	INX	H
	MOV	A,M	; HB
	CMP	B
	JNZ	TNEXT1
BREAK	NOP		; PLACE BREAKPOINT HERE
	NOP
	NOP
TNEXT1	LDAX	B
	INX	B
	MOV	L,A
	JMP	NEXT+3
;
;--------------------------------------------------
;
;	NEXT, THE FORTH ADDRESS INTERPRETER
;	  ( POST INCREMENTING VERSION )
;
DPUSH	PUSH	D
HPUSH	PUSH	H
NEXT	LDAX	B	;(W) <- ((IP))
	INX	B	;(IP) <- (IP)+2
	MOV	L,A
	LDAX	B
	INX	B
	MOV	H,A	; (HL) <- CFA
NEXT1:	MOV	E,M	;(PC) <- ((W))
	INX	H
	MOV	D,M
	XCHG
	PCHL		; NOTE: (DE) = CFA+1
;
	PAGE
;
;		FORTH DICTIONARY
;
;
;	DICTIONARY FORMAT:
;
;				BYTE
;	ADDRESS	NAME		CONTENTS
;	------- ----		--------
;					  ( MSB=1
;					  ( P=PRECEDENCE BIT
;					  ( S=SMUDGE BIT
;	NFA	NAME FIELD	1PS<LEN>  < NAME LENGTH
;				0<1CHAR>  MSB=0, NAME'S 1ST CHAR
;				0<2CHAR>
;				  ...
;				1<LCHAR>  MSB=1, NAME'S LAST CHR
;	LFA	LINK FIELD	<LINKLB>  = PREVIOUS WORD'S NFA
;				<LINKHB>
;LABEL:	CFA	CODE FIELD	<CODELB>  = ADDR CPU CODE
;				<CODEHB>
;	PFA	PARAMETER	<1PARAM>  1ST PARAMETER BYTE
;		FIELD		<2PARAM>
;				  ...
;
;
DP0:	DB	83H	; LIT
	DB	'LI'
	DB	'T'+80H
	DW	0	; (LFA)=0 MARKS END OF DICTIONARY
LIT	DW	$+2	;(S1) <- ((IP))
	LDAX	B	; (HL) <- ((IP)) = LITERAL
	INX	B	; (IP) <- (IP) + 2
	MOV	L,A	; LB
	LDAX	B	; HB
	INX	B
	MOV	H,A
	JMP	HPUSH	; (S1) <- (HL)
 ;
	DB	87H	; EXECUTE
	DB	'EXECUT'
	DB	'E'+80H
	DW	LIT-6
EXEC	DW	$+2
	POP	H	; (HL) <- (S1) = CFA
	JMP	NEXT1
;
	DB	86H	; BRANCH
	DB	'BRANC'
	DB	'H'+80H
	DW	EXEC-0AH
BRAN	DW	$+2	;(IP) <- (IP) + ((IP))
BRAN1	MOV	H,B	; (HL) <- (IP)
	MOV	L,C
	MOV	E,M	; (DE) <- ((IP)) = BRANCH OFFSET
	INX	H
	MOV	D,M
	DCX	H
	DAD	D	; (HL) <- (HL) + ((IP))
	MOV	C,L	; (IP) <- (HL)
	MOV	B,H
	JMP	NEXT
;
	DB	87H	; 0BRANCH
	DB	'0BRANC'
	DB	'H'+80H
	DW	BRAN-9
ZBRAN	DW	$+2
	POP	H
	MOV	A,L
	ORA	H
	JZ	BRAN1	; IF (S1)=0 THEN BRANCH
	INX	B	; ELSE SKIP BRANCH OFFSET
	INX	B
	JMP	NEXT
;
	DB	86H	; (LOOP)
	DB	'(LOOP'
	DB	')'+80H
	DW	ZBRAN-0AH
XLOOP	DW	$+2
	LXI	D,1	; (DE) <- INCREMENT
XLOO1	LHLD	RPP	; ((HL)) = INDEX
	MOV	A,M	; INDEX <- INDEX + INCR
	ADD	E
	MOV	M,A
	MOV	E,A
	INX	H
	MOV	A,M
	ADC	D
	MOV	M,A
	INX	H	; ((HL)) = LIMIT
	INR	D
	DCR	D
	MOV	D,A	; (DE) <- NEW INDEX
	JM	XLOO2	; IF INCR > 0
	MOV	A,E
	SUB	M	; THEN (A) <- INDEX - LIMIT
	MOV	A,D
	INX	H
	SBB	M
	JMP	XLOO3
XLOO2	MOV	A,M	; ELSE (A) <- LIMIT - INDEX
	SUB	E
	INX	H
	MOV	A,M
	SBB	D
;			; IF (A) < 0
XLOO3	JM	BRAN1	; THEN LOOP AGAIN
	INX	H	; ELSE DONE
	SHLD	RPP	; DISCARD R1 & R2
	INX	B	; SKIP BRANCH OFFSET
	INX	B
	JMP	NEXT
;
	DB	87H	; (+LOOP)
	DB	'(+LOOP'
	DB	')'+80H
	DW	XLOOP-9
XPLOO	DW	$+2
	POP	D	; (DE) <- INCR
	JMP	XLOO1
;
	DB	84H	; (DO)
	DB	'(DO'
	DB	')'+80H
	DW	XPLOO-0AH
XDO	DW	$+2
	LHLD	RPP	; (RP) <- (RP) - 4
	DCX	H
	DCX	H
	DCX	H
	DCX	H
	SHLD	RPP
	POP	D	; (R1) <- (S1) = INIT INDEX
	MOV	M,E
	INX	H
	MOV	M,D
	POP	D	; (R2) <- (S2) = LIMIT
	INX	H
	MOV	M,E
	INX	H
	MOV	M,D
	JMP	NEXT
;
	DB	81H	; I
	DB	'I'+80H
	DW	XDO-7
IDO	DW	$+2	;(S1) <- (R1) , (R1) UNCHANGED
	LHLD	RPP
	MOV	E,M	; (DE) <- (R1)
	INX	H
	MOV	D,M
	PUSH	D	; (S1) <- (DE)
	JMP	NEXT
;
	DB	85H	; DIGIT
	DB	'DIGI'
	DB	'T'+80H
	DW	IDO-4
DIGIT	DW	$+2
	POP	H	; (L) <- (S1)LB = ASCII CHR TO BE
;			 CONVERTED
	POP	D	; (DE) <- (S2) = BASE VALUE
	MOV	A,E
	SUI	30H	; IF CHR > "0"
	JM	DIGI2
	CPI	0AH	; AND IF CHR > "9"
	JM	DIGI1
	SUI	7
	CPI	0AH	; AND IF CHR >= "A"
	JM	DIGI2
;			; THEN VALID NUMERIC OR ALPHA CHR
DIGI1	CMP	L	; IF < BASE VALUE
	JP	DIGI2
;			; THEN VALID DIGIT CHR
	MOV	E,A	; (S2) <- (DE) = CONVERTED DIGIT
	LXI	H,1	; (S1) <- TRUE
	JMP	DPUSH
;			; ELSE INVALID DIGIT CHR
DIGI2	MOV	L,H	; (HL) <- FALSE
	JMP	HPUSH	; (S1) <- FALSE
;
	DB	86H	; (FIND)  (2-1)FAILURE
	DB	'(FIND'	; (2-3)SUCCESS
	DB	')'+80H
	DW	DIGIT-8
PFIND	DW	$+2
	POP	D	; (DE) <- NFA
PFIN1	POP	H	; (HL) <- STRING ADDR
	PUSH	H	; SAVE STRING ADDR FOR NEXT ITERATION
	LDAX	D
	XRA	M	; CHECK LENGTHS & SMUDGE BIT
	ANI	3FH
	JNZ	PFIN4	; LENGTHS DIFFERENT
;			; LENGTHS MATCH, CHECK EACH CHR
PFIN2	INX	H	; (HL) <- ADDR NEXT CHR IN STRING
	INX	D	; (DE) <- ADDR NEXT CHR IN NF
	LDAX	D
	XRA	M	; IGNORE MSB
	ADD	A
	JNZ	PFIN3	; NO MATCH
	JNC	PFIN2	; MATCH SO FAR, LOOP AGAIN
	LXI	H,5	; STRING MATCHES
	DAD	D	; ((SP)) <- PFA
	XTHL
;			; BACK UP TO LENGTH BYTE OF NF = NFA
PFIN6	DCX	D
	LDAX	D
	ORA	A
	JP	PFIN6	; IF MSB = 1 THEN (DE) = NFA
	MOV	E,A	; (DE) <- LENGTH BYTE
	MVI	D,0
	LXI	H,1	; (HL) <- TRUE
	JMP	DPUSH  ; RETURN, NF FOUND
;	ABOVE NF NOT A MATCH, TRY ANOTHER
PFIN3	JC	PFIN5	; IF NOT END OF NF
PFIN4	INX	D	; THEN FIND END OF NF
	LDAX	D
	ORA	A
	JP	PFIN4
PFIN5	INX	D	; (DE) <- LFA
	XCHG
	MOV	E,M	; (DE) <- (LFA)
	INX	H
	MOV	D,M
	MOV	A,D
	ORA	E	; IF (LFA) <> 0
	JNZ	PFIN1	; THEN TRY PREVIOUS DICT. DEF.
;			; ELSE END OF DICTIONARY
	POP	H	; DISCARD STRING ADDR
	LXI	H,0	; (HL) <- FALSE
	JMP	HPUSH  	; RETURN, NO MATCH FOUND
;
	DB	87H	; ENCLOSE
	DB	'ENCLOS'
	DB	'E'+80H
	DW	PFIND-9
ENCL	DW	$+2
	POP	D	; (DE) <- (S1) = DELIMITER CHAR
	POP	H	; (HL) <- (S2) = ADDR TEXT TO SCAN
	PUSH	H	; (S4) <- ADDR
	MOV	A,E
	MOV	D,A	; (D) <- DELIM CHR
	MVI	E,-1	; INITIALIZE CHR OFFSET COUNTER
	DCX	H	; (HL) <- ADDR-1
;			; SKIP OVER LEADING DELIMITER CHRS
ENCL1	INX	H
	INR	E
	CMP	M	; IF TEXT CHR = DELIM CHR
	JZ	ENCL1	; THEN LOOP AGAIN
;			; ELSE NON-DELIM CHR FOUND
	MVI	D,0	; (S3) <- (E) = OFFSET TO 1ST NON-DELIM
	PUSH	D
	MOV	D,A	; (D) <- DELIM CHR
	MOV	A,M	; IF 1ST NON-DELIM = NULL
	ANA	A
	JNZ	ENCL2
	MVI	D,0	; THEN (S2) <- OFFSET TO BYTE
	INR	E	;   FOLLOWING NULL
	PUSH	D
	DCR	E	; (S1) <- OFFSET TO NULL
	PUSH	D
	JMP	NEXT
;			; ELSE TEXT CONTAINS NON-DELIM &
;			  NON-NULL CHR
ENCL2	MOV	A,D	; (A) <- DELIM CHR
	INX	H	; (HL) <- ADDR NEXT CHR
	INR	E	; (E) <- OFFSET TO NEXT CHR
	CMP	M	; IF NEXT CHR <> DELIM CHR
	JZ	ENCL4
	MOV	A,M	; AND IF NEXT CHR <> NULL
	ANA	A
	JNZ	ENCL2	; THEN CONTINUE SCAN
;			; ELSE CHR = NULL
ENCL3	MVI	D,0	; (S2) <- OFFSET TO NULL
	PUSH	D
	PUSH	D	; (S1) <- OFFSET TO NULL
	JMP	NEXT
;			; ELSE CHR = DELIM CHR
ENCL4	MVI	D,0	; (S2) <- OFFSET TO BYTE
;			  FOLLOWING TEXT
	PUSH	D
	INR	E	; (S1) <- OFFSET TO 2 BYTES AFTER
;			    END OF WORD
	PUSH	D
	JMP	NEXT
;
	DB	84H	; EMIT
	DB	'EMI'
	DB	'T'+80H
	DW	ENCL-0AH
EMIT	DW	DOCOL
	DW	PEMIT
	DW	ONE,OUTT
	DW	PSTOR,SEMIS
;
	DB	83H	; KEY
	DB	'KE'
	DB	'Y'+80H
	DW	EMIT-7
KEY	DW	$+2
	JMP	PKEY
;
	DB	89H	; ?TERMINAL
	DB	'?TERMINA'
	DB	'L'+80H
	DW	KEY-6
QTERM	DW	$+2
	LXI	H,0
	JMP	PQTER
;
	DB	82H	; CR
	DB	'C'
	DB	'R'+80H
	DW	QTERM-0CH
CR	DW	$+2
	JMP	PCR
;
	DB	85H	; CMOVE
	DB	'CMOV'
	DB	'E'+80H
	DW	CR-5
CMOVE	DW	$+2
	MOV	L,C	; (HL) <- (IP)
	MOV	H,B
	POP	B	; (BC) <- (S1) = #CHRS
	POP	D	; (DE) <- (S2) = DEST ADDR
	XTHL		; (HL) <- (S3) = SOURCE ADDR
;			; (S1) <- (IP)
	JMP	CMOV2	; RETURN IF #CHRS = 0
CMOV1	MOV	A,M	; ((DE)) <- ((HL))
	INX	H	; INC SOURCE ADDR
	STAX	D
	INX	D	; INC DEST ADDR
	DCX	B	; DEC #CHRS
CMOV2	MOV	A,B
	ORA	C
	JNZ	CMOV1	; REPEAT IF #CHRS <> 0
	POP	B	; RESTORE (IP) FROM (S1)
	JMP	NEXT
;
	DB	82H	; U*	16X16 UNSIGNED MULTIPLY
	DB	'U'	; AVG EXECUUION TIME = 994 CYCLES
	DB	'*'+80H
	DW	CMOVE-8
USTAR	DW	$+2
	POP	D	; (DE) <- MPLIER
	POP	H	; (HL) <- MPCAND
	PUSH	B	; SAVE IP
	MOV	B,H
	MOV	A,L	; (BA) <- MPCAND
	CALL	MPYX	; (AHL)1 <- MPCAND.LB * MPLIER
;			       1ST PARTIAL PRODUCT
	PUSH	H	; SAVE (HL)1
	MOV	H,A
	MOV	A,B
	MOV	B,H	; SAVE (A)1
	CALL	MPYX	; (AHL)2 <- MPCAND.HB * MPLIER
;			       2ND PARTIAL PRODUCT
	POP	D	; (DE) <- (HL)1
	MOV	C,D	; (BC) <- (AH)1
;	FORM SUM OF PARTIALS:
;			   (AHL) 1
;			+ (AHL)  2
;			--------
;			  (AHLE)
	DAD	B	; (HL) <- (HL)2 + (AH)1
	ACI	0	; (AHLE) <- (BA) * (DE)
	MOV	D,L
	MOV	L,H
	MOV	H,A	; (HLDE) <- MPLIER * MPCAND
	POP	B	; RESTORE IP
	PUSH	D	; (S2) <- PRODUCT.LW
	JMP	HPUSH	; (S1) <- PRODUCT.HW
;
;	MULTIPLY PRIMITIVE
;		(AHL) <- (A) * (DE)
;	#BITS =	 24	  8	16
MPYX	LXI	H,0	; (HL) <- 0 = PARTIAL PRODUCT.LW
	MVI	C,8	; LOOP COUNTER
MPYX1	DAD	H	; LEFT SHIFT (AHL) 24 BITS
	RAL
	JNC	MPYX2	; IF NEXT MPLIER BIT = 1
	DAD	D	; THEN ADD MPCAND
	ACI	0
MPYX2	DCR	C	; IF NOT LAST MPLIER BIT
	JNZ	MPYX1	; THEN LOOP AGAIN
	RET		; ELSE DONE
;
	DB	82H	; U/
	DB	'U'
	DB	'/'+80H
	DW	USTAR-5
USLAS	DW	$+2
	LXI	H,4
	DAD	SP	; ((HL)) <- NUMERATOR.LW
	MOV	E,M	; (DE) <- NUMER.LW
	MOV	M,C	; SAVE IP ON STACK
	INX	H
	MOV	D,M
	MOV	M,B
	POP	B	; (BC) <- DENOMINATOR
	POP	H	; (HL) <- NUMER.HW
	MOV	A,L
	SUB	C	; IF NUMER >= DENOM
	MOV	A,H
	SBB	B
	JC	USLA1
	LXI	H,0FFFFH	; THEN OVERFLOW
	LXI	D,0FFFFH	; SET REM & QUOT TO MAX
	JMP	USLA7
USLA1	MVI	A,16	; LOOP COUNTER
USLA2	DAD	H	; LEFT SHIFT (HLDE) THRU CARRY
	RAL
	XCHG
	DAD	H
	JNC	USLA3
	INX	D
	ANA	A
USLA3	XCHG		; SHIFT DONE
	RAR		; RESTORE 1ST CARRY
	PUSH	PSW	; SAVE COUNTER
	JNC	USLA4	; IF CARRY = 1
	MOV	A,L	; THEN (HL) <- (HL) - (BC)
	SUB	C
	MOV	L,A
	MOV	A,H
	SBB	B
	MOV	H,A
	JMP	USLA5
USLA4	MOV	A,L	; ELSE TRY (HL) <- (HL) - (BC)
	SUB	C
	MOV	L,A
	MOV	A,H
	SBB	B	; (HL) <- PARTIAL REMAINDER
	MOV	H,A
	JNC	USLA5
	DAD	B	; UNDERFLOW, RESTORE
	DCX	D
USLA5	INX	D	; INC QUOT
USLA6	POP	PSW	; RESTORE COUNTER
	DCR	A	; IF COUNTER > 0
	JNZ	USLA2	; THEN LOOP AGAIN
USLA7	POP	B	; ELSE DONE, RESTORE IP
	PUSH	H	; (S2) <- REMAINDER
	PUSH	D	; (S1) <- QUOTIENT
	JMP	NEXT
;
	DB	83H	; AND
	DB	'AN'
	DB	'D'+80H
	DW	USLAS-5
ANDD	DW	$+2	; (S1) <- (S1) AND (S2)
	POP	D
	POP	H
	MOV	A,E
	ANA	L
	MOV	L,A
	MOV	A,D
	ANA	H
	MOV	H,A
	JMP	HPUSH
;
	DB	82H	; OR
	DB	'O'
	DB	'V'+80H
	DW	ANDD-6
ORR	DW	$+2	; (S1) <- (S1) OR (S2)
	POP	D
	POP	H
	MOV	A,E
	ORA	L
	MOV	L,A
	MOV	A,D
	ORA	H
	MOV	H,A
	JMP	HPUSH
;
	DB	83H	; XOR
	DB	'XO'
	DB	'R'+80H
	DW	ORR-5
XORR	DW	$+2	; (S1) <- (S1) XOR (S2)
	POP	D
	POP	H
	MOV	A,E
	XRA	L
	MOV	L,A
	MOV	A,D
	XRA	H
	MOV	H,A
	JMP	HPUSH
;
	DB	83H	; SP@
	DB	'SP'
	DB	'@'+80H
	DW	XORR-6
SPAT	DW	$+2	;(S1) <- (SP)
	LXI	H,0
	DAD	SP	; (HL) <- (SP)
	JMP	HPUSH	; (S1) <- (HL)
;
	DB	83H	; STACK POINTER STORE
	DB	'SP'
	DB	'!'+80H
	DW	SPAT-6
SPSTO	DW	$+2	;(SP) <- (S0) ( USER VARIABLE )
	LHLD	UP	; (HL) <- USER VAR BASE ADDR
	LXI	D,6
	DAD	D	; (HL) <- S0
	MOV	E,M	; (DE) <- (S0)
	INX	H
	MOV	D,M
	XCHG
	SPHL		; (SP) <- (S0)
	JMP	NEXT
;
	DB	83H	; RP@
	DB	'RP'
	DB	'@'+80H
	DW	SPSTO-6
RPAT	DW	$+2	;(S1) <- (RP)
	LHLD	RPP
	JMP	HPUSH
;
	DB	83H	; RETURN STACK POINTER STORE
	DB	'RP'
	DB	'!'+80H
	DW	RPAT-6
RPSTO	DW	$+2	;(RP) <- (R0) ( USER VARIABLE )
	LHLD	UP	; (HL) <- USER VARIABLE BASE ADDR
	LXI	D,8
	DAD	D	; (HL) <- R0
	MOV	E,M	; (DE) <- (R0)
	INX	H
	MOV	D,M
	XCHG
	SHLD	RPP	; (RP) <- (R0)
	JMP	NEXT
;
	DB	82H	; ;S
	DB	';'
	DB	'S'+80H
	DW	RPSTO-6
SEMIS	DW	$+2	;(IP) <- (R1)
	LHLD	RPP
	MOV	C,M	; (BC) <- (R1)
	INX	H
	MOV	B,M
	INX	H
	SHLD	RPP	; (RP) <- (RP) + 2
	JMP	NEXT
;
	DB	85H	; LEAVE
	DB	'LEAV'
	DB	'E'+80H
	DW	SEMIS-5
LEAVE	DW	$+2	;LIMIT <- INDEX
	LHLD	RPP
	MOV	E,M	; (DE) <- (R1) = INDEX
	INX	H
	MOV	D,M
	INX	H
	MOV	M,E	; (R2) <- (DE) = LIMIT
	INX	H
	MOV	M,D
	JMP	NEXT
;
	DB	82H	; >R
	DB	'>'
	DB	'R'+80H
	DW	LEAVE-8
TOR	DW	$+2	;(R1) <- (S1)
	POP	D	; (DE) <- (S1)
	LHLD	RPP
	DCX	H	; (RP) <- (RP) - 2
	DCX	H
	SHLD	RPP
	MOV	M,E	; ((HL)) <- (DE)
	INX	H
	MOV	M,D
	JMP	NEXT
;
	DB	82H	; R>
	DB	'R'
	DB	'>'+80H
	DW	TOR-5
FROMR	DW	$+2	;(S1) <- (R1)
	LHLD	RPP
	MOV	E,M	; (DE) <- (R1)
	INX	H
	MOV	D,M
	INX	H
	SHLD	RPP	; (RP) <- (RP) + 2
	PUSH	D	; (S1) <- (DE)
	JMP	NEXT
;
	DB	81H	; R
	DB	'R'+80H
	DW	FROMR-5
RR	DW	IDO+2
;
	DB	82H	; 0=
	DB	'0'
	DB	'='+80H
	DW	RR-4
ZEQU	DW	$+2
	POP	H	; (HL) <- (S1)
	MOV	A,L
	ORA	H	; IF (HL) = 0
	LXI	H,0	; THEN (HL) <- FALSE
	JNZ	ZEQU1
	INX	H	; ELSE (HL) <- TRUE
ZEQU1	JMP	HPUSH	; (S1) <- (HL)
;
	DB	82H	; 0<
	DB	'0'
	DB	'<'+80H
	DW	ZEQU-5
ZLESS	DW	$+2
	POP	H	; (HL) <- (S1)
	DAD	H	; IF (HL) >= 0
	LXI	H,0	; THEN (HL) <- FALSE
	JNC	ZLES1
	INX	H	; ELSE (HL) <- TRUE
ZLES1	JMP	HPUSH	; (S1) <- (HL)
;
	DB	81H	; +
	DB	'+'+80H
	DW	ZLESS-5
PLUS	DW	$+2	;(S1) <- (S1) + (S2)
	POP	D
	POP	H
	DAD	D
	JMP	HPUSH
;
	DB	82H	; D+	(4-2)
	DB	'D'	; XLW XHW  YLW YHW  ---  SLW SHW
	DB	'+'+80H	; S4  S3   S2  S1        S2  S1
	DW	PLUS-4
DPLUS	DW	$+2
	LXI	H,6
	DAD	SP	; ((HL)) = XLW
	MOV	E,M	; (DE) = XLW
	MOV	M,C	; SAVE IP ON STACK
	INX	H
	MOV	D,M
	MOV	M,B
	POP	B	; (BC) <- YHW
	POP	H	; (HL) <- YLW
	DAD	D
	XCHG		; (DE) <- YLW + XLW = SUM.LW
	POP	H	; (HL) <- XHW
	MOV	A,L
	ADC	C
	MOV	L,A	; (HL) <- YHW + XHW + CARRY
	MOV	A,H
	ADC	B
	MOV	H,A
	POP	B	; RESTORE IP
	PUSH	D	; (S2) <- SUM.LW
	JMP	HPUSH	; (S1) <- SUM.HW
;
	DB	85H	; MINUS
	DB	'MINU'
	DB	'S'+80H
	DW	DPLUS-5
MINUS	DW	$+2	;(S1) <- -(S1)	( 2'S COMPLEMENT )
	POP	H
	MOV	A,L
	CMA
	MOV	L,A
	MOV	A,H
	CMA
	MOV	H,A
	INX	H
	JMP	HPUSH
;
	DB	86H	; DMINUS
	DB	'DMINU'
	DB	'S'+80H
	DW	MINUS-8
DMINU	DW	$+2
	POP	H	; (HL) <- HW
	POP	D	; (DE) <- LW
	SUB	A
	SUB	E	; (DE) <- 0 - (DE)
	MOV	E,A
	MVI	A,0
	SBB	D
	MOV	D,A
	MVI	A,0
	SBB	L	; (HL) <- 0 - (HL)
	MOV	L,A
	MVI	A,0
	SBB	H
	MOV	H,A
	PUSH	D	; (S2) <- LW
	JMP	HPUSH	; (S1) <- HW
;
	DB	84H	; OVER
	DB	'OVE'
	DB	'R'+80H
	DW	DMINU-9
OVER	DW	$+2
	POP	D
	POP	H
	PUSH	H
	JMP	DPUSH
;
	DB	84H	; DROP
	DB	'DRO'
	DB	'P'+80H
	DW	OVER-7
DROP	DW	$+2
	POP	H
	JMP	NEXT
;
	DB	84H	; SWAP
	DB	'SWA'
	DB	'P'+80H
	DW	DROP-7
SWAP	DW	$+2
	POP	H
	XTHL
	JMP	HPUSH
;
	DB	83H	; DUP
	DB	'DU'
	DB	'P'+80H
	DW	SWAP-7
DUP	DW	$+2
	POP	H
	PUSH	H
	JMP	HPUSH
;
	DB	84H	; 2DUP
	DB	'2DU'
	DB	'P'+80H
	DW	DUP-6
TDUP	DW	$+2
	POP	H
	POP	D
	PUSH	D
	PUSH	H
	JMP	DPUSH
;
	DB	82H	; PLUS STORE
	DB	'+'
	DB	'!'+80H
	DW	TDUP-7
PSTOR	DW	$+2	;((S1)) <- ((S1)) + (S2)
	POP	H	; (HL) <- (S1) = ADDR
	POP	D	; (DE) <- (S2) = INCR
	MOV	A,M	; ((HL)) <- ((HL)) + (DE)
	ADD	E
	MOV	M,A
	INX	H
	MOV	A,M
	ADC	D
	MOV	M,A
	JMP	NEXT
;
	DB	86H	; TOGGLE
	DB	'TOGGL'
	DB	'E'+80H
	DW	PSTOR-5
TOGGL	DW	$+2	;((S2)) <- ((S2)) XOR (S1)LB
	POP	D	; (E) <- BYTE MASK
	POP	H	; (HL) <- ADDR
	MOV	A,M
	XRA	E
	MOV	M,A	; (ADDR) <- (ADDR) XOR (E)
	JMP	NEXT
;
	DB	81H	; @
	DB	'@'+80H
	DW	TOGGL-9
AT	DW	$+2	;(S1) <- ((S1))
	POP	H	; (HL) <- ADDR
	MOV	E,M	; (DE) <- (ADDR)
	INX	H
	MOV	D,M
	PUSH	D	; (S1) <- (DE)
	JMP	NEXT
;
	DB	82H	; C@
	DB	'C'
	DB	'@'+80H
	DW	AT-4
CAT	DW	$+2	;(S1) <- ((S1))LB
	POP	H	; (HL) <- ADDR
	MOV	L,M	; (HL) <- (ADDR)LB
	MVI	H,0
	JMP	HPUSH
;
	DB	82H	; 2@
	DB	'2'
	DB	'@'+80H
	DW	CAT-5
TAT	DW	$+2
	POP	H	; (HL) <- ADDR HW
	LXI	D,2
	DAD	D	; (HL) <- ADDR LW
	MOV	E,M	; (DE) <- LW
	INX	H
	MOV	D,M
	PUSH	D	; (S2) <- LW
	LXI	D,-3	; (HL) <- ADDR HW
	DAD	D
	MOV	E,M	; (DE) <- HW
	INX	H
	MOV	D,M
	PUSH	D	; (S1) <- HW
	JMP	NEXT
;
	DB	81H	; STORE
	DB	'!'+80H
	DW	TAT-5
STORE	DW	$+2	;((S1)) <- (S2)
	POP	H	; (HL) <- (S1) = ADDR
	POP	D	; (DE) <- (S2) = VALUE
	MOV	M,E	; ((HL)) <- (DE)
	INX	H
	MOV	M,D
	JMP	NEXT
;
	DB	82H	; C STORE
	DB	'C'
	DB	'!'+80H
	DW	STORE-4
CSTOR	DW	$+2	;((S1))LB <- (S2)LB
	POP	H	; (HL) <- (S1) = ADDR
	POP	D	; (DE) <- (S2) = BYTE
	MOV	M,E	; ((HL))LB <- (E)
	JMP	NEXT
;
	DB	82H	; 2 STORE
	DB	'2'
	DB	'!'+80H
	DW	CSTOR-5
TSTOR	DW	$+2
	POP	H	; (HL) <- ADDR
	POP	D	; (DE) <- HW
	MOV	M,E	; (ADDR) <- HW
	INX	H
	MOV	M,D
	INX	H	; (HL) <- ADDR LW
	POP	D	; (DE) <- LW
	MOV	M,E	; (ADDR+2) <- LW
	INX	H
	MOV	M,D
	JMP	NEXT
;
	DB	0C1H	; :
	DB	':'+80H
	DW	TSTOR-5
COLON	DW	DOCOL
	DW	QEXEC
	DW	SCSP
	DW	CURR
	DW	AT
	DW	CONT
	DW	STORE
	DW	CREAT
	DW	RBRAC
	DW	PSCOD
DOCOL	LHLD	RPP
	DCX	H	; (R1) <- (IP)
	MOV	M,B
	DCX	H	; (RP) <- (RP) - 2
	MOV	M,C
	SHLD	RPP
	INX	D	; (DE) <- CFA+2 = (W)
	MOV	C,E	; (IP) <- (DE) = (W)
	MOV	B,D
	JMP	NEXT
;
	DB	0C1H	; ;
	DB	';'+80H
	DW	COLON-4
SEMI	DW	DOCOL
	DW	QCSP
	DW	COMP
	DW	SEMIS
	DW	SMUDG
	DW	LBRAC
	DW	SEMIS
;
	DB	84H	; NOOP
	DB	'NOO'
	DB	'P'+80H
	DW	SEMI-4
NOOP	DW	DOCOL
	DW	SEMIS
 ;
	DB	88H	; CONSTANT
	DB	'CONSTAN'
	DB	'T'+80H
	DW	NOOP-7
CON	DW	DOCOL
	DW	CREAT
	DW	SMUDG
	DW	COMMA
	DW	PSCOD
DOCON	INX	D	; (DE) <- PFA
	XCHG
	MOV	E,M	; (DE) <- (PFA)
	INX	H
	MOV	D,M
	PUSH	D	; (S1) <- (PFA)
	JMP	NEXT
;
	DB	88H	; VARIABLE
	DB	'VARIABL'
	DB	'E'+80H
	DW	CON-0BH
VAR	DW	DOCOL
	DW	CON
	DW	PSCOD
DOVAR	INX	D	; (DE) <- PFA
	PUSH	D	; (S1) <- PFA
	JMP	NEXT
;
	DB	84H	; USER
	DB	'USE'
	DB	'R'+80H
	DW	VAR-0BH
USER	DW	DOCOL
	DW	CON
	DW	PSCOD
DOUSE	INX	D	; (DE) <- PFA
	XCHG
	MOV	E,M	; (DE) <- USER VARIABLE OFFSET
	MVI	D,0
	LHLD	UP	; (HL) <- USER VARIABLE BASE ADDR
	DAD	D	; (HL) <- (HL) + (DE)
	JMP	HPUSH	; (S1) <- BASE + OFFSET
;
	DB	81H	; 0
	DB	'0'+80H
	DW	USER-7
ZERO	DW	DOCON
	DW	0
;
	DB	81H	; 1
	DB	'1'+80H
	DW	ZERO-4
ONE	DW	DOCON
	DW	1
;
	DB	81H	; 2
	DB	'2'+80H
	DW	ONE-4
TWO	DW	DOCON
	DW	2
;
	DB	81H	; 3
	DB	'3'+80H
	DW	TWO-4
THREE	DW	DOCON
	DW	3
;
	DB	82H	; BL
	DB	'B'
	DB	'L'+80H
	DW	THREE-4
BL	DW	DOCON
	DW	20H
;
	DB	83H	; C/L ( CHARACTERS/LINE )
	DB	'C/'
	DB	'L'+80H
	DW	BL-5
CSLL	DW	DOCON
	DW	64
;
	DB	85H	; FIRST
	DB	'FIRS'
	DB	'T'+80H
	DW	CSLL-6
FIRST	DW	DOCON
	DW	BUF1
;
	DB	85H	; LIMIT
	DB	'LIMI'
	DB	'T'+80H
	DW	FIRST-8
LIMIT	DW	DOCON
	DW	EM
;
	DB	85H	; B/BUF ( BYTES/BUFFER )
	DB	'B/BU'
	DB	'F'+80H
	DW	LIMIT-8
BBUF	DW	DOCON
	DW	KBBUF
;
	DB	85H	; B/SCR ( BUFFERS/SCREEN )
	DB	'B/SC'
	DB	'R'+80H
	DW	BBUF-8
BSCR	DW	DOCON
	DW	400H/KBBUF
;
	DB	87H	; +ORIGIN
	DB	'+ORIGI'
	DB	'N'+80H
	DW	BSCR-8
PORIG	DW	DOCOL
	DW	LIT
	DW	ORIG
	DW	PLUS
	DW	SEMIS
;
;	USER VARIABLES
;
	DB	82H	; S0
	DB	'S'
	DB	'0'+80H
	DW	PORIG-0AH
SZERO	DW	DOUSE
	DW	6
;
	DB	82H	; R0
	DB	'R'
	DB	'0'+80H
	DW	SZERO-5
RZERO	DW	DOUSE
	DW	8
;
	DB	83H	; TIB
	DB	'TI'
	DB	'B'+80H
	DW	RZERO-5
TIB	DW	DOUSE
	DB	0AH
;
	DB	85H	; WIDTH
	DB	'WIDT'
	DB	'H'+80H
	DW	TIB-6
WIDTH	DW	DOUSE
	DB	0CH
;
	DB	87H	; WARNING
	DB	'WARNIN'
	DB	'G'+80H
	DW	WIDTH-8
WARN	DW	DOUSE
	DB	0EH
;
	DB	85H	; FENCE
	DB	'FENC'
	DB	'E'+80H
	DW	WARN-0AH
FENCE	DW	DOUSE
	DB	10H
;
	DB	82H	; DP
	DB	'D'
	DB	'P'+80H
	DW	FENCE-8
DP	DW	DOUSE
	DB	12H
;
	DB	88H	; VOC-LINK
	DB	'VOC-LIN'
	DB	'K'+80H
	DW	DP-5
VOCL	DW	DOUSE
	DW	14H
;
	DB	83H	; BLK
	DB	'BL'
	DB	'K'+80H
	DW	VOCL-0BH
BLK	DW	DOUSE
	DB	16H
;
	DB	82H	; IN
	DB	'I'
	DB	'N'+80H
	DW	BLK-6
INN	DW	DOUSE
	DB	18H
;
	DB	83H	; OUT
	DB	'OU'
	DB	'T'+80H
	DW	INN-5
OUTT	DW	DOUSE
	DB	1AH
;
	DB	83H	; SCR
	DB	'SC'
	DB	'R'+80H
	DW	OUTT-6
SCR	DW	DOUSE
	DB	1CH
;
	DB	86H	; OFFSET
	DB	'OFFSE'
	DB	'T'+80H
	DW	SCR-6
OFSET	DW	DOUSE
	DB	1EH
;
	DB	87H	; CONTEXT
	DB	'CONTEX'
	DB	'T'+80H
	DW	OFSET-9
CONT	DW	DOUSE
	DB	20H
;
	DB	87H	; CURRENT
	DB	'CURREN'
	DB	'T'+80H
	DW	CONT-0AH
CURR	DW	DOUSE
	DB	22H
;
	DB	85H	; STATE
	DB	'STAT'
	DB	'E'+80H
	DW	CURR-0AH
STATE	DW	DOUSE
	DB	24H
;
	DB	84H	; BASE
	DB	'BAS'
	DB	'E'+80H
	DW	STATE-8
BASE	DW	DOUSE
	DB	26H
;
	DB	83H	; DPL
	DB	'DP'
	DB	'L'+80H
	DW	BASE-7
DPL	DW	DOUSE
	DB	28H
;
	DB	83H	; FLD
	DB	'FL'
	DB	'D'+80H
	DW	DPL-6
FLD	DW	DOUSE
	DB	2AH
;
	DB	83H	; CSP
	DB	'CS'
	DB	'P'+80H
	DW	FLD-6
CSPP	DW	DOUSE
	DB	2CH
;
	DB	82H	; R#
	DB	'R'
	DB	'#'+80H
	DW	CSPP-6
RNUM	DW	DOUSE
	DB	2EH
;
	DB	83H	; HLD
	DB	'HL'
	DB	'D'+80H
	DW	RNUM-5
HLD	DW	DOUSE
	DW	30H
;
;	END OF USER VARIABLES
;
	DB	82H	; 1+
	DB	'1'
	DB	'+'+80H
	DW	HLD-6
ONEP	DW	DOCOL
	DW	ONE
	DW	PLUS
	DW	SEMIS
;
	DB	82H	; 2+
	DB	'2'
	DB	'+'+80H
	DW	ONEP-5
TWOP	DW	DOCOL
	DW	TWO
	DW	PLUS
	DW	SEMIS
;
	DB	84H	; HERE
	DB	'HER'
	DB	'E'+80H
	DW	TWOP-5
HERE	DW	DOCOL
	DW	DP
	DW	AT
	DW	SEMIS
;
	DB	85H	; ALLOT
	DB	'ALLO'
	DB	'T'+80H
	DW	HERE-7
ALLOT	DW	DOCOL
	DW	DP
	DW	PSTOR
	DW	SEMIS
;
	DB	81H	; ,
	DB	','+80H
	DW	ALLOT-8
COMMA	DW	DOCOL
	DW	HERE
	DW	STORE
	DW	TWO
	DW	ALLOT
	DW	SEMIS
;
	DB	82H	; C,
	DB	'C'
	DB	','+80H
	DW	COMMA-4
CCOMM	DW	DOCOL
	DW	HERE
	DW	CSTOR
	DW	ONE
	DW	ALLOT
	DW	SEMIS
;
;	SUBROUTINE USED BY - AND <
;			; (HL) <- (HL) - (DE)
SSUB	MOV	A,L	; LB
	SUB	E
	MOV	L,A
	MOV	A,H	; HB
	SBB	D
	MOV	H,A
	RET
;
	DB	81H	; -
	DB	'-'+80H
	DW	CCOMM-5
SUBB	DW	$+2
	POP	D	; (DE) <- (S1) = Y
	POP	H	; (HL) <- (S2) = X
	CALL	SSUB
	JMP	HPUSH	; (S1) <- X - Y
;
	DB	81H	; =
	DB	'='+80H
	DW	SUBB-4
EQUAL	DW	DOCOL
	DW	SUBB
	DW	ZEQU
	DW	SEMIS
;
	DB	81H	; <
	DB	'<'+80H		; X  <  Y
	DW	EQUAL-4		; S2    S1
LESS	DW	$+2
	POP	D	; (DE) <- (S1) = Y
	POP	H	; (HL) <- (S2) = X
	MOV	A,D	; IF X & Y HAVE SAME SIGNS
	XRA	H
	JM	LES1
	CALL	SSUB	; (HL) <- X - Y
LES1	INR	H	; IF (HL) >= 0
	DCR	H
	JM	LES2
	LXI	H,0	; THEN X >= Y
	JMP	HPUSH	; (S1) <- FALSE
LES2	LXI	H,1	; ELSE X < Y
	JMP	HPUSH	; (S1) <- TRUE
;
	DB	82H	; U< ( UNSIGNED < )
	DB	'U'
	DB	'<'+80H
	DW	LESS-4
ULESS	DW	DOCOL,TDUP
	DW	XORR,ZLESS
	DW	ZBRAN,ULES1-$	; IF
	DW	DROP,ZLESS
	DW	ZEQU
	DW	BRAN,ULES2-$
ULES1	DW	SUBB,ZLESS	; ELSE
ULES2	DW	SEMIS		; ENDIF
;
	DB	81H	; >
	DB	'>'+80H
	DW	ULESS-5
GREAT	DW	DOCOL
	DW	SWAP
	DW	LESS
	DW	SEMIS
;
	DB	83H	; ROT
	DB	'RO'
	DB	'T'+80H
	DW	GREAT-4
ROT	DW	$+2
	POP	D
	POP	H
	XTHL
	JMP	DPUSH
;
	DB	85H	; SPACE
	DB	'SPAC'
	DB	'E'+80H
	DW	ROT-6
SPACE	DW	DOCOL
	DW	BL
	DW	EMIT
	DW	SEMIS
;
	DB	84H	; -DUP
	DB	'-DU'
	DB	'P'+80H
	DW	SPACE-8
DDUP	DW	DOCOL
	DW	DUP
	DW	ZBRAN	; IF
	DW	DDUP1-$
	DW	DUP	; ENDIF
DDUP1	DW	SEMIS
;
	DB	88H	; TRAVERSE
	DB	'TRAVERS'
	DB	'E'+80H
	DW	DDUP-7
TRAV	DW	DOCOL
	DW	SWAP
TRAV1	DW	OVER	; BEGIN
	DW	PLUS
	DW	LIT
	DW	7FH
	DW	OVER
	DW	CAT
	DW	LESS
	DW	ZBRAN	; UNTIL
	DW	TRAV1-$
	DW	SWAP
	DW	DROP
	DW	SEMIS
;
	DB	86H	; LATEST
	DB	'LATES'
	DB	'T'+80H
	DW	TRAV-0BH
LATES	DW	DOCOL
	DW	CURR
	DW	AT
	DW	AT
	DW	SEMIS
;
	DB	83H	; LFA
	DB	'LF'
	DB	'A'+80H
	DW	LATES-9
LFA	DW	DOCOL
	DW	LIT
	DW	4
	DW	SUBB
	DW	SEMIS
;
	DB	83H	; CFA
	DB	'CF'
	DB	'A'+80H
	DW	LFA-6
CFA	DW	DOCOL
	DW	TWO
	DW	SUBB
	DW	SEMIS
;
	DB	83H	; NFA
	DB	'NF'
	DB	'A'+80H
	DW	CFA-6
NFA	DW	DOCOL
	DW	LIT
	DW	5
	DW	SUBB
	DW	LIT
	DW	-1
	DW	TRAV
	DW	SEMIS
;
	DB	83H	; PFA
	DB	'PF'
	DB	'A'+80H
	DW	NFA-6
PFA	DW	DOCOL
	DW	ONE
	DW	TRAV
	DW	LIT
	DW	5
	DW	PLUS
	DW	SEMIS
;
	DB	84H	; STORE CSP
	DB	'!CS'
	DB	'P'+80H
	DW	PFA-6
SCSP	DW	DOCOL
	DW	SPAT
	DW	CSPP
	DW	STORE
	DW	SEMIS
;
	DB	86H	; ?ERROR
	DB	'?ERRO'
	DB	'R'+80H
	DW	SCSP-7
QERR	DW	DOCOL
	DW	SWAP
	DW	ZBRAN	; IF
	DW	QERR1-$
	DW	ERROR
	DW	BRAN	; ELSE
	DW	QERR2-$
QERR1	DW	DROP	; ENDIF
QERR2	DW	SEMIS
;
	DB	85H	; ?COMP
	DB	'?COM'
	DB	'P'+80H
	DW	QERR-9
QCOMP	DW	DOCOL
	DW	STATE
	DW	AT
	DW	ZEQU
	DW	LIT
	DW	11H
	DW	QERR
	DW	SEMIS
;
	DB	85H	; ?EXEC
	DB	'?EXE'
	DB	'C'+80H
	DW	QCOMP-8
QEXEC	DW	DOCOL
	DW	STATE
	DW	AT
	DW	LIT
	DW	12H
	DW	QERR
	DW	SEMIS
;
	DB	86H	; ?PAIRS
	DB	'?PAIR'
	DB	'S'+80H
	DW	QEXEC-8
QPAIR	DW	DOCOL
	DW	SUBB
	DW	LIT
	DW	13H
	DW	QERR
	DW	SEMIS
;
	DB	84H	; ?CSP
	DB	'?CS'
	DB	'P'+80H
	DW	QPAIR-9
QCSP	DW	DOCOL
	DW	SPAT
	DW	CSPP
	DW	AT
	DW	SUBB
	DW	LIT
	DW	14H
	DW	QERR
	DW	SEMIS
;
	DB	88H	; ?LOADING
	DB	'?LOADIN'
	DB	'G'+80H
	DW	QCSP-7
QLOAD	DW	DOCOL
	DW	BLK
	DW	AT
	DW	ZEQU
	DW	LIT
	DW	16H
	DW	QERR
	DW	SEMIS
;
	DB	87H	; COMPILE
	DB	'COMPIL'
	DB	'E'+80H
	DW	QLOAD-0BH
COMP	DW	DOCOL
	DW	QCOMP
	DW	FROMR
	DW	DUP
	DW	TWOP
	DW	TOR
	DW	AT
	DW	COMMA
	DW	SEMIS
;
	DB	0C1H	; [
	DB	'['+80H
	DW	COMP-0AH
LBRAC	DW	DOCOL
	DW	ZERO
	DW	STATE
	DW	STORE
	DW	SEMIS
;
	DB	81H	; ]
	DB	']'+80H
	DW	LBRAC-4
RBRAC	DW	DOCOL
	DW	LIT,0C0H
	DW	STATE,STORE
	DW	SEMIS
;
	DB	86H	; SMUDGE
	DB	'SMUDG'
	DB	'E'+80H
	DW	RBRAC-4
SMUDG	DW	DOCOL
	DW	LATES
	DW	LIT
	DW	20H
	DW	TOGGL
	DW	SEMIS
;
	DB	83H	; HEX
	DB	'HE'
	DB	'X'+80H
	DW	SMUDG-9
HEX	DW	DOCOL
	DW	LIT
	DW	10H
	DW	BASE
	DW	STORE
	DW	SEMIS
;
	DB	87H	; DECIMAL
	DB	'DECIMA'
	DB	'L'+80H
	DW	HEX-6
DEC	DW	DOCOL
	DW	LIT
	DW	0AH
	DW	BASE
	DW	STORE
	DW	SEMIS
;
	DB	87H	; (;CODE)
	DB	'(;CODE'
	DB	')'+80H
	DW	DEC-0AH
PSCOD	DW	DOCOL
	DW	FROMR
	DW	LATES
	DW	PFA
	DW	CFA
	DW	STORE
	DW	SEMIS
;
	DB	0C5H	; ;CODE
	DB	';COD'
	DB	'E'+80H
	DW	PSCOD-0AH
SEMIC	DW	DOCOL
	DW	QCSP
	DW	COMP
	DW	PSCOD
	DW	LBRAC
SEMI1	DW	NOOP	; ( ASSEMBLER )
	DW	SEMIS
;
	DB	87H	; <BUILDS
	DB	'<BUILD'
	DB	'S'+80H
	DW	SEMIC-8
BUILD	DW	DOCOL
	DW	ZERO
	DW	CON
	DW	SEMIS
;
	DB	85H	; DOES>
	DB	'DOES'
	DB	'>'+80H
	DW	BUILD-0AH
DOES	DW	DOCOL
	DW	FROMR
	DW	LATES
	DW	PFA
	DW	STORE
	DW	PSCOD
DODOE	LHLD	RPP	; (HL) <- (RP)
	DCX	H
	MOV	M,B	; (R1) <- (IP) = PFA = (SUBSTITUTE CFA)
	DCX	H
	MOV	M,C
	SHLD	RPP	; (RP) <- (RP) - 2
	INX	D	; (DE) <- PFA = (SUBSTITUTE CFA)
	XCHG
	MOV	C,M	; (IP) <- (SUBSTITUTE CFA)
	INX	H
	MOV	B,M
	INX	H
	JMP	HPUSH	; (S1) <- PFA+2 = SUBSTITUTE PFA
;
	DB	85H	; COUNT
	DB	'COUN'
	DB	'T'+80H
	DW	DOES-8
COUNT	DW	DOCOL
	DW	DUP
	DW	ONEP
	DW	SWAP
	DW	CAT
	DW	SEMIS
;
	DB	84H	; TYPE
	DB	'TYP'
	DB	'E'+80H
	DW	COUNT-8
TYPE	DW	DOCOL
	DW	DDUP
	DW	ZBRAN	; IF
	DW	TYPE1-$
	DW	OVER
	DW	PLUS
	DW	SWAP
	DW	XDO	; DO
TYPE2	DW	IDO
	DW	CAT
	DW	EMIT
	DW	XLOOP	; LOOP
	DW	TYPE2-$
	DW	BRAN	; ELSE
	DW	TYPE3-$
TYPE1	DW	DROP	; ENDIF
TYPE3	DW	SEMIS
;
	DB	89H	; -TRAILING
	DB	'-TRAILIN'
	DB	'G'+80H
	DW	TYPE-7
DTRAI	DW	DOCOL
	DW	DUP
	DW	ZERO
	DW	XDO	; DO
DTRA1	DW	OVER
	DW	OVER
	DW	PLUS
	DW	ONE
	DW	SUBB
	DW	CAT
	DW	BL
	DW	SUBB
	DW	ZBRAN	; IF
	DW	DTRA2-$
	DW	LEAVE
	DW	BRAN	; ELSE
	DW	DTRA3-$
DTRA2	DW	ONE
	DW	SUBB	; ENDIF
DTRA3	DW	XLOOP	; LOOP
	DW	DTRA1-$
	DW	SEMIS
;
	DB	84H	; (.")
	DB	'(."'
	DB	')'+80H
	DW	DTRAI-0CH
PDOTQ	DW	DOCOL
	DW	RR
	DW	COUNT
	DW	DUP
	DW	ONEP
	DW	FROMR
	DW	PLUS
	DW	TOR
	DW	TYPE
	DW	SEMIS
;
	DB	0C2H	; ."
	DB	'.'
	DB	'"'+80H
	DW	PDOTQ-7
DOTQ	DW	DOCOL
	DW	LIT
	DW	22H
	DW	STATE
	DW	AT
	DW	ZBRAN	; IF
	DW	DOTQ1-$
	DW	COMP
	DW	PDOTQ
	DW	WORD
	DW	HERE
	DW	CAT
	DW	ONEP
	DW	ALLOT
	DW	BRAN	; ELSE
	DW	DOTQ2-$
DOTQ1	DW	WORD
	DW	HERE
	DW	COUNT
	DW	TYPE	; ENDIF
DOTQ2	DW	SEMIS
;
	DB	86H	; EXPECT
	DB	'EXPEC'
	DB	'T'+80H
	DW	DOTQ-5
EXPEC	DW	DOCOL
	DW	OVER
	DW	PLUS
	DW	OVER
	DW	XDO	; DO
EXPE1	DW	KEY
	DW	DUP
	DW	LIT
	DW	0EH
	DW	PORIG
	DW	AT
	DW	EQUAL
	DW	ZBRAN	; IF
	DW	EXPE2-$
	DW	DROP
	DW	DUP
	DW	IDO
	DW	EQUAL
	DW	DUP
	DW	FROMR
	DW	TWO
	DW	SUBB
	DW	PLUS
	DW	TOR
	DW	ZBRAN	; IF
	DW	EXPE6-$
	DW	LIT
	DW	BELL
	DW	BRAN	; ELSE
	DW	EXPE7-$
EXPE6	DW	LIT
	DW	BSOUT	; ENDIF
EXPE7	DW	BRAN	; ELSE
	DW	EXPE3-$
EXPE2	DW	DUP
	DW	LIT
	DW	0DH
	DW	EQUAL
	DW	ZBRAN	; IF
	DW	EXPE4-$
	DW	LEAVE
	DW	DROP
	DW	BL
	DW	ZERO
	DW	BRAN	; ELSE
	DW	EXPE5-$
EXPE4	DW	DUP	; ENDIF
EXPE5	DW	IDO
	DW	CSTOR
	DW	ZERO
	DW	IDO
	DW	ONEP
	DW	STORE	; ENDIF
EXPE3	DW	EMIT
	DW	XLOOP	; LOOP
	DW	EXPE1-$
	DW	DROP
	DW	SEMIS
;
	DB	85H	; QUERY
	DB	'QUER'
	DB	'Y'+80H
	DW	EXPEC-9
QUERY	DW	DOCOL
	DW	TIB
	DW	AT
	DW	LIT
	DW	50H
	DW	EXPEC
	DW	ZERO
	DW	INN
	DW	STORE
	DW	SEMIS
;
	DB	0C1H	; 0 (NULL)
	DB	80H
	DW	QUERY-8
NULL	DW	DOCOL
	DW	BLK
	DW	AT
	DW	ZBRAN	; IF
	DW	NULL1-$
	DW	ONE
	DW	BLK
	DW	PSTOR
	DW	ZERO
	DW	INN
	DW	STORE
	DW	BLK
	DW	AT
	DW	BSCR
	DW	ONE
	DW	SUBB
	DW	ANDD
	DW	ZEQU
	DW	ZBRAN	; IF
	DW	NULL2-$
	DW	QEXEC
	DW	FROMR
	DW	DROP	; ENDIF
NULL2	DW	BRAN	; ELSE
	DW	NULL3-$
NULL1	DW	FROMR
	DW	DROP	; ENDIF
NULL3	DW	SEMIS
;
	DB	84H	; FILL
	DB	'FIL'
	DB	'L'+80H
	DW	NULL-4
FILL	DW	$+2
	MOV	L,C
	MOV	H,B
	POP	D
	POP	B
	XTHL
	XCHG
FILL1	MOV	A,B	; BEGIN
	ORA	C
	JZ	FILL2	; WHILE
	MOV	A,L
	STAX	D
	INX	D
	DCX	B
	JMP	FILL1	; REPEAT
FILL2	POP	B
	JMP	NEXT
;
	DB	85H	; ERASE
	DB	'ERAS'
	DB	'E'+80H
	DW	FILL-7
ERASEE	DW	DOCOL
	DW	ZERO
	DW	FILL
	DW	SEMIS
;
	DB	86H	; BLANKS
	DB	'BLANK'
	DB	'S'+80H
	DW	ERASEE-8
BLANK	DW	DOCOL
	DW	BL
	DW	FILL
	DW	SEMIS
;
	DB	84H	; HOLD
	DB	'HOL'
	DB	'D'+80H
	DW	BLANK-9
HOLD	DW	DOCOL
	DW	LIT
	DW	-1
	DW	HLD
	DW	PSTOR
	DW	HLD
	DW	AT
	DW	CSTOR
	DW	SEMIS
;
	DB	83H	; PAD
	DB	'PA'
	DB	'D'+80H
	DW	HOLD-7
PAD	DW	DOCOL
	DW	HERE
	DW	LIT
	DW	44H
	DW	PLUS
	DW	SEMIS
;
	DB	84H	; WORD
	DB	'WOR'
	DB	'D'+80H
	DW	PAD-6
WORD	DW	DOCOL
	DW	BLK
	DW	AT
	DW	ZBRAN	; IF
	DW	WORD1-$
	DW	BLK
	DW	AT
	DW	BLOCK
	DW	BRAN	; ELSE
	DW	WORD2-$
WORD1	DW	TIB
	DW	AT	; ENDIF
WORD2	DW	INN
	DW	AT
	DW	PLUS
	DW	SWAP
	DW	ENCL
	DW	HERE
	DW	LIT
	DW	22H
	DW	BLANK
	DW	INN
	DW	PSTOR
	DW	OVER
	DW	SUBB
	DW	TOR
	DW	RR
	DW	HERE
	DW	CSTOR
	DW	PLUS
	DW	HERE
	DW	ONEP
	DW	FROMR
	DW	CMOVE
	DW	SEMIS
;
	DB	88H	; (NUMBER)
	DB	'(NUMBER'
	DB	')'+80H
	DW	WORD-7
PNUMB	DW	DOCOL
PNUM1	DW	ONEP	; BEGIN
	DW	DUP
	DW	TOR
	DW	CAT
	DW	BASE
	DW	AT
	DW	DIGIT
	DW	ZBRAN	; WHILE
	DW	PNUM2-$
	DW	SWAP
	DW	BASE
	DW	AT
	DW	USTAR
	DW	DROP
	DW	ROT
	DW	BASE
	DW	AT
	DW	USTAR
	DW	DPLUS
	DW	DPL
	DW	AT
	DW	ONEP
	DW	ZBRAN	; IF
	DW	PNUM3-$
	DW	ONE
	DW	DPL
	DW	PSTOR	; ENDIF
PNUM3	DW	FROMR
	DW	BRAN	; REPEAT
	DW	PNUM1-$
PNUM2	DW	FROMR
	DW	SEMIS
;
	DB	86H	; NUMBER
	DB	'NUMBE'
	DB	'R'+80H
	DW	PNUMB-0BH
NUMB	DW	DOCOL
	DW	ZERO
	DW	ZERO
	DW	ROT
	DW	DUP
	DW	ONEP
	DW	CAT
	DW	LIT
	DW	2DH
	DW	EQUAL
	DW	DUP
	DW	TOR
	DW	PLUS
	DW	LIT
	DW	-1
NUMB1	DW	DPL	; BEGIN
	DW	STORE
	DW	PNUMB
	DW	DUP
	DW	CAT
	DW	BL
	DW	SUBB
	DW	ZBRAN	; WHILE
	DW	NUMB2-$
	DW	DUP
	DW	CAT
	DW	LIT
	DW	2EH
	DW	SUBB
	DW	ZERO
	DW	QERR
	DW	ZERO
	DW	BRAN	; REPEAT
	DW	NUMB1-$
NUMB2	DW	DROP
	DW	FROMR
	DW	ZBRAN	; IF
	DW	NUMB3-$
	DW	DMINU	; ENDIF
NUMB3	DW	SEMIS
;
	DB	85H	; -FIND	(0-3) SUCCESS
	DB	'-FIN'	; (0-1) FAILURE
	DB	'D'+80H
	DW	NUMB-9
DFIND	DW	DOCOL
	DW	BL
	DW	WORD
	DW	HERE
	DW	CONT
	DW	AT
	DW	AT
	DW	PFIND
	DW	DUP
	DW	ZEQU
	DW	ZBRAN	; IF
	DW	DFIN1-$
	DW	DROP
	DW	HERE
	DW	LATES
	DW	PFIND	; ENDIF
DFIN1	DW	SEMIS
;
	DB	87H	; (ABORT)
	DB	'(ABORT'
	DB	')'+80H
	DW	DFIND-8
PABOR	DW	DOCOL
	DW	ABORT
	DW	SEMIS
;
	DB	85H	; ERROR
	DB	'ERRO'
	DB	'R'+80H
	DW	PABOR-0AH
ERROR	DW	DOCOL
	DW	WARN
	DW	AT
	DW	ZLESS
	DW	ZBRAN	; IF
	DW	ERRO1-$
	DW	PABOR	; ENDIF
ERRO1	DW	HERE
	DW	COUNT
	DW	TYPE
	DW	PDOTQ
	DB	2
	DB	'? '
	DW	MESS
	DW	SPSTO
;	CHANGE FROM FIG MODEL
;	DW	INN,AT,BLK,AT
	DW	BLK,AT
	DW	DDUP
	DW	ZBRAN,ERRO2-$	; IF
	DW	INN,AT
	DW	SWAP		; ENDIF
ERRO2	DW	QUIT
;
	DB	83H	; ID.
	DB	'ID'
	DB	'.'+80H
	DW	ERROR-8
IDDOT	DW	DOCOL
	DW	PAD
	DW	LIT
	DW	20H
	DW	LIT
	DW	5FH
	DW	FILL
	DW	DUP
	DW	PFA
	DW	LFA
	DW	OVER
	DW	SUBB
	DW	PAD
	DW	SWAP
	DW	CMOVE
	DW	PAD
	DW	COUNT
	DW	LIT
	DW	1FH
	DW	ANDD
	DW	TYPE
	DW	SPACE
	DW	SEMIS
;
	DB	86H	; CREATE
	DB	'CREAT'
	DB	'E'+80H
	DW	IDDOT-6
CREAT	DW	DOCOL
	DW	DFIND
	DW	ZBRAN	; IF
	DW	CREA1-$
	DW	DROP
	DW	NFA
	DW	IDDOT
	DW	LIT
	DW	4
	DW	MESS
	DW	SPACE	; ENDIF
CREA1	DW	HERE
	DW	DUP
	DW	CAT
	DW	WIDTH
	DW	AT
	DW	MIN
	DW	ONEP
	DW	ALLOT
	DW	DUP
	DW	LIT
	DW	0A0H
	DW	TOGGL
	DW	HERE
	DW	ONE
	DW	SUBB
	DW	LIT
	DW	80H
	DW	TOGGL
	DW	LATES
	DW	COMMA
	DW	CURR
	DW	AT
	DW	STORE
	DW	HERE
	DW	TWOP
	DW	COMMA
	DW	SEMIS
;
	DB	0C9H	; [COMPILE]
	DB	'[COMPILE'
	DB	']'+80H
	DW	CREAT-9
BCOMP	DW	DOCOL
	DW	DFIND
	DW	ZEQU
	DW	ZERO
	DW	QERR
	DW	DROP
	DW	CFA
	DW	COMMA
	DW	SEMIS
;
	DB	0C7H	; LITERAL
	DB	'LITERA'
	DB	'L'+80H
	DW	BCOMP-0CH
LITER	DW	DOCOL
	DW	STATE
	DW	AT
	DW	ZBRAN	; IF
	DW	LITE1-$
	DW	COMP
	DW	LIT
	DW	COMMA	; ENDIF
LITE1	DW	SEMIS
;
	DB	0C8H	; DLITERAL
	DB	'DLITERA'
	DB	'L'+80H
	DW	LITER-0AH
DLITE	DW	DOCOL
	DW	STATE
	DW	AT
	DW	ZBRAN	; IF
	DW	DLIT1-$
	DW	SWAP
	DW	LITER
	DW	LITER	; ENDIF
DLIT1	DW	SEMIS
;
	DB	86H	; ?STACK
	DB	'?STAC'
	DB	'K'+80H
	DW	DLITE-0BH
QSTAC	DW	DOCOL
	DW	SPAT
	DW	SZERO
	DW	AT
	DW	SWAP
	DW	ULESS
	DW	ONE
	DW	QERR
	DW	SPAT
	DW	HERE
	DW	LIT
	DW	80H
	DW	PLUS
	DW	ULESS
	DW	LIT
	DW	7
	DW	QERR
	DW	SEMIS
;
	DB	89H	; INTERPRET
	DB	'INTERPRE'
	DB	'T'+80H
	DW	QSTAC-9
INTER	DW	DOCOL
INTE1	DW	DFIND	; BEGIN
	DW	ZBRAN	; IF
	DW	INTE2-$
	DW	STATE
	DW	AT
	DW	LESS
	DW	ZBRAN	; IF
	DW	INTE3-$
	DW	CFA
	DW	COMMA
	DW	BRAN	; ELSE
	DW	INTE4-$
INTE3	DW	CFA
	DW	EXEC	; ENDIF
INTE4	DW	QSTAC
	DW	BRAN	; ELSE
	DW	INTE5-$
INTE2	DW	HERE
	DW	NUMB
	DW	DPL
	DW	AT
	DW	ONEP
	DW	ZBRAN	; IF
	DW	INTE6-$
	DW	DLITE
	DW	BRAN	; ELSE
	DW	INTE7-$
INTE6	DW	DROP
	DW	LITER	; ENDIF
INTE7	DW	QSTAC	; ENDIF
INTE5	DW	BRAN	; AGAIN
	DW	INTE1-$
;
	DB	89H	; IMMEDIATE
	DB	'IMMEDIAT'
	DB	'E'+80H
	DW	INTER-0CH
IMMED	DW	DOCOL
	DW	LATES
	DW	LIT
	DW	40H
	DW	TOGGL
	DW	SEMIS
;
	DB	8AH	; VOCABULARY
	DB	'VOCABULAR'
	DB	'Y'+80H
	DW	IMMED-0CH
VOCAB	DW	DOCOL
	DW	BUILD
	DW	LIT
	DW	0A081H
	DW	COMMA
	DW	CURR
	DW	AT
	DW	CFA
	DW	COMMA
	DW	HERE
	DW	VOCL
	DW	AT
	DW	COMMA
	DW	VOCL
	DW	STORE
	DW	DOES
DOVOC	DW	TWOP
	DW	CONT
	DW	STORE
	DW	SEMIS
;
	DB	0C5H	; FORTH
	DB	'FORT'
	DB	'H'+80H
	DW	VOCAB-0DH
FORTH	DW	DODOE
	DW	DOVOC
	DW	0A081H
	DW	TASK-7	; COLD START VALUE ONLY
;			  CHANGED EACH TIME A DEF IS APPENDED
;			  TO THE FORTH VOCABULARY
	DW	0	; END OF VOCABULARY LIST
;
	DB	8BH	; DEFINITIONS
	DB	'DEFINITION'
	DB	'S'+80H
	DW	FORTH-8
DEFIN	DW	DOCOL
	DW	CONT
	DW	AT
	DW	CURR
	DW	STORE
	DW	SEMIS
;
	DB	0C1H	; (
	DB	'('+80H
	DW	DEFIN-0EH
PAREN	DW	DOCOL
	DW	LIT
	DW	29H
	DW	WORD
	DW	SEMIS
;
	DB	84H	; QUIT
	DB	'QUI'
	DB	'T'+80H
	DW	PAREN-4
QUIT	DW	DOCOL
	DW	ZERO
	DW	BLK
	DW	STORE
	DW	LBRAC
QUIT1	DW	RPSTO	; BEGIN
	DW	CR
	DW	QUERY
	DW	INTER
	DW	STATE
	DW	AT
	DW	ZEQU
	DW	ZBRAN	; IF
	DW	QUIT2-$
	DW	PDOTQ
	DB	2
	DB	'OK'	; ENDIF
QUIT2	DW	BRAN	; AGAIN
	DW	QUIT1-$
;
	DB	85H	; ABORT
	DB	'ABOR'
	DB	'T'+80H
	DW	QUIT-7
ABORT	DW	DOCOL
	DW	SPSTO
	DW	DEC
	DW	QSTAC
	DW	CR
	DW	DOTCPU
	DW	PDOTQ
	DB	0DH
	DB	'fig-FORTH '
	DB	FIGREL+30H,ADOT,FIGREV+30H
	DW	FORTH
	DW	DEFIN
	DW	QUIT
;
WRM	LXI	B,WRM1
	JMP	NEXT
WRM1	DW	WARM
;
	DB	84H	; WARM
	DB	'WAR'
	DB	'M'+80H
	DW	ABORT-8
WARM	DW	DOCOL
	DW	MTBUF
	DW	ABORT
;
CLD	LXI	B,CLD1
	LHLD	ORIG+12H
	SPHL
	JMP	NEXT
CLD1	DW	COLD
;
	DB	84H	; COLD
	DB	'COL'
	DB	'D'+80H
	DW	WARM-7
COLD	DW	DOCOL
	DW	MTBUF
	DW	ZERO,DENSTY
	DW	STORE
	DW	LIT,BUF1
	DW	USE,STORE
	DW	LIT,BUF1
	DW	PREV,STORE
	DW	DRZER
	DW	LIT,0
	DW	LIT,EPRINT
	DW	STORE
;
	DW	LIT
	DW	ORIG+12H
	DW	LIT
	DW	UP
	DW	AT
	DW	LIT
	DW	6
	DW	PLUS
	DW	LIT
	DW	10H
	DW	CMOVE
	DW	LIT
	DW	ORIG+0CH
	DW	AT
	DW	LIT
	DW	FORTH+6
	DW	STORE
	DW	ABORT
;
	DB	84H	; S->D
	DB	'S->'
	DB	'D'+80H
	DW	COLD-7
STOD	DW	$+2
	POP	D
	LXI	H,0
	MOV	A,D
	ANI	80H
	JZ	STOD1
	DCX	H
STOD1	JMP	DPUSH
;
	DB	82H	; +-
	DB	'+'
	DB	'-'+80H
	DW	STOD-7
PM	DW	DOCOL
	DW	ZLESS
	DW	ZBRAN	; IF
	DW	PM1-$
	DW	MINUS	; ENDIF
PM1	DW	SEMIS
;
	DB	83H	; D+-
	DB	'D+'
	DB	'-'+80H
	DW	PM-5
DPM	DW	DOCOL
	DW	ZLESS
	DW	ZBRAN	; IF
	DW	DPM1-$
	DW	DMINU	; ENDIF
DPM1	DW	SEMIS
;
	DB	83H	; ABS
	DB	'AB'
	DB	'S'+80H
	DW	DPM-6
ABS	DW	DOCOL
	DW	DUP
	DW	PM
	DW	SEMIS
;
	DB	84H	; DABS
	DB	'DAB'
	DB	'S'+80H
	DW	ABS-6
DABS	DW	DOCOL
	DW	DUP
	DW	DPM
	DW	SEMIS
;
	DB	83H	; MIN
	DB	'MI'
	DB	'N'+80H
	DW	DABS-7
MIN	DW	DOCOL,TDUP
	DW	GREAT
	DW	ZBRAN	; IF
	DW	MIN1-$
	DW	SWAP	; ENDIF
MIN1	DW	DROP
	DW	SEMIS
;
	DB	83H	; MAX
	DB	'MA'
	DB	'X'+80H
	DW	MIN-6
MAX	DW	DOCOL,TDUP
	DW	LESS
	DW	ZBRAN	; IF
	DW	MAX1-$
	DW	SWAP	; ENDIF
MAX1	DW	DROP
	DW	SEMIS
;
	DB	82H	; M*
	DB	'M'
	DB	'*'+80H
	DW	MAX-6
MSTAR	DW	DOCOL,TDUP
	DW	XORR
	DW	TOR
	DW	ABS
	DW	SWAP
	DW	ABS
	DW	USTAR
	DW	FROMR
	DW	DPM
	DW	SEMIS
;
	DB	82H	; M/
	DB	'M'
	DB	'/'+80H
	DW	MSTAR-5
MSLAS	DW	DOCOL
	DW	OVER
	DW	TOR
	DW	TOR
	DW	DABS
	DW	RR
	DW	ABS
	DW	USLAS
	DW	FROMR
	DW	RR
	DW	XORR
	DW	PM
	DW	SWAP
	DW	FROMR
	DW	PM
	DW	SWAP
	DW	SEMIS
;
	DB	81H	; *
	DB	'*'+80H
	DW	MSLAS-5
STAR	DW	DOCOL
	DW	MSTAR
	DW	DROP
	DW	SEMIS
;
	DB	84H	; /MOD
	DB	'/MO'
	DB	'D'+80H
	DW	STAR-4
SLMOD	DW	DOCOL
	DW	TOR
	DW	STOD
	DW	FROMR
	DW	MSLAS
	DW	SEMIS
;
	DB	81H	; /
	DB	'/'+80H
	DW	SLMOD-7
SLASH	DW	DOCOL
	DW	SLMOD
	DW	SWAP
	DW	DROP
	DW	SEMIS
;
	DB	83H	; MOD
	DB	'MO'
	DB	'D'+80H
	DW	SLASH-4
MODD	DW	DOCOL
	DW	SLMOD
	DW	DROP
	DW	SEMIS
;
	DB	85H	; */MOD
	DB	'*/MO'
	DB	'D'+80H
	DW	MODD-6
SSMOD	DW	DOCOL
	DW	TOR
	DW	MSTAR
	DW	FROMR
	DW	MSLAS
	DW	SEMIS
;
	DB	82H	; */
	DB	'*'
	DB	'/'+80H
	DW	SSMOD-8
SSLA	DW	DOCOL
	DW	SSMOD
	DW	SWAP
	DW	DROP
	DW	SEMIS
;
	DB	85H	; M/MOD
	DB	'M/MO'
	DB	'D'+80H
	DW	SSLA-5
MSMOD	DW	DOCOL
	DW	TOR
	DW	ZERO
	DW	RR
	DW	USLAS
	DW	FROMR
	DW	SWAP
	DW	TOR
	DW	USLAS
	DW	FROMR
	DW	SEMIS
;
;	BLOCK MOVED DOWN 2 PAGES
;
;
	DB	86H	; (LINE)
	DB	'(LINE'
	DB	')'+80H
	DW	MSMOD-8
PLINE	DW	DOCOL
	DW	TOR
	DW	LIT
	DW	40H
	DW	BBUF
	DW	SSMOD
	DW	FROMR
	DW	BSCR
	DW	STAR
	DW	PLUS
	DW	BLOCK
	DW	PLUS
	DW	LIT
	DW	40H
	DW	SEMIS
;
	DB	85H	; .LINE
	DB	'.LIN'
	DB	'E'+80H
	DW	PLINE-9
DLINE	DW	DOCOL
	DW	PLINE
	DW	DTRAI
	DW	TYPE
	DW	SEMIS
;
	DB	87H	; MESSAGE
	DB	'MESSAG'
	DB	'E'+80H
	DW	DLINE-8
MESS	DW	DOCOL
	DW	WARN
	DW	AT
	DW	ZBRAN	; IF
	DW	MESS1-$
	DW	DDUP
	DW	ZBRAN	; IF
	DW	MESS2-$
	DW	LIT
	DW	4
	DW	OFSET
	DW	AT
	DW	BSCR
	DW	SLASH
	DW	SUBB
	DW	DLINE
	DW	SPACE	; ENDIF
MESS2	DW	BRAN	; ELSE
	DW	MESS3-$
MESS1	DW	PDOTQ
	DB	6
	DB	'MSG # '
	DW	DOT	; ENDIF
MESS3	DW	SEMIS
	PAGE
;------------------------------------------
;
;	8080 PORT FETCH AND STORE
;	( SELF MODIFYING CODE, NOT REENTRANT )
;
	DB	82H	; P@ "PORT @"
	DB	'P'
	DB	'@'+80H
	DW	MESS-0AH
PTAT:	DW	$+2
	POP	D	;E <- PORT#
	LXI	H,$+5
	MOV	M,E
	IN	0	;( PORT# MODIFIED )
	MOV	L,A	;L <- (PORT#)
	MVI	H,0
	JMP	HPUSH
;
	DB	82H	; "PORT STORE"
	DB	'P'
	DB	'!'+80H
	DW	PTAT-5
PTSTO:	DW	$+2
	POP	D	;E <- PORT#
	LXI	H,$+7
	MOV	M,E
	POP	H	;H <- CDATA
	MOV	A,L
	OUT	0	;( PORT# MODIFIED )
	JMP	NEXT
	PAGE
;--------------------------------------------------
;	CP/M DISK INTERFACE
;
;	CP/M BIOS CALLS USED
;	( NOTE EQU'S ARE 3 LOWER THAN DOCUMENTED OFFSETS
;	  BECAUSE BASE ADDR IS BIOS+3 )
;
RITSEC	EQU	39
RDSEC	EQU	36
SETDMA	EQU	33
SETSEC	EQU	30
SETTRK	EQU	27
SETDSK	EQU	24
;
;	DOUBLE DENSITY 8" FLOPPY CAPACITIES
SPT2	EQU	52	; SECTORS PER TRACK
TRKS2	EQU	77	; NUMBER OF TRACKS
SPDRV2	EQU	SPT2*TRKS2	; SECTORS/DRIVE
;	SINGLE DENSITY 8" FLOPPY CAPACITIES
SPT1	EQU	26	; SECTORS/TRACK
TRKS1	EQU	77	; # TRACKS
SPDRV1	EQU	SPT1*TRKS1	; SECTORS/DRIVE
;
BPS	EQU	128	; BYTES PER SECTOR
MXDRV	EQU	2	; MAX # DRIVES
;
;	FORTH VARIABLES AND CONSTANTS USED IN DISK INTERFACE
;
	DB	85H	; DRIVE ( CURRENT DRIVE # )
	DB	'DRIV'
	DB	'E'+80H
	DW	PTSTO-5
DRIVE	DW	DOVAR,0
;
	DB	83H	; SEC	( SECTOR # )
	DB	'SE'
	DB	'C'+80H
	DW	DRIVE-8
SEC:	DW	DOVAR
	DW	0
;
	DB	85H	; TRACK	( TRACK # )
	DB	'TRAC'
	DB	'K'+80H
	DW	SEC-6
TRACK:	DW	DOVAR,0
;
	DB	83H	; USE	( ADDR OF NEXT BUFFER TO USE )
	DB	'US'
	DB	'E'+80H
	DW	TRACK-8
USE:	DW	DOVAR
	DW	BUF1
;
	DB	84H	; PREV
;			( ADDR OF PREVIOUSLY USED BUFFER )
	DB	'PRE'
	DB	'V'+80H
	DW	USE-6
PREV	DW	DOVAR
	DW	BUF1
;
	DB	87H	; SEC/BLK ( # SECTORS/BLOCK )
	DB	'SEC/BL'
	DB	'K'+80H
	DW	PREV-7
SPBLK	DW	DOCON
	DW	KBBUF/BPS
;
	DB	85H	; #BUFF  ( NUMBER OF BUFFERS )
	DB	'#BUF'
	DB	'F'+80H
	DW	SPBLK-10
NOBUF	DW	DOCON,NBUF
;
	DB	87H	; DENSITY ( 0 = SINGLE , 1 = DOUBLE )
	DB	'DENSIT'
	DB	'Y'+80H
	DW	NOBUF-8
DENSTY	DW	DOVAR
	DW	0
;
	DB	8AH	; DISK-ERROR  ( DISK ERROR STATUS )
	DB	'DISK-ERRO'
	DB	'R'+80H
	DW	DENSTY-10
DSKERR	DW	DOVAR,0
;
;	DISK INTERFACE HIGH-LEVEL ROUTINES
;
	DB	84H	; +BUF	( ADVANCE BUFFER )
	DB	'+BU'
	DB	'F'+80H
	DW	DSKERR-13
PBUF	DW	DOCOL
	DW	LIT,CO
	DW	PLUS,DUP
	DW	LIMIT,EQUAL
	DW	ZBRAN,PBUF1-$
	DW	DROP,FIRST
PBUF1:	DW	DUP,PREV
	DW	AT,SUBB
	DW	SEMIS
;
	DB	86H	; UPDATE
	DB	'UPDAT'
	DB	'E'+80H
	DW	PBUF-7
UPDAT	DW	DOCOL,PREV
	DW	AT,AT
	DW	LIT,8000H
	DW	ORR
	DW	PREV,AT
	DW	STORE,SEMIS
;
	DB	8DH	; EMPTY-BUFFERS
	DB	'EMPTY-BUFFER'
	DB	'S'+80H
	DW	UPDAT-9
MTBUF	DW	DOCOL,FIRST
	DW	LIMIT,OVER
	DW	SUBB,ERASEE
	DW	SEMIS
;
	DB	83H	; DR0
	DB	'DR'
	DB	'0'+80H
	DW	MTBUF-16
DRZER	DW	DOCOL,ZERO
	DW	OFSET,STORE
	DW	SEMIS
;
	DB	83H	; DR1
	DB	'DR'
	DB	'1'+80H
	DW	ERZER-6
DRONE	DW	DOCOL
	DW	DENSTY,AT
	DW	ZBRAN,DRON1-$
	DW	LIT,SPDRV2
	DW	BRAN,DRON2-$
DRON1	DW	LIT,SPDRV1
DRON2	DW	OFSET,STORE
	DW	SEMIS
;
	DB	86H	; BUFFER
	DB	'BUFFE'
	DB	'R'+80H
	DW	DRONE-6
BUFFE:	DW	DOCOL,USE
	DW	AT,DUP
	DW	TOR
BUFF1	DW	PBUF		; WON'T WORK IF SINGLE BUFFER
	DW	ZBRAN,BUFF1-$
	DW	USE,STORE
	DW	RR,AT
	DW	ZLESS
	DW	ZBRAN,BUFF2-$
	DW	RR,TWOP
	DW	RR,AT
	DW	LIT,7FFFH
	DW	ANDD,ZERO
	DW	RSLW
BUFF2	DW	RR,STORE
	DW	RR,PREV
	DW	STORE,FROMR
	DW	TWOP,SEMIS
;
	DB	85H	; BLOCK
	DB	'BLOC'
	DB	'K'+80H
	DW	BUFFE-9
BLOCK	DW	DOCOL,OFSET
	DW	AT,PLUS
	DW	TOR,PREV
	DW	AT,DUP
	DW	AT,RR
	DW	SUBB
	DW	DUP,PLUS
	DW	ZBRAN,BLOC1-$
BLOC2	DW	PBUF,ZEQU
	DW	ZBRAN,BLOC3-$
	DW	DROP,RR
	DW	BUFFE,DUP
	DW	RR,ONE
	DW	RSLW
	DW	TWO,SUBB
BLOC3	DW	DUP,AT
	DW	RR,SUBB
	DW	DUP,PLUS
	DW	ZEQU
	DW	ZBRAN,BLOC2-$
	DW	DUP,PREV
	DW	STORE
BLOC1	DW	FROMR,DROP
	DW	TWOP,SEMIS
;
;
;	CP/M INTERFACE ROUTINES
;
;		SERVICE REQUEST
;
IOS	LHLD	1	; (HL) <- BIOS TABLE ADDR+3
	DAD	D	; + SERVICE REQUEST OFFSET
	PCHL		; EXECUTE REQUEST
;	RET FUNCTION PROVIDED BY CP/M
;
	DB	86H	; SET-IO
;			( ASSIGN SECTOR, TRACK FOR BDOS )
	DB	'SET-I'
	DB	'O'+80H
	DW	BLOCK-8
SETIO:	DW	$+2
	PUSH	B	; SAVE (IP)
	LHLD	USE+2	; (BC) <- ADDR BUFFER
	MOV	B,H
	MOV	C,L
	LXI	D,SETDMA ; SEND BUFFER ADDR TO CP/M
	CALL	IOS
;
	LHLD	SEC+2	; (BC) <- (SEC) = SECTOR #
	MOV	C,L
	LXI	D,SETSEC	; SEND SECTOR # TO CP/M
	CALL	IOS
;
	LHLD	TRACK+2	; (BC) <- (TRACK) = TRACK #
	MOV	B,H
	MOV	C,L
	LXI	D,SETTRK
	CALL	IOS
;
	POP	B	; RESTORE (IP)
	JMP	NEXT
;
	DB	89H	; SET-DRIVE
	DB	'SET-DRIV'
	DB	'E'+80H
	DW	SETIO-9
SETDRV:	DW	$+2
	PUSH	B	; SAVE (IP)
	LDA	DRIVE+2	; (C) <- (DRIVE) = DRIVE #
	MOV	C,A
	LXI	D,SETDSK	; SEND DRIVE # TO CP/M
	CALL	IOS
	POP	B	; RESTORE (IP)
	JMP	NEXT
;
;	T&SCALC		( CALCULATES DRIVE#, TRACK#, & SECTOR# )
;	STACK INPUT: SECTOR-DISPLACEMENT = BLK# * SEC/BLK
;	OUTPUT: VARIABLES DRIVE, TRACK, & SEC
;
	DB	87H	; T&SCALC
	DB	'T&SCAL'
	DB	'C'+80H
	DW	SETDRV-12
TSCALC:	DW	DOCOL,DENSTY
	DW	AT
	DW	ZBRAN,TSCALS-$
	DW	LIT,SPDRV2
	DW	SLMOD
	DW	LIT,MXDRV
	DW	MIN
	DW	DUP,DRIVE
	DW	AT,EQUAL
	DW	ZBRAN,TSCAL1-$
	DW	DROP
	DW	BRAN,TSCAL2-$
TSCAL1	DW	DRIVE,STORE
	DW	SETDRV
TSCAL2	DW	LIT,SPT2
	DW	SLMOD,TRACK
	DW	STORE,ONEP
	DW	SEC,STORE
	DW	SEMIS
;	SINGLE DENSITY
TSCALS	DW	LIT,SPDRV1
	DW	SLMOD
	DW	LIT,MXDRV

DW	MIN
	DW	DUP,DRIVE
	DW	AT,EQUAL
	DW	ZBRAN,TSCAL3-$
	DW	DROP
	DW	BRAN,TSCAL4-$
TSCAL3	DW	DRIVE,STORE
	DW	SETDRV
TSCAL4	DW	LIT,SPT1
	DW	SLMOD,TRACK
	DW	STORE,ONEP
	DW	SEC,STORE
	DW	SEMIS
;
;	SEC-READ
;	( READ A SECTOR SETUP BY 'SET-DRIVE' & 'SETIO' )
;
	DB	88H	; SEC-READ
	DB	'SEC-REA'
	DB	'D'+80H
	DW	TSCALC-10
SECRD	DW	$+2
	PUSH	B	; SAVE (IP)
	LXI	D,RDSEC	; ASK CP/M TO READ SECTOR
	CALL	IOS
	STA	DSKERR+2	; (DSKERR) <- ERROR STATUS
	POP	B	; RESTORE (IP)
	JMP	NEXT
;
;	SEC-WRITE
;	( WRITE A SECTOR SETUP BY 'SET-DRIVE' & 'SETIO' )
;
	DB	89H	; SEC-WRITE
	DB	'SEC-WRIT'
	DB	'E'+80H
	DW	SECRD-11
SECWT	DW	$+2
	PUSH	B	; SAVE (IP)
	LXI	D,RITSEC	; ASK CP/M TO WRITE SECTOR
	CALL	IOS
	STA	DSKERR+2	; (DSKERR) <- ERROR STATUS
	POP	B	; RESTORE (IP)
	JMP	NEXT
;
	DB	83H	; R/W	( FORTH DISK PRIMATIVE )
	DB	'R/'
	DB	'W'+80H
	DW	SECWT-12
RSLW	DW	DOCOL
	DW	USE,AT
	DW	TOR
	DW	SWAP,SPBLK
	DW	STAR,ROT
	DW	USE,STORE
	DW	SPBLK,ZERO
	DW	XDO
RSLW1	DW	OVER,OVER
	DW	TSCALC,SETIO
	DW	ZBRAN,RSLW2-$
	DW	SECRD
	DW	BRAN,RSLW3-$
RSLW2	DW	SECWT
RSLW3	DW	ONEP
	DW	LIT,80H
	DW	USE,PSTOR
	DW	XLOOP,RSLW1-$
	DW	DROP,DROP
	DW	FROMR,USE
	DW	STORE,SEMIS
;
;--------------------------------------------------------
;
;	ALTERNATIVE R/W FOR NO DISK INTERFACE
;
;RSLW	DW	DOCOL,DROP,DROP,DROP,SEMIS
;
;--------------------------------------------------------
;
	DB	85H	; FLUSH
	DB	'FLUS'
	DB	'H'+80H
	DW	RSLW-6
FLUSH	DW	DOCOL
	DW	NOBUF,ONEP
	DW	ZERO,XDO
FLUS1	DW	ZERO,BUFFE
	DW	DROP
	DW	XLOOP,FLUS1-$
	DW	SEMIS
;
	DB	84H	; LOAD
	DB	'LOA'
	DB	'D'+80H
	DW	FLUSH-8
LOAD	DW	DOCOL,BLK
	DW	AT,TOR
	DW	INN,AT
	DW	TOR,ZERO
	DW	INN,STORE
	DW	BSCR,STAR
	DW	BLK,STORE	; BLK <- SCR * B/SCR
	DW	INTER		; INTERPRET FROM OTHER SCREEN
	DW	FROMR,INN
	DW	STORE
	DW	FROMR,BLK
	DW	STORE
	DW	SEMIS
;
	DB	0C3H	; -->
	DB	'--'
	DB	'>'+80H
	DW	LOAD-7
ARROW	DW	DOCOL
	DW	QLOAD
	DW	ZERO
	DW	INN
	DW	STORE
	DW	BSCR
	DW	BLK
	DW	AT
	DW	OVER
	DW	MODD
	DW	SUBB
	DW	BLK
	DW	PSTOR
	DW	SEMIS
;
	PAGE
;-------------------------------------------------
;
;	CP/M CONSOLE & PRINTER INTERFACE
;
;	CP/M BIOS CALLS USED
;	( NOTE: BELOW OFFSETS ARE 3 LOWER THAN CP/M
;	  DOCUMENTATION SINCE BASE ADDR = BIOS+3 )
;
KCSTAT	EQU	3	; CONSOLE STATUS
KCIN	EQU	6	; CONSOLE INPUT
KCOUT	EQU	9	; CONSOLE OUTPUT
KPOUT	EQU	0CH	; PRINTER OUTPUT
;
EPRINT	DW	0	; ENABLE PRINTER VARIABLE
;			; 0 = DISABLED, 1 = ENABLED
;
;	BELOW BIOS CALLS USE 'IOS' IN DISK INTERFACE
;
CSTAT	PUSH	B	; CONSOLE STATUS
	LXI	D,KCSTAT  ; CHECK IF ANY CHR HAS BEEN TYPED
	CALL	IOS
	POP	B	; IF CHR TYPED THEN (A) <- 0FFH
	RET		; ELSE (A) <- 0
;			; CHR IGNORED
;
CIN	PUSH	B	; CONSOLE INPUT
	LXI	D,KCIN	; WAIT FOR CHR TO BE TYPED
	CALL	IOS	; (A) <- CHR, (MSB) <- 0
	POP	B
	RET
;
COUT	PUSH	H	; CONSOLE OUTPUT
	LXI	D,KCOUT	; WAIT UNTIL READY
	CALL	IOS	; THEN OUTPUT (C)
	POP	H
	RET
;
POUT	LXI	D,KPOUT	; PRINTER OUTPUT
	CALL	IOS	; WAIT UNTIL READY
	RET		; THEN OUTPUT (C)
;
CPOUT	CALL	COUT	; OUTPUT (C) TO CONSOLE
	XCHG
	LXI	H,EPRINT
	MOV	A,M	; IF (EPRINT) <> 0
	ORA	A
	JZ	CPOU1
	MOV	C,E	; THEN OUTPUT (C) TO PRINTER
	CALL	POUT
CPOU1	RET
;
;	FORTH TO CP/M SERIAL IO INTERFACE
;
PQTER	CALL	CSTAT	; IF CHR TYPED
	LXI	H,0
	ORA	A
	JZ	PQTE1
	INR	L	; THEN (S1) <- TRUE
PQTE1	JMP	HPUSH	; ELSE (S1) <- FALSE
;
PKEY	CALL	CIN	; READ CHR FROM CONSOLE
	CPI	DLE	; IF CHR = (^P)
	MOV	E,A
	JNZ	PKEY1
	LXI	H,EPRINT  ; THEN TOGGLE (EPRINT)LSB
	MVI	E,ABL	; CHR <- BLANK
	MOV	A,M
	XRI	1
	MOV	M,A
PKEY1	MOV	L,E
	MVI	H,0
	JMP	HPUSH	; (S1)LB <- CHR
;
PEMIT	DW	$+2	; (EMIT)	ORPHAN
	POP	H	; (L) <- (S1)LB = CHR
	PUSH	B	; SAVE (IP)
	MOV	C,L
	CALL	CPOUT	; OUTPUT CHR TO CONSOLE
;			; & MAYBE PRINTER
	POP	B	; RESTORE (IP)
	JMP	NEXT
;
PCR	PUSH	B	; SAVE (IP)
	MVI	C,ACR	; OUTPUT (CR) TO CONSOLE
	MOV	L,C
	CALL	CPOUT	; & MAYBE TO PRINTER
	MVI	C,LF	; OUTPUT (LF) TO CONSOLE
	MOV	L,C
	CALL	CPOUT	; & MAYBE TO PRINTER
	POP	B	; RESTORE (IP)
	JMP	NEXT
;
;----------------------------------------------------
	PAGE
;
	DB	0C1H	; '	( TICK )
	DB	0A7H
	DW	ARROW-6
TICK	DW	DOCOL
	DW	DFIND
	DW	ZEQU
	DW	ZERO
	DW	QERR
	DW	DROP
	DW	LITER
	DW	SEMIS
;
	DB	86H	; FORGET
	DB	'FORGE'
	DB	'T'+80H
	DW	TICK-4
FORG	DW	DOCOL
	DW	CURR
	DW	AT
	DW	CONT
	DW	AT
	DW	SUBB
	DW	LIT
	DW	18H
	DW	QERR
	DW	TICK
	DW	DUP
	DW	FENCE
	DW	AT
	DW	LESS
	DW	LIT
	DW	15H
	DW	QERR
	DW	DUP
	DW	NFA
	DW	DP
	DW	STORE
	DW	LFA
	DW	AT
	DW	CONT
	DW	AT
	DW	STORE
	DW	SEMIS
;
	DB	84H	; BACK
	DB	'BAC'
	DB	'K'+80H
	DW	FORG-9
BACK	DW	DOCOL
	DW	HERE
	DW	SUBB
	DW	COMMA
	DW	SEMIS
;
	DB	0C5H	; BEGIN
	DB	'BEGI'
	DB	'N'+80H
	DW	BACK-7
BEGIN	DW	DOCOL
	DW	QCOMP
	DW	HERE
	DW	ONE
	DW	SEMIS
;
	DB	0C5H	; ENDIF
	DB	'ENDI'
	DB	'F'+80H
	DW	BEGIN-8
ENDIFF	DW	DOCOL
	DW	QCOMP
	DW	TWO
	DW	QPAIR
	DW	HERE
	DW	OVER
	DW	SUBB
	DW	SWAP
	DW	STORE
	DW	SEMIS
;
	DB	0C4H	; THEN
	DB	'THE'
	DB	'N'+80H
	DW	ENDIFF-8
THEN	DW	DOCOL
	DW	ENDIFF
	DW	SEMIS
;
	DB	0C2H	; DO
	DB	'D'
	DB	'O'+80H
	DW	THEN-7
DO	DW	DOCOL
	DW	COMP
	DW	XDO
	DW	HERE
	DW	THREE
	DW	SEMIS
;
	DB	0C4H	; LOOP
	DB	'LOO'
	DB	'P'+80H
	DW	DO-5
LOOP	DW	DOCOL
	DW	THREE
	DW	QPAIR
	DW	COMP
	DW	XLOOP
	DW	BACK
	DW	SEMIS
;
	DB	0C5H	; +LOOP
	DB	'+LOO'
	DB	'P'+80H
	DW	LOOP-7
PLOOP	DW	DOCOL
	DW	THREE
	DW	QPAIR
	DW	COMP
	DW	XPLOO
	DW	BACK
	DW	SEMIS
;
	DB	0C5H	; UNTIL
	DB	'UNTI'
	DB	'L'+80H
	DW	PLOOP-8
UNTIL	DW	DOCOL
	DW	ONE
	DW	QPAIR
	DW	COMP
	DW	ZBRAN
	DW	BACK
	DW	SEMIS
;
	DB	0C3H	; END
	DB	'EN'
	DB	'D'+80H
	DW	UNTIL-8
ENDD	DW	DOCOL
	DW	UNTIL
	DW	SEMIS
;
	DB	0C5H	; AGAIN
	DB	'AGAI'
	DB	'N'+80H
	DW	ENDD-6
AGAIN	DW	DOCOL
	DW	ONE
	DW	QPAIR
	DW	COMP
	DW	BRAN
	DW	BACK
	DW	SEMIS
;
	DB	0C6H	; REPEAT
	DB	'REPEA'
	DB	'T'+80H
	DW	AGAIN-8
REPEA	DW	DOCOL
	DW	TOR
	DW	TOR
	DW	AGAIN
	DW	FROMR
	DW	FROMR
	DW	TWO
	DW	SUBB
	DW	ENDIFF
	DW	SEMIS
;
	DB	0C2H	; IF
	DB	'I'
	DB	'F'+80H
	DW	REPEA-9
IFF	DW	DOCOL
	DW	COMP
	DW	ZBRAN
	DW	HERE
	DW	ZERO
	DW	COMMA
	DW	TWO
	DW	SEMIS
;
	DB	0C4H	; ELSE
	DB	'ELS'
	DB	'E'+80H
	DW	IFF-5
ELSEE	DW	DOCOL
	DW	TWO
	DW	QPAIR
	DW	COMP
	DW	BRAN
	DW	HERE
	DW	ZERO
	DW	COMMA
	DW	SWAP
	DW	TWO
	DW	ENDIFF
	DW	TWO
	DW	SEMIS
;
	DB	0C5H	; WHILE
	DB	'WHIL'
	DB	'E'+80H
	DW	ELSEE-7
WHILE	DW	DOCOL
	DW	IFF
	DW	TWOP
	DW	SEMIS
;
	DB	86H	; SPACES
	DB	'SPACE'
	DB	'S'+80H
	DW	WHILE-8
SPACS	DW	DOCOL
	DW	ZERO
	DW	MAX
	DW	DDUP
	DW	ZBRAN	; IF
	DW	SPAX1-$
	DW	ZERO
	DW	XDO	; DO
SPAX2	DW	SPACE
	DW	XLOOP	; LOOP	ENDIF
	DW	SPAX2-$
SPAX1	DW	SEMIS
;
	DB	82H	; <#
	DB	'<'
	DB	'#'+80H
	DW	SPACS-9
BDIGS	DW	DOCOL
	DW	PAD
	DW	HLD
	DW	STORE
	DW	SEMIS
;
	DB	82H	; #>
	DB	'#'
	DB	'>'+80H
	DW	BDIGS-5
EDIGS	DW	DOCOL
	DW	DROP
	DW	DROP
	DW	HLD
	DW	AT
	DW	PAD
	DW	OVER
	DW	SUBB
	DW	SEMIS
;
	DB	84H	; SIGN
	DB	'SIG'
	DB	'N'+80H
	DW	EDIGS-5
SIGN	DW	DOCOL
	DW	ROT
	DW	ZLESS
	DW	ZBRAN	; IF
	DW	SIGN1-$
	DW	LIT
	DW	2DH
	DW	HOLD	; ENDIF
SIGN1	DW	SEMIS
;
	DB	81H	; #
	DB	'#'+80H
	DW	SIGN-7
DIG	DW	DOCOL
	DW	BASE
	DW	AT
	DW	MSMOD
	DW	ROT
	DW	LIT
	DW	9
	DW	OVER
	DW	LESS
	DW	ZBRAN	; IF
	DW	DIG1-$
	DW	LIT
	DW	7
	DW	PLUS	; ENDIF
DIG1	DW	LIT
	DW	30H
	DW	PLUS
	DW	HOLD
	DW	SEMIS
;
	DB	82H	; #S
	DB	'#'
	DB	'S'+80H
	DW	DIG-4
DIGS	DW	DOCOL
DIGS1	DW	DIG	; BEGIN
	DW	OVER
	DW	OVER
	DW	ORR
	DW	ZEQU
	DW	ZBRAN	; UNTIL
	DW	DIGS1-$
	DW	SEMIS
;
	DB	83H	; D.R
	DB	'D.'
	DB	'R'+80H
	DW	DIGS-5
DDOTR	DW	DOCOL
	DW	TOR
	DW	SWAP
	DW	OVER
	DW	DABS
	DW	BDIGS
	DW	DIGS
	DW	SIGN
	DW	EDIGS
	DW	FROMR
	DW	OVER
	DW	SUBB
	DW	SPACS
	DW	TYPE
	DW	SEMIS
;
	DB	82H	; .R
	DB	'.'
	DB	'R'+80H
	DW	DDOTR-6
DOTR	DW	DOCOL
	DW	TOR
	DW	STOD
	DW	FROMR
	DW	DDOTR
	DW	SEMIS
;
	DB	82H	; D.
	DB	'D'
	DB	'.'+80H
	DW	DOTR-5
DDOT	DW	DOCOL
	DW	ZERO
	DW	DDOTR
	DW	SPACE
	DW	SEMIS
;
	DB	81H	; .
	DB	'.'+80H
	DW	DDOT-5
DOT	DW	DOCOL
	DW	STOD
	DW	DDOT
	DW	SEMIS
;
	DB	81H	; ?
	DB	'?'+80H
	DW	DOT-4
QUES	DW	DOCOL
	DW	AT
	DW	DOT
	DW	SEMIS
;
	DB	82H	; U.
	DB	'U'
	DB	'.'+80H
	DW	QUES-4
UDOT	DW	DOCOL
	DW	ZERO
	DW	DDOT
	DW	SEMIS
;
	DB	85H	; VLIST
	DB	'VLIS'
	DB	'T'+80H
	DW	UDOT-5
VLIST	DW	DOCOL
	DW	LIT
	DW	80H
	DW	OUTT
	DW	STORE
	DW	CONT
	DW	AT
	DW	AT
VLIS1	DW	OUTT	; BEGIN
	DW	AT
	DW	CSLL
	DW	GREAT
	DW	ZBRAN	; IF
	DW	VLIS2-$
	DW	CR
	DW	ZERO
	DW	OUTT
	DW	STORE	; ENDIF
VLIS2	DW	DUP
	DW	IDDOT
	DW	SPACE
	DW	SPACE
	DW	PFA
	DW	LFA
	DW	AT
	DW	DUP
	DW	ZEQU
	DW	QTERM
	DW	ORR
	DW	ZBRAN	; UNTIL
	DW	VLIS1-$
	DW	DROP
	DW	SEMIS
;
;------ EXIT CP/M  -----------------------
;
	DB	83H	; BYE
	DB	'BY'
	DB	'E'+80H
	DW	VLIST-8
BYE	DW	$+2
	JMP	0
;-----------------------------------------------
;
	DB	84H	; LIST
	DB	'LIS'
	DB	'T'+80H
	DW	BYE-6
LIST	DW	DOCOL,DEC
	DW	CR,DUP
	DW	SCR,STORE
	DW	PDOTQ
	DB	6,'SCR # '
	DW	DOT
	DW	LIT,10H
	DW	ZERO,XDO
LIST1	DW	CR,IDO
	DW	LIT,3
	DW	DOTR,SPACE
	DW	IDO,SCR
	DW	AT,DLINE
	DW	QTERM		; ?TERMINAL
	DW	ZBRAN,LIST2-$	; IF
	DW	LEAVE		; LEAVE
LIST2	DW	XLOOP,LIST1-$	; ENDIF
	DW	CR,SEMIS
;
	DB	85H	; INDEX
	DB	'INDE'
	DB	'X'+80H
	DW	LIST-7
INDEX	DW	DOCOL
	DW	LIT,FF
	DW	EMIT,CR
	DW	ONEP,SWAP
	DW	XDO
INDE1	DW	CR,IDO
	DW	LIT,3
	DW	DOTR,SPACE
	DW	ZERO,IDO
	DW	DLINE,QTERM
	DW	ZBRAN,INDE2-$
	DW	LEAVE
INDE2	DW	XLOOP,INDE1-$
	DW	SEMIS
;
	DB	85H	; TRIAD
	DB	'TRIA'
	DB	'D'+80H
	DW	INDEX-8
TRIAD	DW	DOCOL
	DW	LIT,FF
	DW	EMIT
	DW	LIT,3
	DW	SLASH
	DW	LIT,3
	DW	STAR
	DW	LIT,3
	DW	OVER,PLUS
	DW	SWAP,XDO
TRIA1	DW	CR,IDO
	DW	LIST
	DW	QTERM		; ?TERMINAL
	DW	ZBRAN,TRIA2-$	; IF
	DW	LEAVE		; LEAVE
TRIA2	DW	XLOOP,TRIA1-$	; ENDIF
	DW	CR
	DW	LIT,15
	DW	MESS,CR
	DW	SEMIS
;
	DB	84H	; .CPU
	DB	'.CP'
	DB	'U'+80H
	DW	TRIAD-8
DOTCPU	DW	DOCOL
	DW	BASE,AT
	DW	LIT,36
	DW	BASE,STORE
	DW	LIT,22H
	DW	PORIG,TAT
	DW	DDOT
	DW	BASE,STORE
	DW	SEMIS
;
	DB	84H	; TASK
	DB	'TAS'
	DB	'K'+80H
	DW	DOTCPU-7
TASK	DW	DOCOL
	DW	SEMIS
;
INITDP:	DS	EM-$	;CONSUME MEMORY TO LIMIT
;
	PAGE
;
;		MEMORY MAP
;	( THE FOLLOWING EQUATES ARE NOT REFERENCED ELSEWHERE )
;
;		LOCATION	CONTENTS
;		--------	--------
MCOLD	EQU 	ORIG		;JMP TO COLD START
MWARM	EQU	ORIG+4		;JMP TO WARM START
MA2	EQU	ORIG+8		;COLD START PARAMETERS
MUP	EQU	UP		;USER VARIABLES' BASE 'REG'
MRP	EQU	RPP		;RETURN STACK 'REGISTER'
;
MBIP	EQU	BIP		;DEBUG SUPPORT
MDPUSH	EQU	DPUSH		;ADDRESS INTERPRETER
MHPUSH	EQU	HPUSH
MNEXT	EQU	NEXT
;
MDP0	EQU	DP0		;START FORTH DICTIONARY
MDIO	EQU	DRIVE		  ;CP/M DISK INTERFACE
MCIO	EQU	EPRINT		  ;CONSOLE & PRINTER INTERFACE
MIDP	EQU	INITDP		;END INITIAL FORTH DICTIONARY
;				  = COLD (DP) VALUE
;				  = COLD (FENCE) VALUE
;				  |  NEW
;				  |  DEFINITIONS
;				  V
;
;				  ^
;				  |  DATA
;				  |  STACK
MIS0	EQU	INITS0		;  = COLD (SP) VALUE = (S0)
;				   = (TIB)
;				  |  TERMINAL INPUT
;				  |  BUFFER
;				  V
;
;				  ^
;				  |  RETURN
;				  |  STACK
MIR0	EQU	INITR0		;START USER VARIABLES
;				  = COLD (RP) VALUE = (R0)
;				  = (UP)
;				;END USER VARIABLES
MFIRST	EQU	BUF1		;START DISK BUFFERS
;				  = FIRST
MEND	EQU	EM-1		;END DISK BUFFERS
MLIMIT	EQU	EM		;LAST MEMORY LOC USED + 1
;				  = LIMIT
;
;
	END	ORIG
HHHHDT=0		LEAVE		; LEAVE
TRIA2	DW	XLOOP,TRIA1-$	; ENDIF
	DW	CR
	DW	LIT,15
	DW	MESS,CR
	DW	SEMIS
;
	DB	84H	; .CPU
	DB	'.CP'
	DB	'U'+80H
	DW	TRIAD-8
DOTCPUPPORT
MDPUSH	EQU	DPUSH		;ADDRESS INTERPR