TITLE Forth Interest Group  8086 FORTH
NAME FORTH
PAGE 62,132
.SALL
.XCREF

COMMENT \
		Forth Interest Group  8086 FORTH 

		Version 1.0

		Original implementation by Thomas Newman
		made available by the
			FORTH INTEREST GROUP
			P.O. Box 1105
			San Carlos, CA  94070

		Modified by
			Joe Smith
			U. of Penn./Dept. of Chemistry
			34th & Spruce St.
			Philadelphia, PA  19104
			215 898-4797

		Available through
			SIG/86
			c/o Joseph Boykin
			47-4 Sheridan Drive
			Shrewsbury, MA  01545
			617 845-1074

		Latest revision: June, 1983

This is a revision of fig-FORTH which includes the following changes:

	Source compatible with Microsoft's 8086 Macro Assembler

	Macros for dictionary headers

	Complete interface to MS-DOS, including screen files

	Command line arguments are interpreted

	All i/o is redirectable through execution vectors

\
SUBTTL Assembly switches (TRUE/FALSE) and EQUATES
PAGE


INCLUDE	4TH-OPTS.H		;assembly options

; Version number:

FIGREL		EQU	1	;fig release number
FIGREV		EQU	0	;fig revision number
USRVER		EQU	0	;user version number,0-25,printed as A-Z

; Memory allocation parameters:

EM		EQU	0000		;64K top of memory + 1
NSCR		EQU	8		;No. of 1K block buffers
BUFSIZE		EQU	1024		;size of FORTH's disk buffers
US		EQU	80		;User area size ( in bytes )
RTS		EQU	160		;Return stack/TIB size

BUF1		EQU	EM-(NSCR*(BUFSIZE+4))	;first buffer addr.
INITR0		EQU	BUF1-US		;Start of return stack (R0)
INITS0		EQU	INITR0-RTS	;Start of param. stack (S0)

; ASCII characters used

ANUL		EQU	0		;ASCII NUL
BELL		EQU	7		;ASCII bell: ^G
BSOUT		EQU	8		;output backspace: ^H
LF		EQU	10		;ASCII linefeed
FF		EQU	12		;ASCII form feed
ACR		EQU	13		;ASCII carriage return
BSIN		EQU	127		;input delete char: DEL

SUBTTL Main entry points and COLD start data
PAGE +


INCLUDE	4TH-LIB.MAC		;Required support macros

; Note: FORTH only uses one segment, and runs as a .COM program

MAIN		SEGMENT
		ASSUME	CS:MAIN,DS:MAIN,SS:MAIN,ES:MAIN

		ORG	100H

ORIG: 		NOP
		JMP	CLD		;vector to COLD start
		NOP
		JMP	WRM		;vector to WARM start


		DB	FIGREL		;version # printed by COLD
		DB	FIGREV
		DB	USRVER
		DB	0EH		;version attributes
		DW	LASTNFA		;top word in FORTH vocabulary
		DW	BSIN		;backspace recognised by EXPECT
		DW	INITR0		;initial UP

; COLD start moves the following to USER var's. 3-10
; MUST BE IN SAME ORDER AS USER VARIABLES

		DW	INITS0		;  S0
		DW	INITR0		;  R0
		DW	INITS0		;  TIB
		DW	32		;  WIDTH
		DW	0		;  WARNING
		DW	INITDP		;  FENCE
		DW	INITDP		;  DP
		DW	FORTH+6		;  VOC-LINK

; CPU id printed by COLD

	IF	_ALIGN
		DD	0B3260005H	;"8086" ( in base 36 ! )
	ELSE
		DD	0B3280005H	;"8088" ( in base 36 ! )
	ENDIF

UP 		DW	INITR0		;user area pointer
RPP 		DW	INITR0		;return stack pointer

	$REPORT	<Boot parameters completed>
	$REPORT	<LIMIT	=>,%EM
	$REPORT	<FIRST	=>,%BUF1
	$REPORT	<R0	=>,%INITR0
	$REPORT	<S0	=>,%INITS0

SUBTTL FORTH register usage
PAGE +


COMMENT \

FORTH	8086	Preservation rules
------------------------------------------------------------------------
IP	SI	Interpreter pointer
		Must be preserved across words
		NOTE: Also preserve the direction flag (always UP)!

W	DX	Working register
		Jump to label DPUSH will push contents onto
		the parameter stack before falling into APUSH

SP	SP	Parameter stack pointer
		Must be preserved across words

RP	BP	Return stack pointer
		Must be preserved across words

	AX	General purpose register
		Jump to label APUSH pushes contents onto
		the parameter stack

	CS,DS,SS
		Must be preserved across words

		All other registers are available

\
SUBTTL Comment conventions
PAGE


COMMENT \

==	means	is equal to
:=	means	is assigned the value

name	==	address of name
(name)	==	contents at address name
((name))==	contents at address contained in name

NFA	==	Name Field Address
LFA	==	Link Field Address
CFA	==	Code Field Address
PFA	==	Parameter Field Address

S1,S2	==	parameter stack: top item, next item
R1,R2	==	return stack: top word, next word

LSB	==	Least Significant Bit
MSB	==	Most Significant Bit
LB,LW	==	Low Byte, Low Word
HB,HW	==	High Byte, High Word
\

	IF	_DEBUG
SUBTTL Debugging support
PAGE +

BIP 		DW	0	;breakpoint start address
BIPE 		DW	0	;breakpoint end address

COMMENT \

BIP	BIPE	effect
-----	-----	-------------------------------------------
0	?	trace off
-1	?	trace all NEXT calls
addr1	0	trace addr1 only
addr1	addr2	trace NEXT calls between addr1 and addr2

NOTE: addr1/addr2 can't be CFA's
\

; NEXT with code to trace FORTH word execution

TNEXT: 		PUSHF		;save executing word's data
		PUSH	AX
		MOV	AX,BIP	;addr1
		OR	AX,AX
		JZ	TNEXT2	;no trace if addr1==0
		CMP	AX,-1
		JZ	TNEXT1	;trace all
		CMP	AX,SI
		JZ	TNEXT1	;in range, so trace
		JA	TNEXT2	;not in range
		MOV	AX,BIPE
		OR	AX,AX
		JZ	TNEXT2	;trace addr1 only
		CMP	AX,SI
		JB	TNEXT2	;no longer in range

; Pause on address

TNEXT1: 	POP	AX	;restore executing word's reg's.
		POPF
		INT	3	;Break to DEBUG
BREAK: 		JMP	SHORT TNEXT3	;continue

; No pause, restore registers

TNEXT2: 	POP	AX
		POPF
TNEXT3: 	LODSW		;AX:=(IP)
		MOV	BX,AX
		JMP	SHORT NEXT1

	$REPORT	<Debug trace included>
	ENDIF
SUBTTL Inner interpreter, DPUSH, APUSH entry points
PAGE +


DPUSH: 		PUSH	DX	;common entry point; DX, AX to S2, S1
APUSH: 		PUSH	AX	;common entry point, AX to S1

NEXT:
	IF	_DEBUG
		JMP	TNEXT
	ELSE
		LODSW			; AX:=(IP), IP:=IP+1
		MOV	BX,AX
	ENDIF

NEXT1: 		MOV	DX,BX
		INC	DX		; W:=(IP)+1
		JMP	WORD PTR [BX]	;to CFA
SUBTTL FORTH dictionary 
PAGE +


;=C   LIT	push an inline literal			-- n

		$CODE	83H,LI,T,LIT
		LODSW
		JMP	APUSH

;=C   EXECUTE	executes the word at CFA		CFA -- ?

		$CODE	87H,EXECUT,E,EXEC
		POP	BX
		JMP	NEXT1

;=C   BRANCH	adds an inline offset to IP		--

		$CODE	86H,BRANC,H,BRAN
BRAN1:		ADD	SI,[SI]		; IP:=IP+(IP)
		JMP	NEXT

;=C   0BRANCH	branch if f is zero			f --

		$CODE	87H,0BRANC,H,ZBRAN
		POP	AX
		OR	AX,AX
		JZ	BRAN1		;f==0, so branch
		INC	SI		;point IP to next word
		INC	SI
		JMP	NEXT

;=C   (LOOP)	execution time loop code		--

		$CODE	86H,(LOOP,),XLOOP
		MOV	BX,1
XLOO1: 		ADD	[BP],BX		;R1:=R1+1
		MOV	AX,[BP]
		SUB	AX,2[BP]	;compare new index to limit
		XOR	AX,BX
		JS	BRAN1		;branch - keep looping

		ADD	BP,4		;end of loop, drop R1, R2
		INC	SI		;skip branch offset
		INC	SI
		JMP	NEXT

;=C   (+LOOP)	(LOOP) with increment on S1		n --

		$CODE	87H,(+LOOP,),XPLOO
		POP	BX
		JMP	XLOO1

;=C   (DO)	run-time loop initialization		n2 n1 --

		$CODE	84H,(DO,),XDO
		POP	DX		;index
		POP	AX		;limit
		XCHG	BP,SP		;put them on the return stack
		PUSH	AX		;R2:=S2
		PUSH	DX		;R1:=S2
		XCHG	BP,SP
		JMP	NEXT

;=C   I		leave index value			-- n

		$CODE	81H,,I,IDO
		MOV	AX,[BP]		;AX:=R1 (index)
		JMP	APUSH

;=C   DIGIT	convert c to binary using base n1	c n1 -- [n2] f

		$CODE	85H,DIGI,T,DIGIT
		POP	DX		;base
		POP	AX		;ASCII char
		SUB	AL,'0'
		JB	DIGI2		;error if c < '0'
		CMP	AL,9
		JBE	DIGI1		;number 0-9
		SUB	AL,7
		CMP	AL,10		;number A-Z?
		JB	DIGI2		;no, error
DIGI1: 		CMP	AL,DL
		JAE	DIGI2		;error if digit > base
		SUB	DX,DX
		MOV	DL,AL		;new binary number
		MOV	AL,1		;f==TRUE if OK
		JMP	DPUSH
DIGI2: 		SUB	AX,AX
		JMP	APUSH		;f==FALSE if error

PAGE


;=C*  (FIND)	dictionary search primtive		a1 NFA -- [PFA b] f

		$CODE	86H,(FIND,),PFIND
		MOV	AX,DS
		MOV	ES,AX		;DI defaults to ES
		POP	BX		;BX:=NFA
		POP	CX		;CX:=a1 ( search string )

PFIN1: 		MOV	DI,CX		;get addr
		MOV	AL,[BX]		;get word length
		MOV	DL,AL
		XOR	AL,[DI]
		AND	AL,3FH		;check lengths+smudge bit
		JNZ	PFIN5		;lengths differ

PFIN2: 		INC	BX		;length matches, check chars
		INC	DI
		MOV	AL,[BX]
		XOR	AL,[DI]
		ADD	AL,AL		;this checks bit 8
		JNZ	PFIN5		;chars differ
		JNB	PFIN2		;OK so far

	IF	_ALIGN
		ADD	BX,6		;Compute PFA ( could be 5 or 6)
		AND	BX,0FFFEH	;Clear LSB to align
	ELSE
		ADD	BX,5
	ENDIF
		;end of word (bit 8 set), a match

		PUSH	BX		;S3:=PFA
		MOV	AX,1		;f:=TRUE
		SUB	DH,DH		;DX:=length byte
		JMP	DPUSH		;S2:=f, S1:=l

		; No match, try the next dictionary entry

PFIN5: 		INC	BX		;advance BX to LFA
		JB	PFIN6		;bit 8 set - must be the end
		MOV	AL,[BX]
		ADD	AL,AL
		JMP	PFIN5
PFIN6:

	IF	_ALIGN
		INC	BX		;This could be one too many...
		AND	BX,0FFFEH	;Clear LSB to align
	ENDIF

		MOV	BX,[BX]		;BX:=(LFA)
		OR	BX,BX		;start of dictionary?
		JNZ	PFIN1		;no, keep looking
		MOV	AX,0		;no match, f:=FALSE
		JMP	APUSH		;S1:=f

PAGE


;=C   ENCLOSE	text scanning primitive			a1 c -- a1 n1 n2 n3

		$CODE	87H,ENCLOS,E,ENCL
		POP	AX		;delimiter c
		POP	BX		;text addr
		PUSH	BX		;S4:=text addr
		MOV	AH,0
		MOV	DX,-1		;DX is counter
		DEC	BX		;BX points to text

		; Scan to first non-delimiter

ENCL1: 		INC	BX		;next char
		INC	DX		;count it
		CMP	AL,[BX]		;delimiter found?
		JZ	ENCL1		;not yet, keep looking
		PUSH	DX		;yes, S3:=count
		CMP	AH,[BX]		;found NUL char?
		JNZ	ENCL2		;no...
		MOV	AX,DX		;yes, n2:=n3
		INC	DX		;n3:=n3+1
		JMP	DPUSH		;exit

		; Enclose text to first delimiter

ENCL2: 		INC	BX
		INC	DX
		CMP	AL,[BX]
		JZ	ENCL4		;found it...
		CMP	AH,[BX]		;NUL?
		JNZ	ENCL2		;no, keep looking

		; Found NUL at end of text

ENCL3: 		MOV	AX,DX
		JMP	DPUSH

		; Found delimiter

ENCL4: 		MOV	AX,DX		;count to delimiter
		INC	AX		;count to first > delimiter
		JMP	DPUSH		;S2, S1

SUBTTL Input/output primitives
PAGE


;=:*  EMIT	char output				c --

		$COLON	84H,EMI,T,EMIT
		DW	TICKEMIT,	AT,	EXEC
		DW	ONE,OUTT
		DW	PSTOR,SEMIS

;=:*  KEY	char input				-- c

		$COLON	83H,KE,Y,KEY
		DW	TICKEY,	AT,	EXEC,	SEMIS

;=C   ?TERMINAL	console status				-- f

		$CODE	89H,?TERMINA,L,QTERM
		JMP	PQTER

;=:*  CR	output carriage return/line feed	--

		$COLON 82H,C,R,CR
		DW	TICKCR,	AT,	EXEC,	SEMIS

SUBTTL
PAGE


;=C   CMOVE	byte block move				a1 a2 n --

		$CODE	85H,CMOV,E,CMOVE
		CLD			;count up
		MOV	BX,SI		;save IP
		POP	CX		;move count
		POP	DI		;a2 ( destination )
		POP	SI		;a1 ( source )
		MOV	AX,DS
		MOV	ES,AX		;intrasegment only
	REP	MOVSB			;all that for this?
		MOV	SI,BX
		JMP	NEXT

;=C   U*	unsigned mixed multiply			u1 u2 -- ud

		$CODE	82H,U,*,USTAR
		POP	AX
		POP	BX
		MUL	BX
		XCHG	AX,DX		;S1:=MSW, S2:=LSW
		JMP	DPUSH

;=C   U/	unsigned mixed divide			ud u -- urem uquot

		$CODE	82H,U,/,USLAS
		POP	BX		;BX:=divisor
		POP	DX		;DX:=MSW of dividend
		POP	AX		;AX:=LSW
		CMP	DX,BX		;0?
		JNB	DZERO
		DIV	BX
		JMP	DPUSH
DZERO: 		MOV	AX,-1		;divide by zero! leave -1
		MOV	DX,AX
		JMP	DPUSH

;=C   AND	bitwise AND				n n -- n

		$CODE	83H,AN,D,ANDD
		POP	AX
		POP	BX
		AND	AX,BX
		JMP	APUSH

;=C   OR	bitwise OR				n n -- n

		$CODE	82H,O,R,ORR
		POP	AX
		POP	BX
		OR	AX,BX
		JMP	APUSH

;=C   XOR	bitwise exclusive OR			n n -- n

		$CODE	83H,XO,R,XORR
		POP	AX
		POP	BX
		XOR	AX,BX
		JMP	APUSH

;=C   SP@	push current parameter stack pointer	-- SP

		$CODE	83H,SP,@,SPAT
		MOV	AX,SP
		JMP	APUSH

;=C   SP!	reset parameter stack			? --

		$CODE	83H,SP,!!!!,SPSTO
		MOV	BX,UP		;USER variable base addr
		MOV	SP,6[BX]	;S0 is 6 bytes above base
		JMP	NEXT

;=C   RP@	push current RP onto parameter stack	-- RP

		$CODE	83H,RP,@,RPAT
		MOV	AX,BP
		JMP	APUSH

;=C   RP!	reset return stack			? --

		$CODE	83H,RP,!!!!,RPSTO
		MOV	BX,UP		;USER variable base addr
		MOV	BP,8[BX]	;offset of R0 is 8
		JMP	NEXT

;=C   ;S	end of screen or run time colon word	--

		$CODE	82H,!!!;,S,SEMIS
		MOV	SI,[BP]		;IP:=R1 - pop return stack
		INC	BP		;adjust RP
		INC	BP
		JMP	NEXT

;=C   LEAVE	force loop exit				--

		$CODE	85H,LEAV,E,LEAVE
		MOV	AX,[BP]
		MOV	2[BP],AX	;limit:=index
		JMP	NEXT

;=C   >R	push parm. stack to return stack	n --

		_NFA	= $
		DB	82H,'>','R'+80H		;macro can't handle it!
		$LINKS	$+2,TOR

		POP	BX		;BX:=S1
		DEC	BP		;adjust RP
		DEC	BP
		MOV	[BP],BX		;push it
		JMP	NEXT

;=C   R>	pop return stack to parm. stack		-- n

		$CODE	82H,R,!!!>,FROMR
		MOV	AX,[BP]		;AX:=R1
		INC	BP		;adjust RP
		INC	BP
		JMP	APUSH

;=C   R		top of return stack to parm. stack	-- n

		$NAME	81H,,R
		$LINKS	IDO+2,RR	;synonym for I

;=C   0=	test top of stack for zero		n -- f

		$CODE	82H,0,=,ZEQU
		POP	AX
		OR	AX,AX
		MOV	AX,1
		JZ	ZEQU1
		DEC	AX
ZEQU1:		JMP	APUSH

;=C   0<	test top of stack for negative value	n -- f

		$CODE	82H,0,!!!<,ZLESS
		POP	AX
		OR	AX,AX
		MOV	AX,1
		JS	ZLESS1
		DEC	AX
ZLESS1:		JMP	APUSH

;=C   +		16-bit addition				n1 n2 -- nsum

		$CODE	81H,,+,PLUS
		POP	AX
		POP	BX
		ADD	AX,BX
		JMP	APUSH

;=C   D+	32-bit addition				d1 d2 -- dsum

		$CODE	82H,D,+,DPLUS
		POP	AX		;AX:=d2 MSW
		POP	DX		;DX:=d2 LSW
		POP	BX		;BX:=d1 MSW
		POP	CX		;CX:=d1 LSW
		ADD	DX,CX		;add low words
		ADC	AX,BX		;add high words with carry
		JMP	DPUSH

;=C   MINUS	16-bit two's complement			n -- -n

		$CODE	85H,MINU,S,MINUS
		POP	AX
		NEG	AX
		JMP	APUSH

;=C   DMINUS	32-bit two's complement			d -- -d

		$CODE	86H,DMINU,S,DMINU
		POP	BX		;MSW
		POP	CX		;LSW
		SUB	AX,AX
		MOV	DX,AX
		SUB	DX,CX		;subtract from 0
		SBB	AX,BX		;again for high word
		JMP	DPUSH

;=C   OVER	copy second stack item to top		n1 n2 -- n1 n2 n1

		$CODE	84H,OVE,R,OVER
		POP	DX
		POP	AX
		PUSH	AX
		JMP	DPUSH

;=C   DROP	throw out top stack item		n --

		$CODE	84H,DRO,P,DROP
		POP	AX
		JMP	NEXT

;=C   SWAP	exchange top two stack items		n1 n2 -- n2 n1

		$CODE	84H,SWA,P,SWAP
		POP	DX
		POP	AX
		JMP	DPUSH

;=C   DUP	duplicate the top stack item		n -- n n

		$CODE	83H,DU,P,DUPP
		POP	AX
		PUSH	AX
		JMP	APUSH

;=C   2DUP	duplicate the top two stack items	n1 n2 -- n1 n2 n1 n2

		$CODE	84H,2DU,P,TDUP
		POP	AX
		POP	DX
		PUSH	DX
		PUSH	AX
		JMP	DPUSH

;=C   +!	add to a memory location		n addr --

		$CODE	82H,+,!!!!,PSTOR
		POP	BX
		POP	AX
		ADD	[BX],AX
		JMP	NEXT

;=C   TOGGLE	toggle bits at a memory location	n addr --

		$CODE	86H,TOGGL,E,TOGGL
		POP	AX
		POP	BX
		XOR	[BX],AL
		JMP	NEXT

;=C   @		push memory location to stack		addr -- n

		$CODE	81H,,@,AT
		POP	BX
		MOV	AX,[BX]
		JMP	APUSH

;=C   C@	push byte location to stack		addr -- b

		$CODE	82H,C,@,CAT
		POP	BX
		MOV	AL,[BX]
		SUB	AH,AH
		JMP	APUSH

;=C   2@	fetch 32-bit number			addr -- d

		$CODE	82H,2,@,TAT
		POP	BX
		MOV	AX,[BX]		;LSW at addr
		MOV	DX,[BX+2]	;MSW at addr+2
		JMP	DPUSH

;=C   !		pop stack to memory - "store"		n addr --

		$CODE	81H,,!!!!,STORE
		POP	BX
		POP	AX
		MOV	[BX],AX
		JMP	NEXT

;=C   C!	byte store - "see-store"		b addr --

		$CODE	82H,C,!!!!,CSTOR
		POP	BX
		POP	AX
		MOV	[BX],AL
		JMP	NEXT

;=C   2!	32-bit store				d addr --

		$CODE	82H,2,!!!!,TSTOR
		POP	BX
		POP	AX
		MOV	[BX],AX		;move LSW to addr
		POP	AX
		MOV	2[BX],AX	;move MSW to addr+2
		JMP	NEXT
SUBTTL Defining words
PAGE


;=C   :		begin colon definition			--

		$COLON	0C1H,,:
		DW	QEXEC,	SCSP	;compile time code
		DW	CURR,	AT
		DW	CONT,	STORE
		DW	CREAT,	RBRAC
		DW	PSCOD
					;run time code
DOCOL: 		INC	DX		;W:=W+1
		DEC	BP
		DEC	BP		;RP:=RP-2
		MOV	[BP],SI		;push IP onto return stack
		MOV	SI,DX		;IP:=W
		JMP	NEXT

;=:   ;		end colon definition			--

		$COLON	0C1H,,!!!;
		DW	QCSP,	COMP
		DW	SEMIS,	SMUDG
		DW	LBRAC,	SEMIS

;=:   NOOP	do nothing - no operation		--

		$COLON	84H,NOO,P,NOOP
		DW	SEMIS

;=:   CONSTANT	define a symbolic constant		n --

		$COLON	88H,CONSTAN,T,CON
		DW	CREAT,	SMUDG	;compile time code
		DW	COMMA,	PSCOD
					;run time code
DOCON: 		INC	DX		;point W to PFA
		MOV	BX,DX
		MOV	AX,[BX]		;get data at PFA
		JMP	APUSH		;here it is!

;=:   VARIABLE	define a symbolic variable		n --

		$COLON	88H,VARIABL,E
		DW	CON,	PSCOD	;compile time code
					;run time code
DOVAR: 		INC	DX		;point W to PFA
		PUSH	DX		;return PFA
		JMP	NEXT

;=:   USER	define a user variable			n --

		$COLON	84H,USE,R
		DW	CON,	PSCOD	;compile time code
					;run time code
DOUSE: 		INC	DX		;point W to PFA
		MOV	BX,DX		;BX:=(PFA)   offset
		MOV	BL,[BX]		;BX:=(PFA)  offset<256
		SUB	BH,BH		;just to be safe...
		MOV	DI,UP		;DI:=UP  (user area base addr)
		LEA	AX,[BX+DI]	;load effective address
		JMP	APUSH		;push address to stack

	$REPORT	<Code-level kernel completed>

SUBTTL Constants and USER variables
PAGE +


;=#   0		zero					-- 0

		$CONST	81H,,0,ZERO
		DW	0

;=#   1		one					-- 1

		$CONST	81H,,1,ONE
		DW	1

;=#   2		two					-- 2

		$CONST	81H,,2,TWO
		DW	2

;=#   3		three					-- 3

		$CONST	81H,,3,THREE
		DW	3

;=#   BL	ASCII blank				-- 32

		$CONST	82H,B,L,BLS
		DW	20H

;=#   C/L	characters per line			-- 64

		$CONST	83H,C/,L,CSLL
		DW	64

;=#   FIRST	address of lowest disk buffer		-- addr

		$CONST	85H,FIRS,T,FIRST
		DW	BUF1

;=#   LIMIT	last available memory address + 1	-- addr

		$CONST	85H,LIMI,T,LIMIT
		DW	EM

;=#   B/BUF	size of disk buffers in bytes		-- 1024

		$CONST	85H,B/BU,F,BBUF
		DW	BUFSIZE

;=#   B/SCR	number of disk buffers per screen	-- 1

		$CONST	85H,B/SC,R,BSCR
		DW	1
SUBTTL
PAGE +


;=:   +ORIGIN	word for accessing data in low memory	n -- addr

		$COLON	87H,+ORIGI,N,PORIG
		DW	LIT,	ORIG
		DW	PLUS,	SEMIS

SUBTTL USER variables
PAGE +


;=U   S0	parameter stack base			-- addr

		$USER	82H,S,0,SZERO
		DW	6		;offset in user area

;=U   R0	return stack base			-- addr

		$USER	82H,R,0,RZERO
		DW	8

;=U   TIB	Terminal Input Buffer address		-- addr

		$USER	83H,TI,B,TIB
		DW	10

;=U   WIDTH	maximum length of word names		-- addr

		$USER	85H,WIDT,H,NWIDTH
		DW	12

;=U   WARNING	switch for error processing: 0, 1, -1	-- addr

		$USER	87H,WARNIN,G,WARN
		DW	14

;=U   FENCE	pointer to protected dictionary		-- addr

		$USER	85H,FENC,E,FENCE
		DW	16

;=U   DP	top address used in dictionary		-- addr

		$USER	82H,D,P,DP
		DW	18

;=U   VOC-LINK	pointer to top vocabulary		-- addr

		$USER	88H,VOC-LIN,K,VOCL
		DW	20

;The following user variables hold CFA's for their
;respective logical functions


;=U+  @KEY	CFA of function to do character input	-- addr

		$USER	84H,@KE,Y,TICKEY
		DW	22

;=U+  @EMIT	CFA of function to do character output	-- addr

		$USER	85H,@EMI,T,TICKEMIT
		DW	24

;=U+  @CR	CFA of function to output newline	-- addr

		$USER	83H,@C,R,TICKCR
		DW	58

;=U+  @BLKRD	CFA of function to read one block	-- addr

		$USER	86H,@BLKR,D,TICKBRD
		DW	26

;=U+  @BLKWRT	CFA of function to write one block	-- addr

		$USER	87H,@BLKWR,T,TICKBWRT
		DW	28

;=U   BLK	current block, 0 if terminal		-- addr

		$USER	83H,BL,K,BLK
		DW	30

;=U   IN	current character in input stream	-- addr

		$USER	82H,I,N,INN
		DW	32

;=U   OUT	count of characters output		-- addr

		$USER	83H,OU,T,OUTT
		DW	34

;=U   SCR	current screen				-- addr

		$USER	83H,SC,R,SCR
		DW	36

;=U   OFFSET	number of lowest block to be used	-- addr

		$USER	86H,OFFSE,T,OFSET
		DW	38

;=U   CONTEXT	current vocabulary for execution	-- addr

		$USER	87H,CONTEX,T,CONT
		DW	40

;=U   CURRENT	current vocabulary for definitions	-- addr

		$USER	87H,CURREN,T,CURR
		DW	42

;=U   STATE	current interpreter state		-- addr

		$USER	85H,STAT,E,STATE
		DW	44

;=U   BASE	current number base for i/o		-- addr

		$USER	84H,BAS,E,BASE
		DW	46

;=U   DPL	Decimal Point Locator 			-- addr

		$USER	83H,DP,L,DPL
		DW	48

;=U   CSP	temporary storage for Current SP	-- addr

		$USER	83H,CS,P,CSPP
		DW	52

;=U   R#	current editing cursor location		-- addr

		$USER	82H,R,#,RNUM
		DW	54

;=U   HLD	text pointer used in number formatting	-- addr

		$USER	83H,HL,D,HLD
		DW	56

	$REPORT	<Constants and user variables completed>

SUBTTL FORTH definitions
PAGE +


;=C   1+	increment the top stack item		n -- n+1

		$CODE	82H,1,+,ONEP
		POP	AX
		INC	AX
		JMP	APUSH

;=C   2+	add 2 to the top stack item		n -- n+2

		$CODE	82H,2,+,TWOP
		POP	AX
		INC	AX
		INC	AX
		JMP	APUSH

;=C+  1-	decrement the top stack item		n -- n-1

		$CODE	82H,1,-,ONEM
		POP	AX
		DEC	AX
		JMP	APUSH

;=C+  2-	subtract 2 from the top stack item	n -- n-2

		$CODE	82H,2,-,TWOM
		POP	AX
		DEC	AX
		DEC	AX
		JMP	APUSH

;=:   HERE	next available dictionary location	-- addr

		$COLON	84H,HER,E,HERE
		DW	DP,	AT,	SEMIS

;=:   ALLOT	reserve n bytes in the dictionary	n --

		$COLON	85H,ALLO,T,ALLOT
		DW	DP,	PSTOR,	SEMIS

;=:   ,		compile n into the dictionary		n --

		$COLON	81H,,!!!,,COMMA
		DW	HERE,	STORE
		DW	TWO,	ALLOT,	SEMIS

;=:   C,	compile a byte into the dictionary	b --

		$COLON	82H,C,!!!,,CCOMM
		DW	HERE,	CSTOR
		DW	ONE,	ALLOT,	SEMIS

;=C   -		16-bit subtraction			n1 n2 -- n1-n2

		$CODE	81H,,-,SUBB
		POP	DX
		POP	AX
		SUB	AX,DX
		JMP	APUSH

;=:   =		test top two items for equality		n1 n2 -- f

		$COLON	81H,,=,EQUAL
		DW	SUBB,	ZEQU,	SEMIS

;=C   <		test for top number > second number	n1 n2 -- f

		$CODE	81H,,!!!<,LESS
		POP	DX
		POP	AX
		MOV	BX,DX
		XOR	BX,AX
		JS	LES1		;signs different
		SUB	AX,DX
LES1: 		OR	AX,AX		;test sign bit
		MOV	AX,0		;assume false
		JNS	LES2		;not less than
		INC	AX		;return true (1)
LES2: 		JMP	APUSH

;=:   U<	unsigned test for top > next item	u1 u2 -- f

		$COLON	82H,U,!!!<,ULESS
		DW	TDUP,	XORR,	ZLESS
			$GO?0	ULES1
		DW	DROP,	ZLESS,	ZEQU
			$GOTO	ULES2
ULES1: 		DW	SUBB,	ZLESS
ULES2: 		DW	SEMIS

;=:   >		test for second item > top of stack	n1 n2 -- f

		$COLON	81H,,!!!>,GREAT
		DW	SWAP,	LESS,	SEMIS

;=C   ROT	bring the third stack item to top	n1 n2 n3 -- n2 n3 n1

		$CODE	83H,RO,T,ROT
		POP	DX
		POP	BX
		POP	AX
		PUSH	BX
		JMP	DPUSH

;=:   SPACE	output a blank				--

		$COLON	85H,SPAC,E,SPACE
		DW	BLS,	EMIT,	SEMIS

;=:   -DUP	duplicate the top number if it isn't 0	n -- n [n]

		$COLON	84H,-DU,P,DDUP
		DW	DUPP
			$GO?0	DDUP1
		DW	DUPP
DDUP1: 		DW	SEMIS

;=:   TRAVERSE	move across a fig-FORTH name field	addr1 n -- addr2

		$COLON	88H,TRAVERS,E,TRAV
		DW	SWAP
TRAV1: 		DW	OVER,	PLUS
		DW	LIT,	7FH
		DW	OVER,	CAT,	LESS
			$GO?0	TRAV1
		DW	SWAP,	DROP,	SEMIS

;=:   LATEST	return the top NFA in CURRENT		-- NFA

		$COLON	86H,LATES,T,LATES
		DW	CURR,	AT,	AT,	SEMIS

;=:   LFA	convert a PFA to LFA			PFA -- LFA

		$COLON	83H,LF,A,LFA
		DW	LIT,	4
		DW	SUBB,	SEMIS

;=:   CFA	convert a PFA to CFA			PFA -- CFA

		$COLON	83H,CF,A,CFA
		DW	TWO,	SUBB,	SEMIS

;=:*  NFA	convert a PFA to NFA			PFA -- NFA

		$COLON	83H,NF,A,NFA
		DW	LIT,	5
		DW	SUBB

	IF	_ALIGN
		DW	DUPP,	CAT
		DW	LIT,	90H,	EQUAL	;90H==NOP!
			$GO?0	NFA1
		DW	ONEM
NFA1:
	ENDIF

		DW	LIT,	-1
		DW	TRAV,	SEMIS

;=:*  PFA	convert a NFA to PFA			NFA -- PFA

		$COLON	83H,PF,A,PFA
		DW	ONE,	TRAV
	IF	_ALIGN
		DW	LIT,	6,	PLUS
		DW	LIT,	-2,	ANDD
	ELSE
		DW	LIT,	5,	PLUS
	ENDIF
		DW	SEMIS

;=:   !CSP	save SP at CSP				--

		$COLON	84H,!!!!CS,P,SCSP
		DW	SPAT,	CSPP
		DW	STORE,	SEMIS

;=:   ?ERROR	issue error message m if f is TRUE	f m --

		$COLON	86H,?ERRO,R,QERR
		DW	SWAP
			$GO?0	QERR1
		DW	ERROR
			$GOTO	QERR2
QERR1: 		DW	DROP
QERR2: 		DW	SEMIS

;=:   ?COMP	issue a message if not compiling	--

		$COLON	85H,?COM,P,QCOMP
		DW	STATE,	AT
		DW	ZEQU,	LIT,	17
		DW	QERR,	SEMIS

;=:   ?EXEC	issue a message if not executing	--

		$COLON	85H,?EXE,C,QEXEC
		DW	STATE,	AT
		DW	LIT,	18
		DW	QERR,	SEMIS

;=:   ?PAIRS	issue a message if n1 <> n2		n1 n2 --

		$COLON	86H,?PAIR,S,QPAIR
		DW	SUBB
		DW	LIT,	19
		DW	QERR,	SEMIS

;=:   ?CSP	issue a message if SP <> (CSP)		--

		$COLON	84H,?CS,P,QCSP
		DW	SPAT,	CSPP,	AT,	SUBB
		DW	LIT,	20
		DW	QERR,	SEMIS

;=:   ?LOADING	issue a message if not loading		--

		$COLON	88H,?LOADIN,G,QLOAD
		DW	BLK,	AT,	ZEQU
		DW	LIT,	22
		DW	QERR,	SEMIS

;=:   COMPILE	compile the following word at run time	--

		$COLON	87H,COMPIL,E,COMP
		DW	QCOMP
		DW	FROMR,	DUPP,	TWOP,	TOR
		DW	AT,	COMMA,	SEMIS

;=:   [		suspend compilation to do calculations	--

		$COLON	0C1H,,[,LBRAC
		DW	ZERO,	STATE,	STORE,	SEMIS

;=:   ]		resume compilation after [		--

		$COLON	81H,,],RBRAC
		DW	LIT,	0C0H
		DW	STATE,	STORE,	SEMIS

;=:   SMUDGE	make the latest definition unFINDable	--

		$COLON	86H,SMUDG,E,SMUDG
		DW	LATES
		DW	LIT,	20H
		DW	TOGGL,	SEMIS

;=:   HEX	set the current number base to 16	--

		$COLON	83H,HE,X
		DW	LIT,	16
		DW	BASE,	STORE,	SEMIS

;=:   DECIMAL	set the current number base to 10	--

		$COLON	87H,DECIMA,L,DECA
		DW	LIT,	10
		DW	BASE,	STORE,	SEMIS

;=:   (;CODE)	run time code for ;CODE			--

		$COLON	87H,(!!!;CODE,),PSCOD
		DW	FROMR,	LATES,	PFA
		DW	CFA,	STORE,	SEMIS

;=:   ;CODE	end colon compilation, start CODE	--

		$COLON	0C5H,!!!;COD,E,SEMIC
		DW	QCSP
		DW	COMP,	PSCOD,	LBRAC
SEMI1		DW	NOOP	; (ASSEMBLER)
		DW	SEMIS

;=:   <BUILDS	define compile time behavior		--

		$COLON	87H,!!!<BUILD,S,BUILD
		DW	ZERO,	CON,	SEMIS

;=:   DOES>	define run time behavior		--

		$COLON	85H,DOES,!!!>,DOES
		DW	FROMR,	LATES,	PFA,	STORE
		DW	PSCOD

DODOE: 		XCHG	BP,SP		;get RP
		PUSH	SI		;RP:=IP
		XCHG	BP,SP
		INC	DX		;point W to PFA
		MOV	BX,DX
		MOV	SI,[BX]		;IP:=(PFA)
		INC	DX
		INC	DX		;W points to PFA
		PUSH	DX
		JMP	NEXT

;=:   COUNT	prepare to type a string		addr -- addr+1 n

		$COLON	85H,COUN,T,COUNT
		DW	DUPP,	ONEP,	SWAP,	CAT,	SEMIS

;=:   TYPE	output n characters beginning at addr	addr n --

		$COLON	84H,TYP,E,TYPES
		DW	DDUP
			$GO?0	TYPE1
		DW	OVER,	PLUS
		DW	SWAP,	XDO
TYPE2: 		DW	IDO,	CAT,	EMIT
			$LOOP	TYPE2
			$GOTO	TYPE3
TYPE1: 		DW	DROP
TYPE3: 		DW	SEMIS

;=:   -TRAILING	adjust addr/n to avoid trailing blanks	addr n1 -- addr n2

		$COLON	89H,-TRAILIN,G,DTRAI
		DW	DUPP,	ZERO,	XDO
DTRA1: 		DW	OVER,	OVER,	PLUS
		DW	ONE,	SUBB,	CAT
		DW	BLS,	SUBB
			$GO?0	DTRA2
		DW	LEAVE
			$GOTO	DTRA3
DTRA2: 		DW	ONE,	SUBB
DTRA3: 			$LOOP	DTRA1
		DW	SEMIS

;=:   (.")	run time code for ."			--

		$COLON	84H,(.!!!",),PDOTQ
		DW	RR
		DW	COUNT,	DUPP,	ONEP
		DW	FROMR,	PLUS,	TOR
		DW	TYPES,	SEMIS

;=:   ."	print the following string		--

		$COLON	0C2H,.,!!!",DOTQ
		DW	LIT,	'"'
		DW	STATE,	AT
			$GO?0	DOTQ1
		DW	COMP
		DW	PDOTQ,	WORDS,	HERE
		DW	CAT,	ONEP,	ALLOT
			$GOTO	DOTQ2
DOTQ1: 		DW	WORDS,	HERE,	COUNT,	TYPES
DOTQ2: 		DW	SEMIS

;=:   EXPECT	input up to n characters to addr	addr n --

		$COLON	86H,EXPEC,T,EXPEC
		DW	OVER,	PLUS,	OVER
		DW	XDO
EXPE1: 		DW	KEY,	DUPP
		DW	LIT,	0EH
		DW	PORIG,	AT,	EQUAL
			$GO?0	EXPE2
		DW	DROP,	DUPP,	IDO
		DW	EQUAL,	DUPP,	FROMR
		DW	TWO,	SUBB,	PLUS
		DW	TOR
			$GO?0	EXPE6
		DW	LIT,	BELL
			$GOTO	EXPE7
EXPE6: 		DW	LIT,	BSOUT,	EMIT
		DW	BLS,	EMIT
		DW	LIT,	BSOUT
EXPE7: 			$GOTO	EXPE3
EXPE2: 		DW	DUPP,	LIT,	ACR
		DW	EQUAL
			$GO?0	EXPE4
		DW	LEAVE,	DROP,	BLS,	ZERO
			$GOTO	EXPE5
EXPE4: 		DW	DUPP
EXPE5: 		DW	IDO
		DW	CSTOR,	ZERO,	IDO,	ONEP
		DW	STORE
EXPE3: 		DW	EMIT
			$LOOP	EXPE1
		DW	DROP,	SEMIS

;=:   QUERY	EXPECT 80 characters to TIB		--

		$COLON	85H,QUER,Y,QUERY
		DW	TIB,	AT
		DW	LIT,	80,	EXPEC
		DW	ZERO,	INN,	STORE,	SEMIS

;=:   <nul>	0 in input: resets interpreter		--

		_NFA	= $
		DB	0C1H,80H	;zero header
		$LINKS	DOCOL

		DW	BLK,	AT
			$GO?0	NULL1
		DW	ONE,	BLK,	PSTOR
		DW	ZERO,	INN,	STORE
		DW	BLK,	AT
		DW	BSCR,	ONE,	SUBB,	ANDD
		DW	ZEQU
			$GO?0	NULL2
		DW	QEXEC,	FROMR,	DROP
NULL2: 			$GOTO	NULL3
NULL1: 		DW	FROMR,	DROP
NULL3: 		DW	SEMIS

;=C   FILL	fill n bytes at address with c		addr n c --

		$CODE	84H,FIL,L,FILL
		POP	AX		;fill char
		POP	CX		;fill count
		POP	DI		;destination address
		MOV	BX,DS
		MOV	ES,BX		;same segment
		CLD			;fill toward higher address
	REP	STOSB			;GO!
		JMP	NEXT

;=:   ERASE	fill n bytes at addr with 0's		addr n --

		$COLON	85H,ERAS,E,ERASEE
		DW	ZERO,	FILL,	SEMIS

;=:   BLANKS	fill n bytes at addr with blanks	addr n --

		$COLON	86H,BLANK,S,BLANK
		DW	BLS,	FILL,	SEMIS

;=:   HOLD	insert char in formatted output		c --

		$COLON	84H,HOL,D,HOLD
		DW	LIT,	-1
		DW	HLD,	PSTOR
		DW	HLD,	AT,	CSTOR,	SEMIS

;=:   PAD	returns addr of the text output buffer	-- addr

		$COLON	83H,PA,D,PAD
		DW	HERE,	LIT,	68,	PLUS,	SEMIS
		DW	PLUS,	SEMIS

;=:   WORD	get a word delimited by char to HERE	c --

		$COLON	84H,WOR,D,WORDS
		DW	BLK,	AT
			$GO?0	WORD1
		DW	BLK,	AT,	BLOCK
			$GOTO	WORD2
WORD1: 		DW	TIB,	AT
WORD2: 		DW	INN,	AT,	PLUS,	SWAP
		DW	ENCL,	HERE
		DW	LIT,	34
		DW	BLANK,	INN,	PSTOR
		DW	OVER,	SUBB,	TOR
		DW	RR,	HERE,	CSTOR
		DW	PLUS,	HERE,	ONEP
		DW	FROMR,	CMOVE,	SEMIS

;=:   (NUMBER)	ASCII to binary conversion primitive	d1 addr1 -- d2 addr2

		$COLON	88H,(NUMBER,),PNUMB
PNUM1: 		DW	ONEP
		DW	DUPP,	TOR
		DW	CAT,	BASE,	AT,	DIGIT
			$GO?0	PNUM2
		DW	SWAP,	BASE,	AT,	USTAR
		DW	DROP,	ROT,	BASE,	AT
		DW	USTAR,	DPLUS
		DW	DPL,	AT,	ONEP
			$GO?0	PNUM3
		DW	ONE,	DPL,	PSTOR
PNUM3: 		DW	FROMR
			$GOTO	PNUM1
PNUM2: 		DW	FROMR,	SEMIS

;=:   NUMBER	convert string at addr to 32-bit number	addr -- d

		$COLON	86H,NUMBE,R,NUMB
		DW	ZERO,	ZERO
		DW	ROT,	DUPP,	ONEP,	CAT
		DW	LIT,	"-",	EQUAL
		DW	DUPP,	TOR,	PLUS
		DW	LIT,	-1
NUMB1: 		DW	DPL,	STORE
		DW	PNUMB
		DW	DUPP,	CAT,	BLS,	SUBB
			$GO?0	NUMB2
		DW	DUPP,	CAT
		DW	LIT,	".",	SUBB
		DW	ZERO,	QERR,	ZERO
			$GOTO	NUMB1
NUMB2: 		DW	DROP,	FROMR
			$GO?0	NUMB3
		DW	DMINU
NUMB3: 		DW	SEMIS

;=:   -FIND	search dictionary for next input word	-- [PFA b] f

		$COLON	85H,-FIN,D,DFIND
		DW	BLS,	WORDS
		DW	HERE,	CONT,	AT,	AT
		DW	PFIND,	DUPP,	ZEQU
			$GO?0	DFIN1
		DW	DROP
		DW	HERE,	LATES,	PFIND
DFIN1: 		DW	SEMIS

;=:   (ABORT)	error function when WARNING is -1	--

		$COLON	87H,(ABORT,),PABOR
		DW	ABORT,	SEMIS

;=:   ERROR	system error handler - n is line no.	n -- [IN BLK]

		$COLON	85H,ERRO,R,ERROR
		DW	WARN,	AT,	ZLESS
			$GO?0	ERRO1
		DW	PABOR
ERRO1: 		DW	HERE,	COUNT,	TYPES
		DW	PDOTQ
		DB	2,"? "
		DW	MESS
		DW	SPSTO
		DW	BLK,	AT,	DDUP
			$GO?0	ERRO2
		DW	INN,	AT,	SWAP
ERRO2: 		DW	QUIT

;=:   ID.	print dictionary name field		NFA --

		$COLON	83H,ID,.,IDDOT
		DW	PAD
		DW	LIT,	32
		DW	LIT,	'_'
		DW	FILL
		DW	DUPP,	PFA,	LFA
		DW	OVER,	SUBB
		DW	PAD,	SWAP,	CMOVE
		DW	PAD,	COUNT
		DW	LIT,	1FH	;use low 5 bits of length

; ID. was changed to clear the MSB of the last char in the name

		DW	ANDD,	DUPP,	PAD,	PLUS
		DW	LIT,	80H,	TOGGL	;Zero the MSB
		DW	TYPES,	SPACE,	SEMIS

;=:*  CREATE	create a dictionary header		--

		$COLON	86H,CREAT,E,CREAT
		DW	DFIND
			$GO?0	CREA1
		DW	DROP,	NFA,	IDDOT
		DW	LIT,	4,	MESS	;"not unique"
		DW	SPACE
CREA1: 		DW	HERE,	DUPP,	CAT
		DW	NWIDTH,	AT,	MIN
		DW	ONEP,	ALLOT
		DW	DUPP
		DW	LIT,	0A0H
		DW	TOGGL			;smudge it
		DW	HERE,	ONE,	SUBB
		DW	LIT,	80H
		DW	TOGGL			;last char has bit 8 set

	IF	_ALIGN
;This section of code forces the body of a compiled FORTH word to
;lie on even addresses.  This allows the threaded CFA's to be
;fetched by the inner interpreter in one bus cycle.  For the 8088
;this means nothing, and the extra space required for alignment
;should be saved by setting _ALIGN to FALSE.  The literal 90H is
;used because MASM uses NOP's to align words.  NFA expects
;90H to be used also.
		DW	LIT,	90H,	CCOMM
		DW	DP,	AT
		DW	LIT,	-2,	ANDD
		DW	DP,	STORE
	ENDIF
		DW	LATES,	COMMA		;compile LFA
		DW	CURR,	AT,	STORE	;update vocabulary
		DW	HERE,	TWOP,	COMMA,	SEMIS	;CFA:=PFA

;=:   [COMPILE]	compile an otherwise immediate word	--

		$COLON	0C9H,[COMPILE,]
		DW	DFIND
		DW	ZEQU,	ZERO,	QERR
		DW	DROP,	CFA,	COMMA,	SEMIS

;=:   LITERAL	compile n to be used at run time	n --

		$COLON	0C7H,LITERA,L,LITER
		DW	STATE,	AT
			$GO?0	LITE1
		DW	COMP,	LIT,	COMMA
LITE1: 		DW	SEMIS

;=:   DLITERAL	compile d to be used at run time	d --

		$COLON	0C8H,DLITERA,L,DLITE
		DW	STATE,	AT
			$GO?0	DLIT1
		DW	SWAP,	LITER,	LITER
DLIT1:		DW	SEMIS

;=:   ?STACK	check if the stack is out of bounds	--

		$COLON	86H,?STAC,K,QSTAC
		DW	SPAT,	SZERO,	AT
		DW	SWAP,	ULESS,	ONE,	QERR	;underflow
		DW	SPAT,	HERE
		DW	LIT,	80H
		DW	PLUS,	ULESS
		DW	LIT,	7
		DW	QERR				;overflow
		DW	SEMIS

;=:   INTERPRET	outer text interpreter			--

		$COLON	89H,INTERPRE,T,INTER
INTE1: 		DW	DFIND			;begin
			$GO?0	INTE2
		DW	STATE,	 AT,	LESS
			$GO?0	INTE3
		DW	CFA,	COMMA		;compile it
			$GOTO	INTE4
INTE3: 		DW	CFA,	EXEC		;execute it
INTE4: 		DW	QSTAC
			$GOTO	INTE5
INTE2: 		DW	HERE,	NUMB,	DPL,	AT,	ONEP
			$GO?0	INTE6
		DW	DLITE			;32-bit number
			$GOTO	INTE7
INTE6: 		DW	DROP,	LITER		;16-bit number
INTE7:		DW	QSTAC
INTE5:			$GOTO	INTE1		;repeat forever

;=:   IMMEDIATE	mark the latest word to be executed	--

		$COLON	89H,IMMEDIAT,E
		DW	LATES
		DW	LIT,	40H	;bit 7 is precedence
		DW	TOGGL,	SEMIS

;=:   VOCABULARY	define a new vocabulary		--

		$COLON	8AH,VOCABULAR,Y
		DW	BUILD
		DW	LIT,	0A081H
		DW	COMMA
		DW	CURR,	AT
		DW	CFA,	COMMA,	HERE,	VOCL
		DW	AT,	COMMA,	VOCL,	STORE
		DW	DOES
DOVOC: 		DW	TWOP,	CONT,	STORE,	SEMIS

;=:   FORTH	FORTH vocabulary header			--

		$DOES	0C5H,FORT,H,FORTH
		DW	DOVOC
		DW	0A081H		;fake a null name field!
		DW	LASTNFA		;link changes as def's are added
		DW	0		;end of voc list

;=:   DEFINITIONS	set CURRENT to CONTEXT		--

		$COLON	8BH,DEFINITION,S,DEFIN
		DW	CONT,	AT
		DW	CURR,	STORE,	SEMIS

;=:   (		begin a comment ended by ')'		--

		$COLON	0C1H,,(
		DW	LIT,	')',	WORDS,	SEMIS

;=:   QUIT	halt execution, reset interpreter	--

		$COLON	84H,QUI,T,QUIT
		DW	ZERO,	BLK,	STORE
		DW	LBRAC
QUIT1: 		DW	RPSTO,	CR,	QUERY
		DW	INTER
		DW	STATE,	AT,	ZEQU
			$GO?0	QUIT2
		DW	PDOTQ
		DB	2,"ok"
QUIT2: 			$GOTO	QUIT1

;=:   ABORT	clear stacks and begin execution	--

		$COLON	85H,ABOR,T,ABORT
		DW	SPSTO,	DECA,	QSTAC,	CR
		DW	DOTCPU,	PDOTQ
		DB	16H,'Fig-FORTH  Version '
		DB	FIGREL+30H, '.', FIGREV+30H
		DW	LIT,	10,	PORIG,	CAT
		DW	LIT,	41H,	PLUS,	EMIT
		DW	FORTH,	DEFIN
		DW	LIT,	0,	PRTER,	STORE	;Reset echo

; The following lines add command line interpretation.
; Any text at 80H is copied to the TIB and interpreted.
; This code should probably go somewhere else, but I never bothered
; to move it...

		DW	LIT,	80H,	COUNT,	DUPP	;anyone here?
			$GO?0	AB1			;no...
		DW	ZERO,	LIT,	80H,	CSTOR	;don't do twice
		DW	TIB,	AT,	DUPP
		DW	LIT,	64,	ERASEE		;ensure NUL end
		DW	SWAP,	CMOVE			;move it
		DW	ZERO,	INN,	STORE
		DW	ZERO,	BLK,	STORE,	LBRAC
		DW	CR,	CR,	INTER		;interpret it
			$GOTO AB2
AB1:		DW	DROP,	DROP			;nothing to do
AB2:		DW	QUIT				;back to normal

; Warm start vector comes here

WRM: 		MOV	SI,OFFSET WRM1
		JMP	NEXT
WRM1		DW	WARM

;=:   WARM	empty disk buffers and abort		--

		$COLON	84H,WAR,M,WARM
		DW	MTBUF,	ABORT

; Cold start vector comes here

CLD: 		MOV	SI,OFFSET CLD1		;initialize IP
		MOV	AX,CS
		MOV	DS,AX			;all in one segment
		MOV	SP,12H[ORIG]		;initialize SP
		MOV	SS,AX
		MOV	ES,AX
		CLD				;SI gets incremented
		MOV	BP,RPP			;init RP

		CALL NEAR PTR SYSINIT	;system dependent initialization

		JMP	NEXT

CLD1 		DW	COLD

;=:*  COLD	full initialization and restart		--

		$COLON	84H,COL,D,COLD
		DW	DRZER,	MTBUF
		DW	FIRST,	USE,	STORE
		DW	FIRST,	PREV,	STORE
		DW	LIT,	ORIG+12H
		DW	LIT,	UP,	AT
		DW	LIT,	6,	PLUS
		DW	LIT,	16,	CMOVE	;USER variables
		DW	LIT,	ORIG+12,AT
		DW	LIT,	FORTH+6,STORE	;vocabulary link

; Initialize i/o vectors

		DW	LIT,	PKEY,	TICKEY,		STORE
		DW	LIT,	PEMIT,	TICKEMIT,	STORE
		DW	LIT,	PCR,	TICKCR,		STORE
		DW	LIT,	BLKRD,	TICKBRD,	STORE
		DW	LIT,	BLKWRT,	TICKBWRT,	STORE

		DW	ABORT

;=C   S->D	convert a 16-bit number to 32-bits	n -- d

		_NFA	= $
		DB	84H,'S->','D'+80H
		$LINKS	$+2,STOD

		POP	DX		;n, becomes LSW of result
		SUB	AX,AX
		OR	DX,DX		;is n negative?
		JNS	STOD1		;no, MSW:=AX=0
		DEC	AX		;yes, MSW:=-1
STOD1: 		JMP	DPUSH		;S1=MSW, S2=LSW

;=:   +-	apply the sign of n2 to n1		n1 n2 -- n3

		$COLON	82H,+,-,PM
		DW	ZLESS
			$GO?0	PM1
		DW	MINUS
PM1: 		DW	SEMIS

;=:   D+-	apply the sign of n to d1		d1 n -- d2

		$COLON	83H,D+,-,DPM
		DW	ZLESS
			$GO?0	DPM1
		DW	DMINU
DPM1: 		DW	SEMIS

;=:   ABS	take the absolute value of n1		n1 -- n2

		$COLON	83H,AB,S,ABBS
		DW	DUPP,	PM,	SEMIS

;=:   DABS	take the absolute value of d1		d1 -- d2

		$COLON	84H,DAB,S,DABS
		DW	DUPP,	DPM,	SEMIS

;=:   MIN	return the smaller of n1 and n2		n1 n2 -- n

		$COLON	83H,MI,N,MIN
		DW	TDUP,	GREAT
			$GO?0	MIN1
		DW	SWAP
MIN1: 		DW	DROP,	SEMIS
;=:   MAX	return the larger of two numbers	n1 n2 -- n

		$COLON	83H,MA,X,MAX
		DW	TDUP,	LESS
			$GO?0	MAX1
		DW	SWAP
MAX1: 		DW	DROP,	SEMIS

;=:   M*	mixed multiplication			n1 n2 -- d

		$COLON	82H,M,*,MSTAR
		DW	TDUP,	XORR,	TOR
		DW	ABBS
		DW	SWAP,	ABBS,	USTAR
		DW	FROMR,	DPM,	SEMIS

;=:   M/	mixed division				d n1 -- nrem nquot

		$COLON	82H,M,/,MSLAS
		DW	OVER,	TOR,	TOR
		DW	DABS
		DW	RR,	ABBS,	USLAS
		DW	FROMR,	RR,	XORR
		DW	PM,	SWAP,	FROMR
		DW	PM,	SWAP,	SEMIS

;=:   *		16-bit signed multipication		n1 n2 -- n1*n2

		$COLON	81H,,*,STAR
		DW	MSTAR,	DROP,	SEMIS

;=:   /MOD	16-bit signed division with remainder	n1 n2 -- nrem nquot

		$COLON	84H,/MO,D,SLMOD
		DW	TOR,	STOD,	FROMR
		DW	MSLAS,	SEMIS

;=:   /		16-bit signed division			n1 n2 -- nquot

		$COLON	81H,,/,SLASH
		DW	SLMOD,	SWAP,	DROP,	SEMIS

;=:   MOD	16-bit modulo division			n1 n2 -- nrem

		$COLON	83H,MO,D,MODD
		DW	SLMOD,	DROP,	SEMIS

;=:   */MOD	scale n1 by the ratio of n2 to n3	n1 n2 n3 -- nrem nquot

		$COLON	85H,*/MO,D,SSMOD
		DW	TOR,	MSTAR,	FROMR
		DW	MSLAS,	SEMIS

;=:   */	scale n1 by the ratio of n2 to n3	n1 n2 n3 -- nquot

		$COLON	82H,*,/,SSLA
		DW	SSMOD,	SWAP,	DROP,	SEMIS

;=:   M/MOD	mixed unsigned scaler			ud1 u -- urem udquot

		$COLON	85H,M/MO,D,MSMOD
		DW	TOR,	ZERO,	RR,	USLAS
		DW	FROMR,	SWAP,	TOR
		DW	USLAS,	FROMR,	SEMIS

;=:   (LINE)	convert a line/screen to addr/count	l s -- addr count

		$COLON	86H,(LINE,),PLINE
		DW	TOR
		DW	LIT,	64
		DW	BBUF,	SSMOD
		DW	FROMR,	BSCR,	STAR
		DW	PLUS
		DW	BLOCK,	PLUS
		DW	LIT,	64,	SEMIS

;=:   .LINE	type line n1 in screen n2		n1 n2 --

		$COLON	85H,.LIN,E,DLINE
		DW	PLINE,	DTRAI,	TYPES,	SEMIS

;=:   MESSAGE	type error message n			n --

		$COLON	87H,MESSAG,E,MESS
		DW	WARN,	AT
			$GO?0	MESS1
		DW	DDUP
			$GO?0	MESS2
		DW	LIT,	4
		DW	OFSET,	AT,	BSCR,	SLASH
		DW	SUBB,	DLINE,	SPACE
MESS2: 			$GOTO	MESS3
MESS1: 		DW	PDOTQ
		DB	6,"MSG # "
		DW	DOT
MESS3: 		DW	SEMIS

	$REPORT	<FORTH kernel completed>

INCLUDE	4TH-SYSD.ASM			;System dependent code

SUBTTL Disk interface words
PAGE +

;=?   DRIVE	disk drive last accessed		-- addr

		$VAR	85H,DRIV,E,DRIVE
		DW	0

;=?+  RECORD	disk record last accessed		-- addr

		$VAR	86H,RECOR,D,REC
		DW	0

;=?+  DTA	disk transfer address last used		-- addr

		$VAR	83H,DT,A,DTA
		DW	FIRST

;=?   USE	pointer to disk buffer to use next	-- addr

		$VAR	83H,US,E,USE
		DW	BUF1

;=?   PREV	pointer to disk buffer last accessed	-- addr

		$VAR	84H,PRE,V,PREV
		DW	BUF1

;=#   #BUFF	total number of block buffers		-- n

		$CONST	85H,#BUF,F,NOBUF
		DW	NSCR

;=?   DISK-ERROR	status of last disk operation	-- addr

		$VAR	8AH,DISK-ERRO,R,DSKERR
		DW	0

;=?*  PRINTER	flag controlling printer		-- addr

		$VAR	87H,PRINTE,R,PRTER
		DW	0

;Block read/write words modified to use execution vectors.
;The functions called by BLOCK-READ/-WRITE have the following stack
;effect: ( addr blk -- ) and set DISK-ERROR accordingly.

;=:+  BLOCK-READ	read one block to addr		addr blk --

		$COLON	8AH,BLOCK-REA,D,BLOCKRD
		DW	TICKBRD,	AT,	EXEC,	SEMIS

;=:+  BLOCK-WRITE	write one block from addr	addr blk --

		$COLON	8BH,BLOCK-WRIT,E,BLOCKWRT
		DW	TICKBWRT,	AT,	EXEC,	SEMIS

;=:*  +BUF	advance addr to next buffer		addr1 -- addr2

		$COLON	84H,+BU,F,PBUF
		DW	BBUF,	TWOP,	TWOP	;B/BUF+4
		DW	PLUS,	DUPP,	LIMIT,	EQUAL
			$GO?0	PBUF1
		DW	DROP,	FIRST
PBUF1: 		DW	DUPP,	PREV,	AT
		DW	SUBB,	SEMIS

;=:   UPDATE	mark PREV buffer to be saved		--

		$COLON	86H,UPDAT,E,UPDAT
		DW	PREV,	AT,	AT
		DW	LIT,	8000H
		DW	ORR
		DW	PREV,	AT,	STORE,	SEMIS

;=:*  EMPTY-BUFFERS	wipe out disk buffers		--

		$COLON	8DH,EMPTY-BUFFER,S,MTBUF
		DW	FIRST,	LIMIT,	OVER
		DW	SUBB,	ERASEE
;Modified so that emptied buffers won't look like block 0:
;instead, they're all assigned to block 32767.  If you want to
;use FORTH on a disk that big - TOO BAD!
		DW	LIT,	7FFFH
		DW	NOBUF,	ONEP,	ZERO,	XDO
MTBUF1:		DW	DUPP,	BUFFE,	DROP
			$LOOP	MTBUF1
		DW	DROP,	SEMIS

;Words added to save buffers:

;=:+  SAVBUF	saves buffer at addr if updated		addr --

		$COLON	86H,SAVBU,F,SAVBUF
		DW	DUPP,	TOR,	AT,	ZLESS
			$GO?0	SVBF1		;not updated, return
		DW	RR,	TWOP,	RR,	AT
		DW	LIT,	7FFFH,	ANDD	;15-bits only!
		DW	ZERO,	RSLW		;write it
		DW	DSKERR,	AT,	ZEQU
			$GO?0	SVBF1		;don't un-update if error
		DW	RR,	ONEP		;high byte!
		DW	LIT,	80H,	TOGGL	;un-update buffer
SVBF1:		DW	FROMR,	DROP,	SEMIS

;=:+  SAVE-BUFFERS	flush buffers but don't empty	--

		$COLON	8CH,SAVE-BUFFER,S,SAVBUFS
		DW	PREV,	AT
SVBFS1:		DW	PBUF,	OVER,	SAVBUF,	ZEQU
			$GO?0	SVBFS1
		DW	DROP,	SEMIS

;=:*  BUFFER	assign an available buffer to block n	n -- addr

;BUFFER changed to write out ALL dirty buffers when one is found.

		$COLON	86H,BUFFE,R,BUFFE
		DW	USE,	AT,	DUPP,	TOR
BUFF1: 		DW	PBUF
			$GO?0	BUFF1		;dont use PREV
		DW	USE,	STORE		;use this one NEXT!
		DW	RR,	AT,	ZLESS	;found a dirty one?
			$GO?0	BUFF2		;no
		DW	SAVBUFS			;yes, save ALL
BUFF2:		DW	RR,	STORE		;set header to n
		DW	RR,	PREV,	STORE	;this is now PREV
		DW	FROMR,	TWOP,	SEMIS	;leave data addr

;=:*  BLOCK	get block n				n -- addr

		$COLON	85H,BLOC,K,BLOCK
		DW	OFSET,	AT,	PLUS,	TOR	;get n+offset
		DW	PREV,	AT,	DUPP		;look in PREV first
		DW	AT,	RR,	SUBB
		DW	DUPP,	PLUS			;throw out high bit
			$GO?0	BLOC1			;n is in PREV
BLOC2: 		DW	PBUF,	ZEQU			;check next buffer
			$GO?0	BLOC3			;found it
		DW	DROP,	RR			;not in buffer
		DW	BUFFE,	DUPP			;get a buffer
		DW	RR,	ONE,	RSLW		;read blk
		DW	TWO,	SUBB			;leave buffer addr
BLOC3: 		DW	DUPP,	AT,	RR,	SUBB	;check the buffer
		DW	DUPP,	PLUS,	ZEQU
			$GO?0	BLOC2
		DW	DUPP,	PREV,	STORE		;either found it or read it
BLOC1: 		DW	FROMR,	DROP			;return
		DW	TWOP,	SEMIS

;T&SCALC now done by D&RCALC in SYSD.ASM file...

;=:*  R/W	block read/write, f=1=write, f=2=read	addr blk f --

		$COLON	83H,R/,W,RSLW
;Modified to simply pass the address and blk to the R/W functions
			$GO?0	RSLW1
		DW	BLOCKRD
			$GOTO	RSLW2
RSLW1:		DW	BLOCKWRT
RSLW2:		DW	DSKERR,	AT,	DDUP
			$GO?0	RSLW5		;OK
		DW	ZLESS
			$GO?0	RSLW3
		DW	LIT,	9		;Write error
			$GOTO	RSLW4
RSLW3:		DW	LIT,	8		;Read error
RSLW4:		DW	LIT,	7FFFH		;Set buffer to 32767
		DW	PREV,	AT,	STORE	; to mark as bad
		DW	WARN,	AT,	ZLESS	;If WARNING<0 then
			$GO?0 RSLW6		;assume he can handle it
			$GOTO RSLW7		;otherwise,
RSLW6:		DW	ZERO,	WARN,	STORE	;don't try to read!
RSLW7:		DW	QERR
RSLW5:		DW	SEMIS

;=:*  FLUSH	empty buffers, saving changed ones	--

		$COLON	85H,FLUS,H,FLUSH
		DW	NOBUF,	ONEP
		DW	ZERO,	XDO
FLUS1: 		DW	LIT,	7FFFH,	BUFFE,	DROP
			$LOOP	FLUS1
		DW	SEMIS

;=:   LOAD	interpret screen n			n --

		$COLON	84H,LOA,D
		DW	BLK,	AT,	TOR
		DW	INN,	AT,	TOR
		DW	ZERO,	INN,	STORE
		DW	BSCR,	STAR,	BLK,	STORE
		DW	INTER
		DW	FROMR,	INN,	STORE
		DW	FROMR,	BLK,	STORE
		DW	SEMIS

;=:   -->	continue with next screen		--

		$COLON	0C3H,--,!!!>
		DW	QLOAD
		DW	ZERO,	INN,	STORE
		DW	BSCR,	BLK,	AT
		DW	OVER,	MODD,	SUBB
		DW	BLK,	PSTOR,	SEMIS
SUBTTL
PAGE +


;=:   '		find next input word in dictionary	-- PFA

		_NFA	= $
		DB	0C1H,"'"+80H
		$LINKS	DOCOL,TICK

		DW	DFIND,	ZEQU
		DW	ZERO,	QERR
		DW	DROP,	LITER,	SEMIS

;=:*  FORGET	chop off the top of the dictionary	--

		$COLON	86H,FORGE,T
		DW	CURR,	AT
		DW	CONT,	AT
		DW	SUBB
		DW	LIT,	24,	QERR	;"declare vocabulary"
		DW	TICK,	DUPP
		DW	FENCE,	AT,	ULESS	;note change from fig
		DW	LIT,	21,	QERR	;"in protected dictionary"
		DW	DUPP
		DW	NFA,	DP,	STORE
		DW	LFA,	AT
		DW	CONT,	AT,	STORE,	SEMIS
SUBTTL Control flow structures
PAGE

;=:   BACK	compile a backward branch offset	target --

		$COLON	84H,BAC,K,BACK
		DW	HERE,	SUBB
		DW	COMMA,	SEMIS

;=:   BEGIN	starting point of looping structures	-- HERE 1

		$COLON	0C5H,BEGI,N
		DW	QCOMP
		DW	HERE,	ONE,	SEMIS

;=:   ENDIF	end of IF..ELSE..THEN structure		addr 2 --

		$COLON	0C5H,ENDI,F,ENDIFF
		DW	QCOMP
		DW	TWO,	QPAIR
		DW	HERE,	OVER,	SUBB
		DW	SWAP,	STORE,	SEMIS

;=:   THEN	synonym for ENDIF			addr 2 --

		$COLON	0C4H,THE,N
		DW	ENDIFF,	SEMIS

;=:   DO	start of DO..LOOP structure		-- HERE 3

		$COLON	0C2H,D,O
		DW	COMP,	XDO
		DW	HERE,	THREE,	SEMIS

;=:   LOOP	end of DO..LOOP structure		addr 3 --

		$COLON	0C4H,LOO,P
		DW	THREE,	QPAIR
		DW	COMP,	XLOOP
		DW	BACK,	SEMIS

;=:   +LOOP	end of DO..+LOOP structure		addr 3 --

		$COLON	0C5H,+LOO,P
		DW	THREE,	QPAIR
		DW	COMP,	XPLOO
		DW	BACK,	SEMIS

;=:   UNTIL	end of BEGIN..UNTIL loop		addr 1 --

		$COLON	0C5H,UNTI,L,UNTIL
		DW	ONE,	QPAIR
		DW	COMP,	ZBRAN
		DW	BACK,	SEMIS

;=:   END	synonym for UNTIL			addr 1 --

		$COLON	0C3H,EN,D
		DW	UNTIL,	SEMIS

;=:   AGAIN	end of BEGIN..AGAIN infinite loop	addr 1 --

		$COLON	0C5H,AGAI,N,AGAIN
		DW	ONE,	QPAIR
		DW	COMP,	BRAN
		DW	BACK,	SEMIS

;=:   REPEAT	end of BEGIN..WHILE..REPEAT structure	addr 1 --

		$COLON	0C6H,REPEA,T
		DW	TOR,	TOR
		DW	AGAIN
		DW	FROMR,	FROMR
		DW	TWO,	SUBB
		DW	ENDIFF,	SEMIS

;=:   IF	conditional branch structure		-- 2

		$COLON	0C2H,I,F,IFF
		DW	COMP,	ZBRAN
		DW	HERE,	ZERO,	COMMA
		DW	TWO,	SEMIS

;=:   ELSE	optional part of IF..ELSE..THEN		addr 2 -- HERE 2

		$COLON	0C4H,ELS,E
		DW	TWO,	QPAIR
		DW	COMP,	BRAN
		DW	HERE,	ZERO,	COMMA
		DW	SWAP
		DW	TWO,	ENDIFF,	TWO
		DW	SEMIS

;=:   WHILE	conditional loop BEGIN..WHILE..REPEAT	addr 2 -- HERE 4

		$COLON	0C5H,WHIL,E
		DW	IFF,	TWOP,	SEMIS
SUBTTL Output formatting words
PAGE +


;=:   SPACES	type n spaces				n --

		$COLON	86H,SPACE,S,SPACS
		DW	ZERO,	MAX
		DW	DDUP
			$GO?0	SPAX1
		DW	ZERO,	XDO
SPAX2: 		DW	SPACE
			$LOOP	SPAX2
SPAX1: 		DW	SEMIS

;=:   <#	begin number formatting			--

		$COLON	82H,!!!<,#,BDIGS
		DW	PAD,	HLD,	STORE
		DW	SEMIS

;=:   #>	end number formatting			d -- addr count

		$COLON	82H,#,!!!>,EDIGS
		DW	DROP,	DROP
		DW	HLD,	AT
		DW	PAD
		DW	OVER,	SUBB,	SEMIS

;=:   SIGN	places a '-' in output if n < 0		n d -- d

		$COLON	84H,SIG,N,SIGN
		DW	ROT,	ZLESS
			$GO?0	SIGN1
		DW	LIT,	'-',	HOLD
SIGN1: 		DW	SEMIS

;=:   #		convert one digit of d1 to ASCII	d1 -- d2

		$COLON	81H,,#,DIG
		DW	BASE,	AT,	MSMOD
		DW	ROT
		DW	LIT,	9
		DW	OVER,	LESS
			$GO?0	DIG1
		DW	LIT,	7,	PLUS
DIG1: 		DW	LIT,	'0',	PLUS
		DW	HOLD,	SEMIS

;=:   #S	process all significant digits of d1	d1 -- 0.

		$COLON	82H,#,S,DIGS
DIGS1: 		DW	DIG
		DW	OVER,	OVER
		DW	ORR,	ZEQU
			$GO?0	DIGS1
		DW	SEMIS

;=:   D.R	print d right-aligned in n columns	d n --

		$COLON	83H,D.,R,DDOTR
		DW	TOR,	SWAP,	OVER
		DW	DABS
		DW	BDIGS
		DW	DIGS,	SIGN
		DW	EDIGS
		DW	FROMR,	OVER,	SUBB
		DW	SPACS,	TYPES,	SEMIS

;=:   .R	print n1 right-aligned in n2 columns	n1 n2 --

		$COLON	82H,.,R,DOTR
		DW	TOR
		DW	STOD,	FROMR,	DDOTR,	SEMIS

;=:   D.	print a 32-bit number			d --

		$COLON	82H,D,.,DDOT
		DW	ZERO
		DW	DDOTR,	SPACE,	SEMIS

;=:   .		print a 16-bit number			n --

		$COLON	81H,,.,DOT
		DW	STOD,	DDOT,	SEMIS

;=:   ?		print the value at addr			addr --

		$COLON	81H,,?,QUES
		DW	AT,	DOT,	SEMIS

;=:   U.	print an unsigned 16-bit number		u --

		$COLON	82H,U,.,UDOT
		DW	ZERO,	DDOT,	SEMIS

;=:   VLIST	print the words in CONTEXT vocabulary	--

		$COLON	85H,VLIS,T
		DW	LIT,	80H
		DW	OUTT,	STORE
		DW	CONT,	AT,	AT
VLIS1: 		DW	OUTT,	AT
		DW	CSLL,	GREAT
			$GO?0	VLIS2
		DW	CR
		DW	ZERO,	OUTT,	STORE
VLIS2: 		DW	DUPP
		DW	IDDOT
		DW	SPACE,	SPACE
		DW	PFA,	LFA,	AT
		DW	DUPP,	ZEQU
		DW	QTERM,	ORR
			$GO?0	VLIS1
		DW	DROP,	SEMIS

;=:   LIST	list screen n, as 16 lines of 64 chars	n --

		$COLON	84H,LIS,T,LISTC
		DW	DUPP,	BLOCK	,DROP	;added 7-9-83
		DW	DECA,	CR
		DW	DUPP,	SCR,	STORE
		DW	PDOTQ
		DB	6,"SCR # "
		DW	DOT
		DW	LIT,	16,	ZERO,	XDO
LIST1: 		DW	CR,	IDO
		DW	LIT,	3,	DOTR,	SPACE
		DW	IDO,	SCR,	AT,	DLINE
		DW	QTERM
			$GO?0	LIST2
		DW	LEAVE
LIST2: 			$LOOP	LIST1
		DW	CR,	SEMIS

;=:   INDEX	print line 0 of screens n1 thru n2	n1 n2 --

		$COLON	85H,INDE,X
		DW	LIT,	FF,	EMIT,	CR
		DW	ONEP,	SWAP,	XDO
INDE1: 		DW	CR,	IDO
		DW	LIT,	3,	DOTR,	SPACE
		DW	ZERO,	IDO,	DLINE
		DW	QTERM
			$GO?0	INDE2
		DW	LEAVE
INDE2: 			$LOOP	INDE1
		DW	SEMIS

;=:   TRIAD	list screens in groups of three		n1 n2 --

		$COLON	85H,TRIA,D
		DW	LIT,	FF,	EMIT
		DW	LIT,	3,	SLASH
		DW	LIT,	3,	STAR
		DW	LIT,	3,	OVER
		DW	PLUS,	SWAP,	XDO
TRIA1: 		DW	CR,	IDO,	LISTC
		DW	QTERM
			$GO?0	TRIA2
		DW	LEAVE
TRIA2: 			$LOOP	TRIA1
		DW	CR
		DW	LIT,	15,	MESS,	CR
		DW	SEMIS
;
		$COLON	84H,.CP,U,DOTCPU
		DW	BASE,	AT
		DW	LIT,	36,	BASE,	STORE
		DW	LIT,	22H,	PORIG,	TAT
		DW	DDOT
		DW	BASE,	STORE,	SEMIS

IF	_EXTEND
INCLUDE	4TH-XTNS.ASM
ENDIF

	$REPORT	<FORTH definitions completed>

SUBTTL End of FORTH dictionary
PAGE



;=:   TASK	word to mark the end of the dictionary	--

LASTNFA:
		$COLON	84H,TAS,K,TASK
		DW	SEMIS
;
INITDP		EQU	$
MAIN		ENDS

	$REPORT	<End of assembly source>

		END	ORIG
ragment  which,  on  receiving
                  control after you  hit  ^C,  examines  t