*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*
*								*
*   jax4th.a ...						*
*		direct-threaded amiga resident proto ans forth	*
*		*C* COPYRIGHT 1991 jack j. woehr		*
*		jax@well{.UUCP,.sf.ca.us} JAX on GEnie		*
*		Version 0.dpANS-2				*
*		An unofficial implementation of X3J14 dpANS-2	*
*								*
*	For information on the proposed ANS Forth, contact:	*
*								*
*			ANS ASC X3/X3J14 Technical Committee	*
*			111 N. Sepulveda Blvd., Suite 300	*
*			Manhattan Beach, CA 90266 USA		*
*								*
* !NO WARRANTIES, NO GUARANTEES, NO SOAP RADIO! YER ON YER OWN!	*
*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*

*	DEBUG

	INCLUDE	"exec/types.i"
	INCLUDE "exec/alerts.i"
	INCLUDE "exec/libraries.i"
	INCLUDE	"exec/memory.i"
	INCLUDE	"libraries/dos.i"
	INCLUDE	"libraries/dosextens.i"
	INCLUDE	"prelvo.i"
	INCLUDE "jax4th.i"

*--- Our Program ---*

	SECTION	ForthRes,CODE

start	; symbol needed by macro kcomp in jax4th.i and NSstart below

;---------------------------------------------------------------;
; We start with a jump to later in the image where things have	;
; more or less sorted themselves out.				;
;---------------------------------------------------------------;

	bra.w	forthstart

;-----------------------------------------------------------------------;
; Now a copy of routine which will consume ~~1/3 of Forth execution.	;
; The working copy of NEXT resides at base of each local code image	;
; so as to allow substitution of a DEBUG routine.			;
;-----------------------------------------------------------------------;

next	move.l	(ip)+,d0	; get execution token ( == addr>>1)
	exetok

;-----------------------------------------------------------------------;
; NSstart an important symbol because we initialize portions of the	;
; system by jumping into the local code segment. NSstart is the first	;
; element of the local code segment residing past the local copy of	;
; the NEXT routine (which latter is why it the local code segment is	;
; sometimes called the Next Segment). In any event, this init routine's	;
; offset in the Next Segment is equivalent to the calculation performed	;
; here below:								;
;-----------------------------------------------------------------------;

NSstart	EQU	*-next

;-----------------------------------------------------------------------;
; And here is the equivalent of more of the startup in the Default	;
; Image, which contains relocatable addresses, so that this size can	;
; be gauged in the image-save routine.					;
;-----------------------------------------------------------------------;
	move.l	$7fffff00,dp	; first allocateable code offset
	movea.l	#$7fff0000,bp	; base of data seg
	move.l	$7fff0000,ap	; first allocatable data offset

S_end	EQU	*-next	; label used by image-saving code

;-----------------------------------------------------------------------;
; The first link field in the dictionary is also the first link in the	;
; IMPLEMENTED wordlist, the wordlist of non-standard words used in	;
; this implementation. This wordlist should shrink over time.		;
;-----------------------------------------------------------------------;

linki0	set	(((*-start)>>1)|kernbit)
	dc.l	0
	nfa	7,'PERFOR','M'	; ( a-addr --)
perform	move.l	0(bp,tos.l),d0	; execute token stored at addr on TOS
	popdsp			; clean up stack
	exetok

defer	macro		; \1 is the data address
	push	*+8(PC)	; get the deferral data address
	jmp	perform	; branch to perform
	dc.l	\1	; the stored deferral data address
	endm

kcomp	macro	; compile a Forth address properly masked as kernel
	dc.l	(((\1-start)>>1)|kernbit)
	endm

*--- Branching & Control Flow Primitives

doif	pop	d0		; grab flag from stack
	tst.l	d0		; was TOS is a TRUE flag?
	beq.s	doelse		; no, we will have to reload IP
	addq.l	#4,ip		; otherwise, jump past inline branch addr
	bra.s	doifdon		; return to Forth
doelse	move.l	(ip),ip		; no, load token into IP
	dereftok	ip	; and convert to address 
doifdon	tonext			; return to inner interpreter

;-----------------------------------------------------------------------;
; The label DOELSE also works as execution engine for REPEAT and AGAIN.	;
;-----------------------------------------------------------------------;

dountil	pop	d0		; grab flag from stack
	tst.l	d0		; was TOS is a TRUE flag?
	bne.s	dountnz		; yes, branch to exit UNTIL loop
	move.l	(ip)+,ip	; no, get branchback compiled by BEGIN
	dereftok	ip	; convert to address
	tonext			; return to inner interpreter
dountnz	addq.l	#4,ip		; jump past branchback address
	tonext			; return to inner interpreter

;---------------------------------------------------------------;
; The label DOUNTIL also works as execution engine for WHILE.	;
;---------------------------------------------------------------;

dodo	rpush	(ip)+		; save exit address on ret stack
	addi.l	#$80000000,(dsp); add overflow limit to outer loop index
	sub.l	(dsp),tos	; and subtract result from inner loop index
	rpush	(dsp)+		; push massaged outer loop index
	pop	-(rp)		; push massaged inner loop index
	tonext

doqdo	cmp.l	(dsp),tos	; see if loop indices are equal
	bne.s	dodo		; they're not, branch to "do"
	adda.l	#4,dsp		; discard outer index
	popdsp			; discard inner index
	move.l	(ip),ip		; no, load token into IP
	dereftok	ip	; and convert to address 
	tonext

; The macro DEREFTOK uses 8$ and 9$ as local labels
doloop	addq.l	#1,(rp)		; increment massaged inner index
doloopa	bvs.s	2$		; if we overflowed, it's time to exit
	move.l	(ip)+,ip	; but if not, get loopback address
	dereftok	ip	; convert to address
	tonext			; and go with it
2$	adda.l	#12,rp		; clear return stack
	addq.l	#4,ip		; branch past loopback address
	tonext

; The macro DEREFTOK uses 8$ and 9$ as local labels
doploop	pop	d0		; grab increment from stack
	add.l	d0,(rp)		; increment massaged inner index
	bvs.s	2$		; if we overflowed, it's time to exit
	move.l	(ip)+,ip	; but if not, get loopback address
	dereftok	ip	; convert to address
	tonext			; and go with it
2$	adda.l	#12,rp		; clear return stack
	addq.l	#4,ip		; branch past loopback address
	tonext

;-----------------------------------------------------------------------;
; Loop index fetching ... the engines are here, the actual word "I"	;
; will have to be a compiler-smart word to know which engine to compile.;
;-----------------------------------------------------------------------;

dodoi	push	(rp)		; push massaged inner loop
	add.l	4(rp),tos	; un-massage by adding massaged outer loop
	tonext

*dofori	push	fn		; push FOR ... NEXT index
*	tonext

dodoj	push	12(rp)		; push massaged inner loop
	add.l	16(rp),tos	; un-massage by adding massaged outer loop
	tonext

compif	macro			; assemble the IF engine with targaddr
	kcomp	doif
	kcomp	\1
	endm

compelse	macro		; assemble the ELSE engine with targaddr
	kcomp	doelse
	kcomp	\1
	endm

compuntil	macro		; assemble the UNTIL engine with a branch addr
	kcomp	dountil
	kcomp	\1
	endm

compdo	macro			; assemble DO engine and exit branch
	kcomp	dodo		; engine
	kcomp	\1		; branch
	endm

compqdo	macro			; assemble ?DO engine and exit branch
	kcomp	doqdo		; engine
	kcomp	\1		; branch
	endm

comploop	macro		; assemble LOOP engine and loopback branch
	kcomp	doloop		; engine
	kcomp	\1		; branch
	endm

compploop	macro		; assemble +LOOP engine and loopback branch
	kcomp	doploop		; engine
	kcomp	\1		; branch
	endm

	lfa	i0
	nfa	10,'((ABORT")',')'
ppabortq	nest	; How to ABORT" from the kernel ( flag --)
	kcomp	r_fet	; get address of kernel cell which starts countstring
	kcomp	abstod	; convert to data seg address
	kcomp	count	; -- flag addr ct
	kcomp	rot	; -- addr ct flag
	kcomp	qerror	; --
	kcomp	pr_from	; -- ip 
	kcomp	dup	; -- ip ip
	kcomp	abstod	; -- ip ip-dseg
	kcomp	count	; -- ip addr ct
	kcomp	onepl	; -- ip addr ct' ,one extra for count byte itself!
	kcomp	nip	; -- ip ct'
	kcomp	plus	; -- ip'
	kcomp	aligned	; -- ip-aligned
	kcomp	pto_r	; restore ip
	kcomp	unnest

abortq	macro
	kcomp	ppabortq
	countstr	\1
	endm

*--- Prims for Literals

; Numeric literals

	lfa	i0
	nfa	5,'(LIT',')'	; ( -- n)
parlit	push	(ip)+		; pushes literal in next cell onto stack 
	tonext

literal	macro		; \1 is literal value
	kcomp	parlit
	dc.l	\1
	endm

	lfa	i0
	nfa	6,'(2LIT',')'	; ( -- d)
p2lit	push	(ip)+
	move.l	(ip)+,-(dsp)
	tonext

dliteral	macro
	kcomp	p2lit
	dc.l	\1	; high order
	dc.l	\2	; low order
	endm

; Here's how we assemble dot-quotes during assembly of the kernel

dotq	macro			; \1 is a string in this kernel assembly
	kcomp	ppdotq		; execution engine
	countstr	\1	; counted string
	endm

*--- Deferral, but this isn't in the BASIS so may disappear

	lfa	0
	nfa	4,'(IS',')'	; ( --)
paris	move.l	(ip)+,a0		; data address
	move.l	(ip)+,0(bp,a0.l)	; vector
	tonext

is	macro		; \1 is data address \2 is new vector
	kcomp	paris
	dc.l	\1
	kcomp	\2
	endm

;-----------------------------------------------------------------------;
; Note: The notation " 91xxxx jax" at the tail of a Standard word	;
; indicates approximately the date upon which I became convinced	;
; that the word was reasonably debugged ... some of the notations	;
; are pretty much post-facto.						;
;-----------------------------------------------------------------------;

;-----------------------------------------------------------------------;
;			     CORE Word Set				;
;-----------------------------------------------------------------------;

link1	set	(((*-start)>>1)|kernbit)
	dc.l	0	; dpANS-2 CORE
	nfa	1,'!'	; ( x a-addr --)
store	walin	tos	; no guru
	sto		; macro from jax4th.i
	popdsp		; drop tos
	tonext		; 910705 jax

link3	set	(((*-start)>>1)|kernbit)
	dc.l	0	; dpANS-2 CORE
	nfa	1,'#'	; ( ud1 -- ud2)
sharp	nest
	kcomp	bas	; -- ud1 addr
	kcomp	fetch	; -- ud1 n
	kcomp	pto_r	; -- ud1		R: -- n
	literal	0	; -- ud1 0		R: -- n
	kcomp	r_fet	; -- ud1 0 n		R: -- n
	kcomp	umslmod	; -- ud1l rem ud2h	R: -- n
	kcomp	pr_from	; -- ud11 rem ud2h n	R: --
	kcomp	swap	; -- ud1l rem n ud2h
	kcomp	pto_r	; -- ud1l rem n		R: -- ud2h
	kcomp	umslmod	; -- digit ud2l		R: -- ud2h
	kcomp	pr_from	; -- digit ud21 ud2h	R: --
	kcomp	rot	; -- ud2l ud2h digit
	literal	9	; -- ud2l ud2h digit 9
	kcomp	over	; -- ud2 digit 9 digit
	kcomp	lesst	; -- ud2 dig flag
	compif	_1sharp	; -- ud2 dig
	literal	"A"-10	; -- ud2 dig n
	kcomp	plus	; -- ud2 ascii
	compelse	_2sharp	; -- ud2 dig
_1sharp	literal	"0"	; -- ud2 dig "0"
	kcomp	plus	; -- ud2 ascii
_2sharp	kcomp	hold	; -- ud2
	kcomp	unnest	; 910705 jax

	lfa	3		; dpANS-2 CORE
	nfa	2,'#','>'	; ( xd -- c-addr u)
sharpr	nest
	kcomp	twodrop	; --
	kcomp	hl	; -- a-addr
	kcomp	fetch	; -- c-addr
	kcomp	pad	; -- c-addr a-addr
	kcomp	over	; -- c-addr a-addr c-addr
	kcomp	minus	; -- c-addr u
	kcomp	unnest	; 910705 jax

	lfa	3		; dpANS-2 CORE
	nfa	2,'#','S'	; ( ud1 -- ud2)
sharps	nest
_1sharps			; -- ud1
	kcomp	sharp		; -- ud2
	kcomp	twodup		; -- ud2 ud2
	kcomp	b_or		; -- ud2 w
	kcomp	zeroeq		; -- ud2 flag
	compuntil _1sharps	; -- ud2
	kcomp	unnest		; 910705 jax

	lfa	3		; dpANS-2 CORE
	nfa	4,'#TI','B'	; ( -- a-addr)
numti	docreat	numtib		; 910705 jax

	lfa	3		; dpANS-2 CORE
	nfa	1,''''		; ( "name" -- xt)
tick	nest
	kcomp	defined		; -- addr -1|0|1
	kcomp	zeroeq		; -- addr flag
	kcomp	qmissing	; -- abort on not found
	kcomp	unnest		; 910705 jax

***!!!*** ANS	Supposed to span lines of files, doesn't yet.
link0	set	(((*-start)>>1)|kernbit)
	dc.l	0		; dpANS-2 CORE
	nfi	1,'('		; ( "ccc<)>" --)
lparen	nest			; supposed to span lines, this doesn't yet!
	literal	")"		; -- char
	kcomp	word		; -- addr
	kcomp	drop		; --
	kcomp	unnest
***!!!***

link2	set	(((*-start)>>1)|kernbit)
	dc.l	0		; dpANS-2 CORE
	nfa	1,<'*'>		; ( n1|u1 n2|u2 -- n3|u3)
star	nest
	kcomp	umstar		; -- d
	kcomp	d_to_s		; -- s
	kcomp	unnest		; 910909 jax

	lfa	2		; dpANS-2 CORE
	nfa	2,<'*'>,<'/'>	; ( n1 n2 n3 -- n4)
strsl	nest
	kcomp	strslmd		; -- r q
	kcomp	nip		; -- q
	kcomp	unnest

	lfa	2		; dpANS-2 CORE
	nfa	5,<'*/MO'>,'D'	; ( n1 n2 n3 -- n4 n5)
strslmd	nest
	kcomp	pto_r		; -- n1 n2	R: -- n3
	kcomp	umstar		; -- d		R: -- n3
	kcomp	pr_from		; -- d n3	R: --
	kcomp	umslmod		; -- r q
	kcomp	unnest		; 910909 jax

	lfa	3		; dpANS-2 CORE
	nfa	1,'+'		; ( n1|u1 n2|u2 --- n3|u3)
plus	add.l	(dsp)+,tos	; add two top stack items
	tonext			; 910710 jax

	lfa	3		; dpANS-2 CORE
	nfa	2,'+','!'	; ( n|u a-addr --)
plstore	walin tos		; no guru
	pop	a0		; address
	add.l	0(bp,a0.l),tos	; contents + tos
	pop	<0(bp,a0.l)>	; store
	tonext			; 910708 jax

	lfa	3		; dpANS-2 C CORE ( dodest --) ( compiling)
	nfi	5,'+LOO','P'	; ( n --) ( R: sys --) ( if the loop exits)
				; ( n --) ( R: sys1 -- sys2) ( otherwise)
kploop	nest			; an immediate colon def
	kcomp	chkstat		; abort if interpreting
	literal	doflag		; THEN check for DOFLAG
	kcomp	noteq		; test
	abortq	"DOFLAG missing at +LOOP"	; abort with error
	kcomp	parlit		; we need the kernel LOOP engine
	kcomp	doploop		; LOOP engine addr as kernel token
	kcomp	ctok		; compile it at runtime
	kcomp	mtok		; convert address to a local code token
	kcomp	ctok		; compile it at runtime
	kcomp	unnest		; 910909 jax

	lfa	0		; dpANS-2 CORE
	nfa	1,<','>		; ( x --)
comma	wapalin			; no guru
	move.l	tos,0(bp,ap.l)	; store to dataseg
	addq.l	#4,ap		; post-increment the allocation pointer
	popdsp			; discard TOS
	tonext			; 910909 jax

	lfa	1		; dpANS-2 CORE
	nfa	1,'-'		; ( n1|u1 n2|u2 --- n3|u3)
minus	pop	d0		; subtract two top stack items
	sub.l	d0,tos
	tonext			; 910706 jax

	lfa	2		; dpANS-2 CORE
	nfa	1,'.'		; ( n --)
dot	nest
* The next instructions are a temporary expedient ...
	kcomp	depth		; -- n1 n2
	literal	1
	kcomp	lesst		; -- n1 flag
	abortq	"Stack Underflow"	; --
* ... since underflowing the stack with dot ( . ) has bizarre results.
	kcomp	s_to_d		; -- d1
	kcomp	tuck		; -- d1h d1
	kcomp	dabs		; -- d1h _d1_
	kcomp	lsharp		; -- d1h d1
	kcomp	sharps		; -- d1h d2
	kcomp	rot		; -- d2 d1h
	kcomp	zerolt		; -- d2 flag
	compif	_1dot		; -- d2
	literal	'-'		; -- d2 char
	kcomp	hold		; -- d2
_1dot	kcomp	sharpr		; -- c-addr u
	kcomp	type		; --
	kcomp	space		; --
	kcomp	unnest		; 910909 jax

; (.") prints a string stored in the DSeg whose address is in the NSeg,
; such a setup being the norm for runtime compiled strings.

	lfa	i0
	nfa	4,'(."',')'	; ( --)
pdotq	move.l	(ip)+,a0	; A0 pointing at DSeg address of count byte
	moveq.l	#0,d0		; clear for count byte
	move.b	0(bp,a0.l),d0	; count byte of string
	addi.l	#1,a0		; increment to point at string
	push	a0		; address
	push	d0		; count
	bra.w	type		; execute a type

; ((.")) prints a string actually stored in the Kernel Dictionary

	lfa	i0
	nfa	6,'((.")',')'	; ( --)
ppdotq	movea.l	ip,a0		; IP was pointing to count byte
	pshdsp			; we need tos
	moveq.l	#0,tos		; clear tos for count
	move.b	(a0)+,tos	; tos <- count, A0 <- string itself
	move.l	tos,d0		; save copy of count
	addq.l	#1,d0		; add one for count byte
	adda.l	d0,ip		; bump IP with count+one for count byte
	andi.l	#1,d0		; was result odd?
	adda.l	d0,ip		; bump IP with alignment byte, if any
	suba.l	bp,a0		; make it a BP-relative address for DOSWRITE
	move.l	a0,-(dsp)	; ( b-addr u --)
	bra.w	type		; type out string

	lfa	2		; dpANS-2 C CORE
	nfi	2,'.','"'	; ( "ccc<">" --) ( compiling) ( --) ( execution)
kdotq	nest
	kcomp	chkstat		; abort if interpreting
	kcomp	parlit
	kcomp	pdotq		; execution engine for string in DSeg
	kcomp	ctok		; compile at run time
	kcomp	commaq		; compile string into DSeg
	kcomp	unnest		; 910706 jax

	lfa	3		; dpANS-2 CORE
	nfa	1,'/'		; ( n1 n2 -- n3)
slash	nest
	kcomp	slmod		; -- r q
	kcomp	nip		; -- q
	kcomp	unnest		; 910706 jax

	lfa	3		; dpANS-2 CORE
	nfa	4,'/MO','D'	; ( n1 n2 -- n3 n4)
slmod	nest
	kcomp	pto_r		; -- n1		R: -- n2
	kcomp	s_to_d		; -- d		R: -- n2
	kcomp	pr_from		; -- d n2	R: --
	kcomp	fmslmod		; -- r q
	kcomp	unnest		; 910707 jax

	lfa	0		; dpANS-2 CORE
	nfa	2,'0',<'<'>	; ( n -- flag)
zerolt	tst.l	tos
	smi	tos	; this construct saves four cycles on 68000
	ext.w	tos	; compared to branch on condition
	ext.l	tos	; in cases where flag is FALSE
	tonext

	lfa	0		; dpANS-2 CORE
	nfa	2,'0','='	; ( n|u -- flag)
zeroeq	tst.l	tos	; see above
	seq	tos
	ext.w	tos
	ext.l	tos
	tonext		; 910909 jax

	lfa	1		; dpANS-2 CORE
	nfa	2,'1','+'	; ( n1|u1 -- n2|u2)
onepl	addq.l	#1,tos
	tonext		; 910909 jax

	lfa	1		; dpANS-2 CORE
	nfa	2,'1','-'	; ( n1|u1 -- n2|u2)
onemi	subq.l	#1,tos
	tonext		; 910909 jax

	lfa	2		; dpANS-2 CORE
	nfa	2,'2',<'!'>	; ( x1 x2 a-addr --)
twosto	walin	tos			; no guru
	movea.l	tos,a0			; move dest to an address register
	move.l	(dsp)+,0(bp,a0.l)	; move data to dataseg addr
	addq.l	#4,a0			; move to next address
	move.l	(dsp)+,0(bp,a0.l)	; high and low portions
	popdsp				; clear stack
	tonext				; 910909 jax

	lfa	2		; dpANS-2 CORE
	nfa	2,'2',<'*'>	; ( x1 -- x2)
twostar	lsl.l	#1,tos
	tonext			; 910717 jax

	lfa	2		; dpANS-2 CORE
	nfa	2,'2',<'/'>	; ( x1 -- x2)
twosl	asr.l	#1,tos
	tonext			; 910909 jax

	lfa	2		; dpANS-2 CORE
	nfa	2,'2','@'	; ( a-addr -- x1 x2)
twofet	walin	tos			; longword fetch, no gurus!
	move.l	tos,a0			; move address to address register
	move.l	0(bp,a0.l),tos		; deref a 2variable address
	addq.l	#4,a0			; lo order word now
	move.l	0(bp,a0.l),-(dsp)	; hi word was stored first in memory
	tonext			; 910716 jax

	lfa	2		; dpANS-2 CORE
	nfa	5,'2DRO','P'	; ( x1 x2 --)
twodrop	addq.l	#4,dsp
	popdsp
	tonext			; 910716 jax

	lfa	2		; dpANS-2 CORE
	nfa	4,'2DU','P'	; ( x1 x2 -- x1 x2 x1 x2)
twodup	move.l	tos,-(dsp)
	move.l	4(dsp),-(dsp)
	tonext			; 910716 jax

	lfa	2		; dpANS-2 CORE
	nfa	5,'2OVE','R'	; ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2)
twoove	pshdsp
	move.l	12(dsp),-(dsp)
	move.l	12(dsp),tos
	tonext			; 910909 jax

	lfa	2		; dpANS-2 CORE
	nfa	5,'2SWA','P'	; ( x1 x2 x3 x4 --- x3 x4 x1 x2)
twoswa	move.l	(dsp)+,d0	; w3
	move.l	(dsp)+,d1	; w2
	move.l	(dsp),d2	; w1
	move.l	d0,(dsp)	; w3
	move.l	tos,-(dsp)	; w4
	move.l	d2,-(dsp)	; w1
	move.l	d1,tos		; w2
	tonext			; 910908 jax

linki1	set	(((*-start)>>1)|kernbit)
	dc.l	0
	nfa	8,'MAKENES','T'	; ( --)
makenest		; copy the NEST engine into code space
	move.w	#(_1mknst-_0mknst),d0	; length of code to copy
	move.l	#_0mknst,a0		; KSeg addr to start from
	move.l	dp,a1			; Destination in NSeg
	adda.l	np,a1			; Convert to AbsAddr
	bra.s	2$
1$	move.b	(a0)+,(a1)+	; loop copying code to code segment
2$	dbra.w	d0,1$
	suba.l	np,a1		; convert back to NSeg addr
	move.l	a1,dp		; restore dictionary pointer
	tonext
_0mknst	move.l	ip,-(rp)	; save the instruction pointer,
	lea.l	*+6(pc),ip	; load IP with this word's addr list base addr
	jmp	(np)
_1mknst

	lfa	2		; dpANS-2 D CORE
	nfa	1,':'		; compilation ( "name" -- colon-sys)
colon	nest			; execution ( i*x -- j*x) ( R: -- sys)
	kcomp	creatq
	literal	nonaming
	kcomp	off		; this is not a :NONAME definition
	kcomp	smudge
	kcomp	makenest
	kcomp	depth
	literal	csp
	kcomp	store
	kcomp	rbrack		; set STATE on
	kcomp	unnest		; 910715 jax

	lfa	3		; dpANS-2 C CORE
	nfi	1,';'		; Compilation ( colon-sys --)
semicol	nest			; Execution ( --) R: ( sys --)
	kcomp	chkstat
	kcomp	depth
	literal csp
	kcomp	fetch
	kcomp	noteq
	abortq	"Stack Changed."
	kcomp	parlit
	kcomp	unnest
	kcomp	ctok
	literal	nonaming
	kcomp	fetch		; check if this is a :NONAME def
	compif	_1semic
	literal	nonaming	; it is, turn var OFF
	kcomp	off
	compelse	_2semic
_1semic	kcomp	unsmudge	; it isn't so UNSMUDGE
_2semic	kcomp	lbrack
	kcomp	unnest		; 910714 jax

	lfa	0		; dpANS-2 CORE
	nfa	1,<'<'>		; ( n1 n2 --- flag)
lesst	cmp.l	(dsp)+,tos
	sgt	tos
	ext.w	tos
	ext.l	tos
	tonext			; 910711 jax

	lfa	0		; dpANS-2 CORE
	nfa	2,'<','#'	; ( --)
lsharp	nest			; pictured numeric output descends from PAD
	kcomp	pad		; -- a-addr
	kcomp	hl		; -- a-addr1 a-addr2
	kcomp	store		; --
	kcomp	unnest		; 910711 jax

	lfa	1		; dpANS-2 CORE
	nfa	1,'='		; ( x1 x2 -- flag)
equal	cmp.l	(dsp)+,tos
	seq	tos
	ext.w	tos
	ext.l	tos
	tonext			; 910711 jax

	lfa	2		; dpANS-2 CORE
	nfa	1,'>'		; ( n1 n2 --- flag)
greater	cmp.l	(dsp)+,tos
	slt	tos
	ext.w	tos
	ext.l	tos
	tonext			; 910711 jax

; Can't be used in kernel for dealing with kernel words!!!
	lfa	2		; dpANS-2 CORE
	nfa	5,'>BOD','Y'	; ( xt -- a-addr)
to_body	lsl.l	#1,tos		; all CREATE words are NextSeg words
	move.w	0(np,tos.l),d0	; get first instruction
	andi.w	#$40,d0		; suffices to distinguish CREATE from DOES
	beq.s	1$		; if NZ, it's a DOES word (MOVEA)
	move.l	_1mkdoe-_0mkdoe(np,tos.l),tos	; fetch DOES> data ptr
	tonext
1$	move.l	_1mkcre-_0mkcre(np,tos.l),tos	; fetch CREATE data ptr
	tonext			; 920105 jax

	lfa	2		; dpANS-2 CORE
	nfa	3,'>I','N'	; ( -- a-addr)
toi	docreat	toin		; 910711 jax

	lfa	i0
	nfa	5,'DIGI','T'	; ( char n -- n true | char false )
digit	move.l	(dsp),d0
	cmpi.b	#"a",d0
	blt.s	_1digit
	cmpi.b	#"z",d0
	bgt.s	_1digit
	subi.l	#" ",d0
_1digit	subi.l	#"0",d0
	bpl.s	_2digit
	bra.s	_6digit
_2digit	cmpi.l	#10,d0
	blt.s	_4digit
	subq.l	#7,d0
	cmpi.l	#10,d0
	bcc.s	_4digit
	bra.s	_6digit
_4digit	cmp.l	d0,tos
	bhi.s	_5digit
	bra.s	_6digit
_5digit	move.l	d0,(dsp)
	move.l	#-1,tos
	tonext
_6digit	moveq.l	#0,tos
	tonext

linki2	set	(((*-start)>>1)|kernbit)
	dc.l	0
	nfa	4,'UD*','S'	; ( ud1 n -- ud2)
udstars	nest			; -- ud1 n
	kcomp	dupto_r		; -- ud1 n		R: -- n
	kcomp	swap		; -- ud1l n ud1h	R: -- n
	kcomp	pto_r		; -- ud1l n		R: -- n ud1h
	kcomp	umstar		; -- ud2dl		R: -- n
	kcomp	ptworfr		; -- ud2dl n ud2h	R: --
	kcomp	umstar		; -- ud2dl ud2dh
	kcomp	drop		; -- ud2dl ud2h
	literal	0		; -- ud2dl ud2h 0
	kcomp	swap		; -- ud2dl ud2dh
	kcomp	dplus		; -- ud2
	kcomp	unnest

	lfa	2		; dpANS-2 CORE
	nfa	7,'>NUMBE','R'	; ( ud1 c-addr1 u1 -- ud2 c-addr2 u2)
to_numb	nest
	kcomp	over		; -- ud1 c-addr u1 c-addr1
	kcomp	cfetch		; -- ud1 c-addr u1 char
	literal	"-"		; -- ud1 c-addr u1 char1 char2
	kcomp	equal		; -- ud1 c-addr u1 flag
	kcomp	dup		; -- ud1 c-addr u1 flag flag
	literal	$7FFFFFFF	; hi bit indicates negative
	kcomp	b_or		; -- ud1 c-addr u1 flag mask
	kcomp	kdpl
	kcomp	store		; default is a single number, neg or pos
	compif	_8to_nu		; -- ud1 c-addr u1
	literal	1
	kcomp	slstr		; -- ud1 c-addr' u1'
_8to_nu	kcomp	tuck		; -- ud1 u1 c-addr1 u1
	kcomp	false		; -- ud1 u1 c-addr1 u1 0
	compqdo	_2to_nu		; -- ud1 u1 c-addr1
_0to_nu	kcomp	dup		; -- ud1 u1 c-addr1 c-addr1
	kcomp	cfetch		; -- ud1 u1 c-addr1 char
	kcomp	bas		; -- ud1 u1 c-addr1 char 'base
	kcomp	fetch		; -- ud1 u1 c-addr1 char base
	kcomp	digit		; -- ud1 u1 c-addr1 n t|f
	compif	_1to_nu		; -- ud1 u1 c-addr1 n ,valid digit
	kcomp	negrot		; -- ud1 n u1 c-addr1
	kcomp	ptwotor		; -- ud1 n			R: -- u1 c-addr1
	kcomp	negrot		; -- n ud1			R: -- u1 c-addr1
	kcomp	bas		; -- n ud1 addr			R: -- u1 c-addr1
	kcomp	fetch		; -- n1 ud1 n2			R: -- u1 c-addr1
	kcomp	udstars		; -- n ud1'			R: -- u1 c-addr1
	kcomp	rot		; -- ud1' n			R: -- u1 c-addr1
	kcomp	mplus		; -- ud2			R: -- u1 c-addr1
	kcomp	pr_from		; -- ud2 c-addr1		R: -- u1
	kcomp	onepl		; -- ud2 c-addr2		R: -- u1
	kcomp	pr_from		; -- ud2 c-addr1 u1		R: --
	kcomp	onemi		; -- ud2 c-addr2 u2
	kcomp	swap		; -- ud2 u2 c-addr2
	compelse	_7to_nu	; -- ud1 u1 c-addr1 n ,not valid digit
_1to_nu	literal	"."		; -- ud1 u1 c-addr1 n char 
	kcomp	equal		; -- ud1 u1 c-addr1 flag
	compif	_9to_nu		; -- ud1 u1 c-addr1
	kcomp	over		; -- ud1 u1 c-addr1 u1
	kcomp	onemi		; -- ud1 u1 c-addr1 u1'
	kcomp	kdpl		; -- ud1 u1 c-addr1 u1' a-addr
	kcomp	fetch		; -- ud1 u1 c-addr1 u1' mask
	literal	$80000000	; -- ud1 u1 c-addr1 u1' mask1 mask2
	kcomp	b_and		; -- ud1 u1 c-addr1 u1' mask
	kcomp	b_or		; -- ud1 u1 c-addr1 mask
	kcomp	kdpl
	kcomp	store		; -- ud1 u1 c-addr1
	kcomp	swap		; -- ud1 c-addr1 u1
	literal	1
	kcomp	slstr		; -- ud1' c-addr1' u1'
	kcomp	swap		; -- ud2 u2 c-addr2
	compelse	_7to_nu	; -- ud2 u2 c-addr2
_9to_nu	kcomp	pleave		; -- ud2 u2 c-addr2
_7to_nu	comploop	_0to_nu ; -- ud2 u2 c-addr2
_2to_nu	kcomp	swap		; -- ud2 c-addr2 u2
	kcomp	twoswa		; -- c-addr2 u2 ud2
	kcomp	kdpl
	kcomp	fetch		; -- c-addr2 u2 ud2 mask
	literal	$80000000	; -- c-addr2 u2 ud mask1 mask2
	kcomp	b_and
	kcomp	zerone		; -- c-addr2 u2 ud2 flag
	kcomp	qdnegat		; -- c-addr2 u2 ud2'
	kcomp	twoswa		; -- ud2 c-addr2 u2
	kcomp	unnest		; 910717 jax

	lfa	i0
	nfa	4,'(>R',')'	; ( x --) ( R: -- x)
pto_r	pop	-(rp)
	tonext

	lfa	2		; dpANS-2 C CORE
	nfi	2,'>','R'	; ( x --) ( R: -- x)
to_r	nest
	kcomp	chkstat
	kcomp	parlit
	kcomp	pto_r
	kcomp	ctok
	kcomp	unnest		; 910711 jax

	lfa	3		; dpANS-2 CORE
	nfa	4,'?DU','P'	; ( x -- x x) OR ( 0 - 0)
qdup	tst.l	tos
	beq.s	_1qdup
	pshdsp
_1qdup	tonext			; 910711 jax

	lfa	0		; dpANS-2 CORE
	nfa	1,'@'		; ( a-addr -- x)
fetch	walin	tos		; longword fetch, no gurus!
	fet			; macro from jax4th.i
	tonext			; 910711 jax

***!!!*** All this ABORT stuff should probably be re-written, but at least
***!!!*** it currently seems to work.

	lfa	i0
	nfa	'(ABORT"',')'	; ( flag --)
pabortq	nest		; How to ABORT" from local code
	kcomp	r_fet	; get address of cell containing ptr to DSeg string
	kcomp	abstod	; convert to data seg address
	kcomp	fetch	; address of DSeg string
	kcomp	count	; -- flag addr ct
	kcomp	rot	; -- addr ct flag
	kcomp	qerror	; --
	kcomp	pr_from	; get ip
	kcomp	cellpl	; increment past DSeg string address
	kcomp	pto_r	; restore
	kcomp	unnest	; onwards

	lfa	1		; dpANS-2 CORE
	nfa	5,'ABOR','T'	; (i*x --) ( R: j*x --)
abort	nest
	kcomp	true
	abortq	" "		; 910711 jax

	lfa	1		; dpANS-2 C CORE
	nfi	6,'ABORT','"'	; Compilation: ( "ccc<">" --)
kabortq	nest			; Execution: (i*w --) ( R: j*w --)
	kcomp	chkstat
	kcomp	parlit
	kcomp	pabortq
	kcomp	ctok
	kcomp	commaq
	kcomp	unnest		; 910711 jax

	lfa	1		; dpANS-2 CORE
	nfa	3,'AB','S'	; ( n1 -- +n2)
abs	tst.l	tos
	bge.s	1$
	neg.l	tos
1$	tonext			; 910711 jax

	lfa	1		; dpANS-2 CORE
	nfa 	6,'ACCEP','T'	; ( c-addr +n -- +n2)
accept  nest
	kcomp	dup	; count to accept
	kcomp	zerole	; invalid operand?
	abortq	"Negative argument to ACCEPT"	; yes, abort w/message
	literal	0	; initial count of ACCEPTed characters
	kcomp	negrot	; place below loop indices on stack
	kcomp	bounds	; set up indices into destination address
	compdo	_1accep	; DO ...
_0accep	kcomp	key	; get a key
	kcomp	dup	; dup to test
	literal $0d	; is it a CR ?
	kcomp	equal	; test
	kcomp	over	; test again
	literal	$0a	; is it an LF ?
	kcomp	equal	; test
	kcomp	b_or	; either one exits
	compif	_2accep	; IF ...
	kcomp	drop	; drop the key
	kcomp	pleave	; leave with the current count on stack
	compelse _3accep	; ELSE ...
			; this resolution actually unnecessary due to LEAVE
_2accep	kcomp	dodoi	; address to store ACCEPTed char to
	kcomp	cstore	; store it
	kcomp	onepl	; increment count of ACCEPTed chars
_3accep	comploop	_0accep	; ... THEN LOOP
_1accep	kcomp	unnest	; 910711 jax

	lfa	1		; dpANS-2 CORE
	nfa	5,'ALIG','N'	; ( --)
align	wapalin			; word-align the data segment
	tonext			; 910711 jax

	lfa	1		; dpANS-2 CORE
	nfa	7,'ALIGNE','D'	; ( addr -- a-addr)
aligned	walin	tos		; return address word-aligned
	tonext			; 910711 jax

	lfa	1		; dpANS-2 CORE
	nfa	5,'ALLO','T'	; ( n --)
allot	add.l	tos,ap		; allot data space
	popdsp
	tonext			; 910711 jax

	lfa	1		; dpANS-2 CORE
	nfa	3,'AN','D'	; ( x1 x2 -- x3)
b_and	and.l	(dsp)+,tos	; bitwise AND
	tonext			; 910711 jax

	lfa	2		; dpANS-2 CORE
	nfa	4,'BAS','E'	; ( -- a-addr)
bas	docreat	base		; holds number base for conversions
				; 910909 jax

	lfa	2		; dpANS-2 C CORE
	nfi	5,'BEGI','N'	; Compilation: ( -- dest)
kbegin	nest			; Execution: ( --)
	kcomp	chkstat		; abort if interpreting
	kcomp	dpfet		; leave user dict pointer on stack
*	literal	beginflag	; and a compiler flag
	kcomp	unnest		; review compiler security flag issues
				; 910705 jax

	lfa	2		; dpANS-2 CORE
	nfa	2,'B','L'	; ( -- char)
bl	doconst	$20		; ASCII blank space
				; 910909 jax

	lfa	2		; dpANS-2 CORE
	nfa	3,'BL','K'	; ( -- a-addr)
kblk	docreat	blk		; 910909 jax

	lfa	3		; dpANS-2 CORE
	nfa	2,'C',<'!'>	; ( char c-addr --)
cstore	move.l  (dsp)+,d0	; pop second on stack
	move.b	d0,0(bp,tos.l)	; store byte data
	popdsp			; drop tos
	tonext			; 910711 jax

	lfa	3		; dpANS-2 CORE
	nfa	2,'C',<','>	; ( char --)
ccomma	move.b	tos,0(bp,ap.l)	; store to dataseg
	addq.l	#1,ap		; post-increment allocation pointer
	popdsp			; drop TOS

	lfa	3		; dpANS-2 CORE
	nfa	2,'C','@'	; ( c-addr -- char)
cfetch	movea.l	tos,a0		; move source to an address register
	moveq.l	#0,tos		; clear tos for byte fetch
	move.b	0(bp,a0.l),tos	; fetch byte data from variable address
	tonext			; 910711 jax

	lfa	3		; dpANS-2 CORE
	nfa	5,'CELL','+'	; ( addr1 -- addr2)
cellpl	addq.l	#cellsize,tos
	tonext			; 910711 jax

	lfa	3		; dpANS-2 CORE
	nfa	5,'CELL','S'	; ( n1 -- n2)
cells	lsl.l	#(cellsize/2),tos
	tonext			; 910711 jax

	lfa	3		; dpANS-2 CORE
	nfa	4,'CHA','R'	; ("ccc< >" -- char)
char	nest
	kcomp	bl
	kcomp	word
	kcomp	onepl
	kcomp	cfetch
	kcomp	unnest		; 910711 jax

	lfa	3		; dpANS-2 CORE
	nfa	5,'CHAR','+'	; ( c-addr1 -- c-addr2)
charpl	addq.l	#charsize,tos	; increment by width of char in AUs
	tonext			; 910909 jax

	lfa	3		; dpANS-2 CORE
	nfa	5,'CHAR','S'	; ( n1 -- n2)
chars	tonext			; no conversion necessary
				; 910909 jax

	lfa	i1
	nfa	9,'MAKECONS','T'	; ( --)
makconst		; copy the DOCONST engine into code space
	move.w	#(_1mkcon-_0mkcon),d0	; length of code to copy
	move.l	#_0mkcon,a0		; KSeg addr to start from
	move.l	dp,a1			; Destination in NSeg
	adda.l	np,a1			; Convert to AbsAddr
	bra.s	2$
1$	move.b	(a0)+,(a1)+	; loop copying code to code segment
2$	dbra.w	d0,1$
	suba.l	np,a1		; convert back to NSeg addr
	move.l	a1,dp		; restore dictionary pointer
	tonext
_0mkcon	pshdsp			; push stack
	move.l	*+6(pc),tos	; load TOS with stored literal value
	jmp	(np)
_1mkcon

	lfa	3		; dpANS-2 D CORE
	nfa	8,'CONSTAN','T'	; ( x "name" --)
kconst	nest
	kcomp	creatq
	kcomp	makconst
	kcomp	ctok
	kcomp	unnest		; 910711 jax

;-----------------------------------------------------------------------------;
; Strings compiled by user at run time will be compiled into the DSeg, not    ;
; into the dictionary, so that all the normal data space handling words will  ;
; work on them ... so sometimes there are two sets of engines for handling    ;
; embedded strings, one set for the strings in the DSeg and one set for those ;
; in KSeg.								      ;
;-----------------------------------------------------------------------------;

	lfa	3		; dpANS-2 CORE
	nfa	5,'COUN','T'	; ( c-addr1 -- c-addr2 u)
count	move.l	tos,a0
	moveq.l	#0,tos
	move.b	0(bp,a0.l),tos	; count
	addq.l	#1,a0
	move.l	a0,-(dsp)	; address
	tonext			; 910711 jax

	lfa	3		; dpANS-2 CORE
	nfa	2,'C','R'	; ( --)
cr	nest
	literal	$0a
	kcomp	emit
	kcomp	unnest

	lfa	i2
	nfa	7,'CREATE','"'	; ( --)
creatq	nest
	kcomp	alidic		; align dictionary
	kcomp	align		; align data space
	kcomp	bl		; -- char
	kcomp	word		; -- a-addr
	kcomp	dup		; -- a-addr a-addr
	kcomp	cfetch		; -- a-addr u
	kcomp	zeroeq		; -- a-addr flag
	abortq	"Zero-length name string"	; abort on zero name
	kcomp	qupperc		; get next lexical item
	kcomp	dup		; -- 'word 'word
	kcomp	hash		; -- 'word n  ,get thread number
	kcomp	cells		; -- 'word n
	kcomp	getcurr		; -- 'word n a-addr
	kcomp	plus		; -- 'word 'thread
	kcomp	dup		; -- 'word 'thread 'thread
	kcomp	fetch		; -- 'word 'thread thread
	kcomp	dpfet		; -- 'word 'thread thread dp
	kcomp	mtok		; -- 'word 'thread thread tok
	kcomp	negrot		; -- 'word tok 'thread thread
	kcomp	ctok		; -- 'word tok 'thread
	kcomp	store		; -- 'word
	kcomp	dpfet		; -- 'word dp
	kcomp	mtok		; -- 'word tok
	kcomp	las		; -- 'word tok a-addr
	kcomp	store		; -- 'word   ,store NFA to LAST
	kcomp	count		; -- c-addr u
	literal	maxncount	; -- c-addr u limit-to-name-length
	kcomp	min		; -- c-addr u
	kcomp	dpfet		; -- c-addr u nseg-addr
	kcomp	twodup		; -- c-addr u ns-addr u ns-addr
	kcomp	plus		; -- c-addr u ns-addr ns-addr'
	kcomp	onepl		; to account for the count byte
	kcomp	dpsto		; -- c-addr u ns-addr
	kcomp	codtoz		; -- c-addr u abs-addr
	kcomp	abstod		; -- c-addr u dseg-addr
	kcomp	dup
	kcomp	pto_r		; -- c-addr u dseg-addr		R: -- ds-addr
	kcomp	place		; --				R: -- ds-addr
	kcomp	pr_from		; -- ds-addr
	kcomp	dup
	kcomp	cfetch		; -- ds-addr char
	literal	namebit
	kcomp	b_or		; -- ds-addr masked-char
	kcomp	swap
	kcomp	cstore		; --
	kcomp	dpfet		; -- ns-addr
	kcomp	onemi		; -- ns-addr-of-last-namechar
	kcomp	codtoz
	kcomp	abstod
	kcomp	dup		; -- ds-addr ds-addr
	kcomp	cfetch		; -- ds-addr char
	literal	namebit
	kcomp	b_or		; -- ds-addr masked-char
	kcomp	swap
	kcomp	cstore		; --
	kcomp	alidic
	kcomp	unnest

	lfa	i1
	nfa	12,'MAKECREAT','E'	; ( --)
makcreat		; copy the DOCREAT engine into code space
	move.w	#(_1mkcre-_0mkcre),d0	; length of code to copy
	move.l	#_0mkcre,a0		; KSeg addr to start from
	move.l	dp,a1			; Destination in NSeg
	adda.l	np,a1			; Convert to AbsAddr
	bra.s	2$
1$	move.b	(a0)+,(a1)+	; loop copying code to code segment
2$	dbra.w	d0,1$
	suba.l	np,a1		; convert back to NSeg addr
	move.l	a1,dp		; restore dictionary pointer
	tonext
_0mkcre	move.l	tos,-(dsp)	; push stack
	move.l	*+6(pc),tos	; load TOS with this word's data ptr
	jmp	(np)
_1mkcre

	lfa	3		; dpANS-2 D CORE
	nfa	6,'CREAT','E'	; ( "<name>" --)
create	nest
	kcomp	creatq		; create dict header, align dict+data space
	kcomp	makcreat	; compile DODATA engine
	kcomp	here
	kcomp	ctok		; compile data pointer
	kcomp	unnest		; 910711 jax

	lfa	0		; dpANS-2 CORE
	nfa	7,'DECIMA','L'	; ( --)
decimal	nest			; set BASE to 10 decimal
	literal	$0a
	kcomp	bas
	kcomp	store
	kcomp	unnest		; 910711 jax

	lfa	0		; dpANS-2 CORE
	nfa	5,'DEPT','H'	; ( -- +n)
depth	move.l	dsp,d1		; get current data stack ptr
	pshdsp			; save TOS
	move.l	#spzero,a0	; get data seg addr of SP0
	move.l	0(a0,bp.l),tos	; fetch contents to d1
	sub.l	bp,d1		; convert DSP to DSEg addr
	sub.l	d1,tos		; sub from original-DSP-as-DSeg addr
	asr.l	#2,tos		; convert to CELLs
	tonext			; 910711 jax

;-----------------------------------------------------------------------;
; To prevent accidental mis-invocation (hopefully!) of the kernel	;
; control-flow defs instead of the assembler prims, those control-flow	;
; words that may have corresponding asm prims have the high level words	;
; labelled with k---							;
;-----------------------------------------------------------------------;
 
	lfa	0		; dpANS-2 C CORE
	nfi	2,'D','O'	; Compilation: ( -- dodest)
	nest			; Execution: ( n1|u1 n1|u2 --) ( R: -- sys)
	kcomp	parlit	; need a literal to store into local code space
	kcomp	dodo	; the kernel address of the label DODO
	kcomp	ctok	; this is the store to local code space
	kcomp	dpfet	; leave user dict pointer on stack
	kcomp	parlit
	kcomp	noop	; place holder for branch resolve
	kcomp	ctok
	literal	doflag	; and a compiler flag
	kcomp	unnest		; 910711 jax

	lfa	i1
	nfa	8,'MAKEDOE','S'		; ( --)
makdoes			; copy the DOES engine into code space
	move.w	#(_1mkdoe-_0mkdoe),d0	; length of code to copy
	move.l	#_0mkdoe,a0		; KSeg addr to start from
	move.l	dp,a1			; Destination in NSeg
	adda.l	np,a1			; Convert to AbsAddr
	bra.s	2$
1$	move.b	(a0)+,(a1)+	; loop copying code to code segment
2$	dbra.w	d0,1$
	suba.l	np,a1		; convert back to NSeg addr
	move.l	a1,dp		; restore dictionary pointer
	tonext
_0mkdoe	movea.l	#0,a0		; literal 0 overwritten at compile time
	jsr	0(np,a0.l)	; jump leaving 'data-ptr on system stack
_1mkdoe

	lfa	i1
	nfa	9,'MAKEDDOE','S'	; ( --)
makddoes			; copy the DOES engine into code space
	move.w	#(_1mkddoe-_0mkddoe),d0	; length of code to copy
	move.l	#_0mkddoe,a0		; KSeg addr to start from
	move.l	dp,a1			; Destination in NSeg
	adda.l	np,a1			; Convert to AbsAddr
	bra.s	2$
1$	move.b	(a0)+,(a1)+	; loop copying code to code segment
2$	dbra.w	d0,1$
	suba.l	np,a1		; convert back to NSeg addr
	move.l	a1,dp		; restore dictionary pointer
	tonext
_0mkddoe	move.l	(dsp)+,a0	; 'data-prt
	pshdsp
	move.l	(a0),tos	; data address of CREATE/DOES> word
	nest
_1mkddoe

	lfa	i0
	nfa	5,'DOES','Z'	; ( a-addr --)
doesz	nest
	kcomp	las	; -- a-addr1 a-addr2
	kcomp	fetch	; -- a-addr1 a-addr2
	kcomp	travers	; -- a-addr1 tok
	kcomp	ctoktoc	; -- a-addr1 NSeg-addr
	kcomp	dup	; -- a-addr1 NSeg-addr(cfa) NSeg-addr(cfa)
	kcomp	dpsto	: -- a-addr1 NSeg-addr
	literal	_1mkcre-_0mkcre	; -- a-addr1 NSeg-addr n
	kcomp	plus	; -- a-addr1 NSeg-addr' ,addr of data ptr
	kcomp	codtoz	; -- a-addr1 abs-addr
	kcomp	abstod	; -- a-addr1 data-addr
	kcomp	fetch	; -- a-addr1 data-ptr
	kcomp	makdoes	; -- a-addr1 data-ptr
	kcomp	ctok	; -- a-addr1 ,restore data space pointer
	kcomp	dpfet	; -- a-addr1 NSeg-addr
	literal	((_1mkdoe-_0mkdoe)+2)	; back to #0 in the "movea.l #0,a0"
	kcomp	minus	; -- a-addr1 NSeg-addr' ,to be overwritten
	kcomp	codtoz	; -- a-addr1 abs-addr
	kcomp	abstod	; -- a-addr1 a-addr2
	kcomp	store	; --
	kcomp	unnest

	lfa	0		; dpANS-2 C CORE
	nfi	5,'DOES','>'	; Compilation: ( colon-sys1 -- colon-sys2)
doesr	nest			; Execution: ( -- a-addr) ( R: sys --)
	kcomp	dpfet		; name Execution: ( -- a-addr) (R: -- sys2)
	literal	4
	kcomp	cells
	kcomp	plus		; just past what this compiles (to past UNNEST)
	kcomp	parlit
	kcomp	parlit
	kcomp	ctok		; compile (LIT)
	kcomp	ctok		; compile DP of "dodoeser" for DOESZ
	kcomp	parlit
	kcomp	doesz
	kcomp	ctok		; compile does-overwriter
	kcomp	parlit
	kcomp	unnest		; compile an unnest
	kcomp	ctok
	kcomp	makddoes	; write does-catcher preceding runtime code
	kcomp	unnest		; 910714 jax

	lfa	0		; dpANS-2 CORE
	nfa	4,'DRO','P'	; ( x --) 
drop	popdsp
	tonext			; 910713 jax

	lfa	0		; dpANS-2 CORE
	nfa	3,'DU','P'	; ( x -- x x)
dup	pshdsp
	tonext			; 910713 jax

	lfa	1		; dpANS-2 C CORE
	nfi	4,'ELS','E'	; Compilation: ( orig1 -- orig2)
kelse	nest			; Execution: ( --)
*	literal	ifflag		; check for compiler flag
*	kcomp	noteq		; test	; review dpANS-2 Table 5-3
*	abortq	"IFFLAG missing at ELSE"	; abort with error
	kcomp	parlit		; we need the kernel ELSE engine
	kcomp	doelse		; the ELSE engine addr as kernel token
	kcomp	ctok		; compile it at runtime
	kcomp	parlit
	kcomp	noop		; place marker
	kcomp	ctok		; for branch forward
	kcomp	dpfet		; get dictionary pointer
	kcomp	swap		; get resolve address
	kcomp	dpsto		; make it current dictionary pointer
	kcomp	dup		; extra copy of fetched dictionary pointer
	kcomp	mtok		; convert it to local code token
	kcomp	ctok		; resolve the IF
	kcomp	dup		; need extra copy of real current DP	
	kcomp	cell
	kcomp	minus		; this is what THEN has to resolve
	kcomp	swap		; but this is the current DP
	kcomp	dpsto		; restore actual dictionary pointer
*	literal	elseflag	; compiler flag	; no compiler flag in ANS
	kcomp	unnest		; 910713 jax

	lfa	i0
	nfa	6,'(EMIT',')'	; ( char --)
pemit	nest
	kcomp	emitbu
	kcomp	cstore
	kcomp	stdo
	kcomp	fetch
	kcomp	emitbu
	literal	1
	kcomp	doswrit
	kcomp	drop	; maybe save return in an error var?
	kcomp	unnest

	lfa	1		; dpANS-2 CORE
	nfa	4,'EMI','T'	; ( x --)
emit	defer	isemit		; 910713 jax

;-----------------------------------------------------------------------;
; ENVIRONMENT? will be implemented as a private one-thread dictionary.	;
;-----------------------------------------------------------------------;

***!!!*** Expand
	lfa	1			; dpANS-2 CORE
	nfa	12,'ENVIRONMENT','?'	; ( c-addr u -- false | value true)
enviroq	nest
	kcomp	twodrop
	kcomp	false
	kcomp	unnest			; 910909 jax
***!!!***

	lfa	1		; dpANS-2 CORE
	nfa	8,'EVALUAT','E'	; ( i*x c-addr u -- j*x)
evaluat	nest
	kcomp	kblk		; -- a-addr
	kcomp	fetch		; -- n
	kcomp	sourcfi		; -- n a-addr
	kcomp	fetch		; -- n1 n2
	kcomp	ptwotor		; --			R: -- n1 n2
	kcomp	kblk
	kcomp	off
	kcomp	sourcfi
	kcomp	on		; --			R: -- n1 n2
	kcomp	numti		; -- c-addr u addr	R: -- n1 n2
	kcomp	fetch		; -- c-addr u addr	R: -- n1 n2
	kcomp	pto_r		; -- c-addr u		R: -- n1 n2 addr
	kcomp	tib		; -- c-addr u addr
	kcomp	toi		; -- c-addr u addr1 addr2
	kcomp	fetch		; -- c-addr u addr1 addr2'
	kcomp	ptwotor		; -- c-addr u		R: -- n1 n2 a1 a2 a3
	kcomp	toi		; -- c-addr u addr
	kcomp	off		; -- c-addr u
	kcomp	numti		; -- c-addr u addr
	kcomp	store		; -- c-addr
	kcomp	tickti		; -- c-addr addr
	kcomp	store		; --
	kcomp	interp		; --			R: -- n1 n2 a1 a2 a3
	kcomp	ptworfr		; -- @'tib >in		R: -- n1 n2 a1
	kcomp	toi		; -- @'tib @>in '>in
	kcomp	store		; -- @'tib
	kcomp	tickti		; -- @'tib ''tib
	kcomp	store		; --			R: -- n1 n2 a1
	kcomp	pr_from		; -- @#tib		R: -- n1 n2
	kcomp	numti		; -- @#tib '#tib
	kcomp	store		; --
	kcomp	ptworfr		; -- n1 n2		R: --
	kcomp	sourcfi
	kcomp	store
	kcomp	kblk
	kcomp	store		; --
	kcomp	unnest		; 910714 jax

	lfa	1		; dpANS-2 CORE
	nfa	7,'EXECUT','E'	; ( i*x xt -- j*x)
execute	pop	d0		; execute token on TOS
	exetok			; 910714 jax

	lfa	i1
	nfa	6,'(EXIT',')'	; ( --) ( R: sys --)
pexit	rpop	ip	; restore ip to return from nested colon def
	tonext		; jump next

	lfa	1		; dpANS-2 C CORE
	nfa	4,'EXI','T'	; ( --) ( R: sys --)
exit	nest
	kcomp	chkstat		; abort if interpreting
	kcomp	parlit
	kcomp	pexit
	kcomp	ctok
	kcomp	unnest

	lfa	2		; dpANS-2 CORE
	nfa	4,'FIL','L'	; ( c-addr u char ---)
fill	move.l	(dsp)+,d0
	move.l	(dsp)+,a0	; pop addr	
	adda.l	bp,a0		; add data seg base to offset
	bra.s	2$		; start loop
1$	move.b	tos,(a0)+	; copy TOS to destination region
2$	dbra	d0,1$		; iteratively
	popdsp			; clean up stack
	tonext			; 910714 jax

linki3	set	(((*-start)>>1)|kernbit)
	dc.l	0
	nfa	12,'NAME-COMPAR','E'
				; ( b-addr1 u1 name-addr2 u2+$80 -- addr t|f)
ncompar	andi.l	#maxncount,tos	; unmask name header count byte
	move.l	(dsp)+,a0	; dest addr
	move.l	(dsp)+,d0	; count of source string
	move.l	(dsp),a1	; src addr, save for failure return
	adda.l	bp,a0		; this is a data segment access
	adda.l	bp,a1		; likewise
	cmp.l	d0,tos		; count the same?
	beq.s	3$		; they're the same, jump into loop
	moveq.l	#0,tos		; they are not the same
	tonext			; so exit  -- addr false
1$	move.b	(a0)+,d1	; byte from NAME HEADER
	move.b	d1,d2		; copy of same for testing for last char
	andi.b	#namebit,d2	; last char in name header?
	beq.s	2$		; no, continue normally
	moveq.w	#0,tos		; set up for loop exit, it *was* last char
2$	andi.b	#maxnchar,d1	; mask off high bit
	cmp.b	(a1)+,d1	; do byte comparison
3$	dbne	tos,1$		; exit if different
	seq.b	tos		; success?
	ext.w	tos
	ext.l	tos		; well-formed flag
	move.l	a0,d0		; copy of CFA-abs-addr
	andi.l	#1,d0		; odd address?
***!!!*** LWORD alignement for 68030 versions? See NFA NFI macros in JAX4TH.I
	adda.l	d0,a0		; word-align address if necessary
	move.l	a0,(dsp)	; CFA-abs-addr, if success
	tonext			; onwards!

	lfa	i1
	nfa	10,'?IMMEDIAT','E'	; ( link-dataaddr -- 1|-1)
qimmed	move.l	tos,a0		; link data address to A0 to fetch count byte
	move.b	4(bp,a0.l),tos	; get count byte
	andi.b	#immedbit,tos	; AND with $40 to see if immediate
	beq.s	1$
	moveq.l	#1,tos		; indicate an IMMEDIATE word
	tonext
1$	moveq.l	#-1,tos		; indicate a non-IMMEDIATE word
	tonext

	lfa	i1
	nfa	10,'?IN-KERNE','L'	; ( cfa link-tok -- exetok link-tok)
qinkern	move.l	tos,d0		; copy of link tok
	move.l	(dsp),d1	; cfa-abs-addr
	lsl.l	#1,d0		; carry set if link tok was kernel link
	bcc.s	1$		; branch if it was a local link
	sub.l	cp,d1		; subtract CODE ptr from abs addr
	lsr.l	#1,d1		; shift into a token
	ori.l	#kernbit,d1	; add the KERNEL bit
	move.l	d1,(dsp)	; restore to data stack
	tonext
1$	sub.l	np,d1		; subtract NEXT ptr from abs addr
	lsr.l	#1,d1		; shift into token
	move.l	d1,(dsp)	; restore to stack
	tonext

***!!!***; This should be examined to see if all this token/addr thrashing
***!!!***; and data/return stack thrashing is really necessary.
; Find a dictionary entry's execution token in a given thread

	lfa	i0
	nfa	6,'(FIND',')'	; ( thread c-addr -- [c-addr 0]|[w 1]|[w -1])
pfind	nest
	kcomp	count		; -- thread addr ct
	kcomp	twodup		; -- thread addr ct addr ct
	kcomp	ptwotor		; -- thread addr ct		R: -- adr ct
	kcomp	rot		; -- addr ct thread		R: -- adr ct
_1pfind	kcomp	fetch		; -- addr ct link-tok		R: -- adr ct
	kcomp	dup		; -- addr ct link-tok link-tok	R: -- adr ct
	kcomp	pto_r		; -- addr ct link-tok		R: -- a c lt
	kcomp	ltodat		; -- addr ct link-addr		R: -- a c lt
	kcomp	ltonam		; -- addr ct name-addr		R: -- a c lt
	kcomp	count		; -- addr ct name-addr ct	R: -- a c lt
	kcomp	ncompar		; -- cfa t|f			R: -- a c lt
	compif	_2pfind		; -- cfa , IF			R: -- a c lt
	kcomp	pr_from		; -- cfa link-tok		R: -- a c
	kcomp	qinkern		; -- tok link-tok		R: -- a c
	kcomp	ltodat		; -- tok link-addr		R: -- a c
	kcomp	qimmed		; -- tok 1|-1			R: -- a c
	kcomp	ptworfr		; -- tok 1|-1 n n		R: --
	kcomp	twodrop		; -- tok 1|-1
	kcomp	pexit		; -- tok 1|-1 , quick getaway
_2pfind				; -- cfa , THEN			R: -- a c lt
	kcomp	drop		; --				R: -- a c lt
	kcomp	pr_from		; -- link-tok			R: -- a c
	kcomp	ltodat		; -- link-addr			R: -- a c
	kcomp	dup		; -- link-addr l-a		R: -- a c
	kcomp	fetch		; -- l-a link-tok|0		R: -- a c
	compif	_3pfind		; -- l-a, IF a valid link	R: -- a c
	kcomp	ptworfr		; -- l-a a c			R: --
	kcomp	twodup		; -- l-a a c a c
	kcomp	ptwotor		; -- l-a a c			R: -- a c
	kcomp	rot		; -- a c l-a			R: -- a c
	compelse	_1pfind	; -- a c l-a ,AGAIN		R: -- a c
_3pfind				; -- l-a ,no more links		R: -- a c
	kcomp	drop		; --				R: -- a c
	kcomp	ptworfr		; -- addr ct			R: --
	kcomp	drop		; -- addr
	kcomp	onemi		; -- c-addr
	kcomp	false		; -- c-addr 0
	kcomp	unnest		; -- c-addr 0

	lfa	2		; dpANS-2 CORE
	nfa	4,'FIN','D'	; ( c-addr -- c-addr 0 | xt 1 | xt -1 )
find	nest			; -- $addr
	kcomp	dup		; -- $addr
	kcomp	cfetch		; -- $addr ct
	compif	_4find		; IF the count is non-zero
	kcomp	context		; -- $addr addr
	kcomp	cell		; -- $addr addr n
	kcomp	minus		; back up to one cell before CONTEXT
	kcomp	swap		; ptr-to-vocptr $addr
	kcomp	false		; ptr-to-vocptr $addr 0
	kcomp	false		; ptr-to-vocptr $addr 0 0
	kcomp	numvoc		; number of vocabularies in search order
	literal	0
	compdo	_3find		; loop until success or run out of search order
_0find				; ptr-to-vocptr $addr 0 0
	kcomp	twodrop		; ptr-to-vocptr $addr
	kcomp	cell
	kcomp	underpl		; -- ptv $addr
	kcomp	over		; -- ptr-to-vocptr $addr ptr-to-vocptr
	kcomp	fetch		; -- ptv $addr voc|0
	kcomp	qdup		; we may have reached end of search order
	compif	_1find		; -- ptv $addr voc ,valid vocabulary pointer
	kcomp	over
	kcomp	dup		; -- ptv $addr voc $addr $addr
	kcomp	hash		; -- ptv $a1 voc $a1 thread#
	kcomp	cells
	kcomp	underpl		; -- ptv $a1 voc-thread-baseaddr $a1
	kcomp	pfind		; -- ptv $a1 [[ addr 0 ]|[ exetok [ -1|1 ]]]
	compelse	_2find	; NULL in CONTEXT at this entry
_1find				; -- ptv $addr ,invalid voc ptr, end of order
	kcomp	nip		; -- $addr
	kcomp	false		; -- $addr 0
	kcomp	pkunloo		; -- $addr 0
	kcomp	pexit		; -- c-addr 0
_2find				; -- ptv $addr n1 n2
	kcomp	dup		; -- ptv $a1 w flag1 flag1
	kcomp	pqleave		; -- ptv $a1 w flag1
	comploop	_0find
_3find				; -- ptv $a1 w flag1
	kcomp	rot
	kcomp	drop		; -- ptv w flag
	kcomp	rot
	kcomp	drop		; -- w flag
	kcomp	pexit		; -- w flag
_4find				; -- $addr the string was null
	kcomp	kendq		; var that indicates end of input
	kcomp	on		; set
	kcomp	false		; -- c-addr 0
	kcomp	unnest		; 910909 jax

	lfa	2		; dpANS-2 CORE
	nfa	6,'FM/MO','D'	; ( d1 n1 -- n2 n3)
fmslmod	nest
	kcomp	qdup		; -- d1 n1 n1|-
	compif	_2fmslm		; -- d1 n1
	kcomp	dup		; -- d1 n1 n1
	kcomp	pto_r		; -- d1 n1		R: -- n1
	kcomp	twodup		; -- d1 n1 d1h n1	R: -- n1
	kcomp	b_xor		; -- d1 n1 sign		R: -- n1
	kcomp	pto_r		; -- d1 n1		R: -- n1 sign
	kcomp	pto_r		; -- d1			R: -- n1 sign n1
	kcomp	dabs		; -- _d1_		R: -- n1 sign n1
	kcomp	r_fet		; -- _d1_ n1		R: -- n1 sign n1
	kcomp	abs		; -- _d1_ _n1_		R: -- n1 sign n1
	kcomp	umslmod		; -- r q		R: -- n1 sign n1
	kcomp	swap		; -- q r		R: -- n1 sign n1
	kcomp	pr_from		; -- q r n1		R: -- n1 sign
	kcomp	zerolt		; -- q r flag		R: -- n1 sign
	compif	_0fmslm		; -- q r		R: -- n1 sign
	kcomp	negate		; -- q r		R: -- n1 sign
_0fmslm	kcomp	swap		; -- r q		R: -- n1 sign
	kcomp	pr_from		; -- r q sign		R: -- n1
	kcomp	zerolt		; -- r q flag		R: -- n1
	compif	_1fmslm		; -- r q		R: -- n1
	kcomp	negate		; -- r q		R: -- n1
	kcomp	over		; -- r q r		R: -- n1
	compif	_1fmslm		; -- r q flag		R: -- n1
	kcomp	onemi		; -- r q		R: -- n1
	kcomp	r_fet		; -- r q n1		R: --
	kcomp	rot		; -- q n1 r
	kcomp	minus		; -- q r
	kcomp	swap		; -- r q
_1fmslm	kcomp	pr_from		; -- r q n1		R: --
	kcomp	drop		; -- r q
	kcomp	pexit		: -- r q
_2fmslm	kcomp	twodrop		; --
	kcomp	true
	kcomp	true		; -- -1 -1  ,return for division by zero
	kcomp	unnest		; 910909 jax

	lfa	0		; dpANS-2 CORE
	nfa	4,'HER','E'	; ( -- addr)
here	datp			; return next available location in dataseg
	tonext			; 910714 jax

	lfa	0		; dpANS-2 CORE
	nfa	4,'HOL','D'	; ( char -- )
hold	nest
	kcomp	pad		; -- c-addr
	kcomp	hl
	kcomp	fetch		; -- c-addr1 c-addr2
	kcomp	minus
	literal	$80		; -- n1 n2
	kcomp	lesst		; -- flag  ,is numeric output string full?
	compif	_1hold		; --       ,no it is not, continue
	literal	-1		; -- char -1
	kcomp	hl		; -- char -1 adr
	kcomp	plstore		; -- char
	kcomp	hl		; -- char adr1
	kcomp	fetch		; -- char adr2
	kcomp	cstore		; --
	compelse	_2hold
_1hold	kcomp	true		;          ,yes it is, abort with informatif
	abortq	" Pictured numeric output string full."
_2hold	kcomp	unnest		; 910714 jax

	lfa	1	; dpANS-2 C CORE
	nfi	1,'I',	; ( -- n|u) ( R: sys -- sys)
ki	nest		; colon def, compiles at runtime
	kcomp	chkstat	; abort if interpreting
	kcomp	parlit
	kcomp	dodoi	; compile DO's I
	kcomp	ctok
	kcomp	unnest	; 910909 jax

	lfa	1		; dpANS-2 C CORE
	nfi	2,'I','F'	; Compiling: (  -- orig)
kif	nest			; Execution: ( x --)
	kcomp	chkstat		; abort if interpreting
	kcomp	parlit		; need DOUNTIL engine
	kcomp	doif		; masked as kernel
	kcomp	ctok		; compile it at compile time
	kcomp	dpfet		; leave branchback address on stack
	kcomp	parlit
	kcomp	noop		; to be resolved
	kcomp	ctok
*	literal ifflag		; leave compiler flag ; review dpANS Table 5-3.
	kcomp	unnest		; 910714 jax

	lfa	1			; dpANS-2 CORE
	nfa	9,'IMMEDIAT','E'	; ( --)
kimmed	nest
	kcomp	las		; -- a-addr
	kcomp	fetch		; -- NSeg-NFA-tok
	kcomp	twostar		; -- NSeg-addr
	kcomp	codtoz		; -- abs-addr
	kcomp	abstod		; -- c-addr
	kcomp	dup		; -- c-addr c-addr
	kcomp	cfetch		; -- c-addr countbyte
	literal	immedbit	; -- c-addr countbyte x
	kcomp	b_or		; -- c-addr countbyte'
	kcomp	swap		; -- countbyte' c-addr
	kcomp	cstore		; --
	kcomp	unnest		; 910711 jax

	lfa	1		; dpANS-2 CORE
	nfa	6,'INVER','T'	; ( x1 -- x2)
b_not	not.l	tos
	tonext			; 910714 jax

	lfa	3		; dpANS-2 CORE
	nfa	3,'KE','Y'	; ( -- char)
key	move.l	#stdin,a0	; variable holding console in file handle
	move.l	0(bp,a0.l),d1	; deref into the correct register for the call
	pshdsp			; save TOS
	moveq.l	#0,tos		; clear TOS
	pshdsp			; make room in mem for received char
	move.l	dsp,d2		; address of that room in mem
	addq.l	#3,d2		; aligned to low byte of longword
	moveq.l	#1,d3		; we want one char
	callamy Read,dos	; read one char to 3(DSP)
	popdsp			; discard return (save in some sort of FERROR?)
	popdsp			; pop to TOS
	tonext			; 910714 jax

	lfa	i0
	nfa	7,'(LEAVE',')'	; ( --)
pleave	adda.l	#(2*cellsize),rp
	rpop	ip
	dereftok	ip
	tonext

	lfa	0		; dpANS-2 C CORE
	nfi	5,'LEAV','E'	; ( --) ( R: sys --)
leave	nest
	kcomp	chkstat
	kcomp	parlit
	kcomp	pleave
	kcomp	ctok
	kcomp	unnest		; 910714 jax

	lfa	0		; dpANS-2 C CORE
	nfi	7,'LITERA','L'	; Compilation: ( x --)
klitera	nest			; Execution: ( -- x)
	kcomp	chkstat		; abort if interpreting
	kcomp	parlit		; the next token is actually a numeric literal
	kcomp	parlit		; kernel token for (LIT)
	kcomp	ctok		; compile token to runtime dictionary
	kcomp	ctok		; compile the literal itself
	kcomp	unnest		; 910714 jax

	lfa	0		; dpANS-2 C CORE
	nfi	4,'LOO','P'	; Compilation: ( dodest --)
kloop	nest			; Execution: ( --) ( R: sys1 -- sys2)
	kcomp	chkstat		; abort if interpreting
	literal	doflag		; THEN check for DOFLAG
	kcomp	noteq		; test
	abortq	"DOFLAG missing at LOOP"	; abort with error
	kcomp	parlit		; we need the kernel LOOP engine
	kcomp	doloop		; LOOP engine addr as kernel token
	kcomp	ctok		; compile it at runtime
	kcomp	dup		; dup resolve address
	kcomp	cellpl		; add a cell to it to reach branchback address
	kcomp	mtok		; convert address to a local code token
	kcomp	ctok		; compile it at runtime
	kcomp	dpfet		; -- resolve-NSeg-addr leave-addr
	kcomp	mtok		; convert LEAVE addr to token
	kcomp	swap		; -- leave-token resolve-NSeg-addr
	kcomp	codtoz
	kcomp	abstod		; -- leave-token resolve-DSeg-addr
	kcomp	store		; --
	kcomp	unnest		; 910714 jax

	lfa	1		; dpANS-2 CORE
	nfa	2,'M',<'*'>	; ( n1 n2 -- d)
mstar	nest
	kcomp	twodup
	kcomp	b_xor		; bit 31 set if only one operand negative
	kcomp	pto_r		; save
	kcomp	abs
	kcomp	swap
	kcomp	abs
	kcomp	umstar
	kcomp	pr_from		; get back "negativizer"
	kcomp	zerolt		; bit 31 set?
	kcomp	qdnegat		; if so, negate product
	kcomp	unnest		; 910909 jax

	lfa	1		; dpANS-2 CORE
	nfa	3,'MA','X'	; ( n1 n2 -- n3)
max	cmp.l	(dsp),tos
	bge.s	1$
	popdsp
	bra.s	2$
1$	move.l	(dsp)+,d0
2$	tonext			; 910714 jax

	lfa	1		; dpANS-2 CORE
	nfa	3,'MI','N'	; ( n1 n2 -- n3)
min	cmp.l	(dsp),tos
	ble.s	1$
	popdsp
	bra.s	2$
1$	move.l	(dsp)+,d0
2$	tonext			; 910714 jax

	lfa	1		; dpANS-2 CORE
	nfa	3,'MO','D'	; ( n1 n2 -- n3)
mod	nest
	kcomp	slmod
	kcomp	drop
	kcomp	unnest		; 910909 jax

	lfa	1		; dpANS-2 CORE
	nfa	4,'MOV','E'	; ( addr1 addr2 u ---)
amov	move.l	tos,d0		; copy count for testing
cmov    dmov         		; 910714 jax
        blt.s   cmovr		; DEST > SRC move predecrementing
        bra.s   cmove		; SRC >= DEST, move postincrementing
				; 910909 jax
***!!!*** These below don't belong here, but that neat short branch .. sigh!
* Maybe the answer is just to fill out MOVE with a test for size and
* put the whole shebang inline

	lfa	3		; dpANS-2 STRING
	nfa	6,'CMOVE','>'	; ( c-addr1 c-addr2 u --)
cmovr	tst.l	tos		; non-zero count?
	bne.s	_1cmovr		; yes, proceed
	addq.l	#8,dsp		; no, clear stack and exit
	popdsp
	tonext
_1cmovr	rindex			; as wmovr, but .b
	bra.s	2$		; correct entry to Moto DBcc loop
1$	move.b	-(a0),-(a1)	; move.s doesn't assemble correctly
2$	dbra	tos,1$
	popdsp
	tonext			; 910714 jax

	lfa	3		; dpANS-2 STRING
	nfa	5,'CMOV','E'	; ( c-addr1 c-addr2 u --)
cmove	tst.l	tos		; non-zero count?
	bne.s	_1cmove		; yes, proceed
	addq.l	#8,dsp		; no, clear stack and exit
	popdsp
	tonext
_1cmove	lindex			; as wmove, but .b
	bra.s	2$		; correct entry to Moto DBcc loop
1$	move.b	(a0)+,(a1)+	
2$	dbra	tos,1$
	popdsp
	tonext			; 910714 jax

	lfa	2		; dpANS-2 CORE
	nfa	6,'NEGAT','E'	; ( n1 -- n2)
negate	neg.l	tos
	tonext			; 910714 jax

	lfa	3		; dpANS-2 CORE
	nfa	2,'O','R'	; ( x1 x2 -- x3)
b_or	or.l	(dsp)+,tos	; bitwise OR
	tonext			; 910714 jax

	lfa	3		; dpANS-2 CORE
	nfa	4,'OVE','R'	; ( x1 x2 --- x1 x2 x1)
over	pshdsp
	move.l	4(dsp),tos
	tonext			; 910714 jax

	lfa	0		; dpANS-2 C CORE
	nfi	8,'POSTPON','E'	; Compilation: ( "name" --)
postpon	nest			; Execution: ( --)
	kcomp	bl
	kcomp	word		; get next lexical item
	kcomp	qupperc		; convert to upper
	kcomp	find		; FIND in dictionary
	kcomp	dup		; dup the immed|not-immed|not-found flag
	compif	_1postp		; if found
	kcomp	zerogt		; is it immediate?
	compif	_2postp		; yes
	kcomp	ctok		; compile it at runtime
	compelse	_3postp
_2postp	kcomp	parlit		; we need (LIT) itself as a literal!
	kcomp	parlit		; here it is to be put on stack at runtime
	kcomp	ctok		; compile (LIT) at runtime
	kcomp	ctok		; compile the found word's token at runtime
	kcomp	parlit		; we need COMPILE-TOKEN as a literal
	kcomp	ctok		; compile COMPILE-TOKEN as literal
	kcomp	ctok		; compile COMPILE-TOKEN at runtime
	compelse	_3postp	; but if word was not found in dictionary
_1postp	kcomp	drop		; extra copy of the FIND flag, ( -- c-addr)
	kcomp	count		; get count of failed string
	kcomp	type		; type she out
	kcomp	space		; with a space
	kcomp	true		; flag for ABORT"
	abortq	"was not found by POSTPONE."	; abort with informatif
_3postp	kcomp	unnest		; 910909 jax

	lfa	1		; dpANS-2 CORE
	nfa	4,'QUI','T'	; ( --) ( R: i*x --)
quit	nest
	kcomp	kblk		; turn off BLK and return to console input
	kcomp	off
	kcomp	sourcfi		; turn of SOURCE-FILE for console input
	kcomp	off
	kcomp	numti		; indicate that input stream is empty
	kcomp	off
	kcomp	toi		; indicate that input stream is unparsed
	kcomp	off
	kcomp	stat		; set STATE to interpret
	kcomp	off
_1quit				; this is a "begin"
	kcomp	status		; ye olde CR each Forth QUIT
	kcomp	rpzer		; zero the return stack
	kcomp	fetch
	kcomp	rpsto		; init the RP stack
	kcomp	kendq
	kcomp	off		; reset end-of-input var
	kcomp	query		; get a line of input
	kcomp	interp		; execute it
	kcomp	stat		; check STATE
	kcomp	fetch
	kcomp	b_not
	compif	_2quit
	dotq	"ok "		; say "ok " if interpreting
_2quit  compelse	_1quit	; and this is an "Again"
				; 910909 jax

	lfa	i0
	nfa	4,'(R>',')'	; ( -- x)
pr_from	push	(rp)+
	tonext

	lfa	2		; dpANS-2 C CORE
	nfi	2,'R','>'	; ( -- x) ( R: x --)
r_from	nest
	kcomp	chkstat
	kcomp	parlit
	kcomp	pr_from
	kcomp	ctok
	kcomp	unnest		; 910714 jax

	lfa	2		; dpANS-2 C CORE
	nfa	2,'R','@'	; ( -- x) ( R: x -- x)
r_fet	push	(rp)
	tonext			; 910714 jax

;-----------------------------------------------------------------------;
; Handling RECURSE by using LAST only works because the BASIS		;
; specifically excludes nested compilation 4.0190 "current definition"	;
;-----------------------------------------------------------------------;

	lfa	2		; dpANS-2 C CORE
	nfi	7,'RECURS','E'	; ( --)
recurse	nest
	kcomp	las		; variable, holds latest name token
	kcomp	fetch		; latest name token
	kcomp	travers		; to code token
	kcomp	ctok		; compile at runtime
	kcomp	unnest		; 910714 jax

	lfa	2		; dpANS-2 C CORE
	nfi	6,'REPEA','T'	; Compilation: ( orig dest --)
krepeat	nest			; Execution: ( --)
	kcomp	chkstat		; abort if interpreting
*	literal	whileflag	; check for compiler flag
*	kcomp	noteq		; test	; no compiler security flag in ANS
*	abortq	"WHILEFLAG missing at REPEAT"	; abort with error
	kcomp	dpfet		; - a1 a2 dp  ,get dictionary pointer
	kcomp	swap		; - a1 dp a2  ,get resolve address
	kcomp	dpsto		; - a1 dp  ,make it current dictionary pointer
	kcomp	dup		; - a1 dp dp  ,extra copy of dictionary pointer
	kcomp	cellpl		; increment it past REPEAT
	kcomp	cellpl		; - a1 dp dp' , increment past branchback
	kcomp	mtok		; convert it to local code token
	kcomp	ctok		; - a1 dp resolve the WHILE
	kcomp	dpsto		; - a1 restore actual dictionary pointer
	kcomp	parlit		; we need kernel DOELSE engine
	kcomp	doelse		; the ELSE engine addr as kernel token
	kcomp	ctok		; compile it at runtime, it works for REPEAT
	kcomp	mtok		; convert BEGIN address to a local code token
	kcomp	ctok		; compile it at runtime
	kcomp	unnest		; 910705 jax

	lfa	2		; dpANS-2 CORE
	nfa	3,'RO','T'	; ( x1 x2 x3 --- x2 x3 x1)
rot	move.l	4(dsp),d0
	move.l	(dsp)+,(dsp)
	push	d0
	tonext			; 910714 jax

	lfa	i0
	nfa	3,'(S"',')'	; ( -- c-addr u) (R: a-addr -- addr<-addr+u)
psquote	move.l	(ip)+,a0	; IP was pointing at cell containing DSeg addr
	pshdsp			; prepare stack
	moveq.l	#0,tos		; clear TOS
	move.b	0(bp,a0.l),tos	; count of string
	addq.l	#1,a0		; inc past count byte
	move.l	a0,-(dsp)	; Data Seg addr
	tonext

	lfa	i0
	nfa	2,',','"'	; ( "ccc<">" --)
commaq	nest
	literal	$22		; ascii "
	kcomp	parse		; look for delimiting doublequote
	kcomp	here		; get current data space pointer
	kcomp	dup		; save a copy
	kcomp	ctok		; compile one
	kcomp	over		; save copy of count
	kcomp	pto_r		; on the ret stack
	kcomp	place		; move string into data space
	kcomp	pr_from		; get count back
	kcomp	onepl		; add byte occupied by count
	kcomp	allot		; allot that space the string used up
	kcomp	align		; align data space
	kcomp	unnest

	lfa	3		; dpANS-2 C CORE
				; dpANS-2 FILE
	nfi	2,'S','"'	; Compilation: ( "ccc<">" --)
squote	nest			; Execution: ( -- c-addr u)
	kcomp	stat
	kcomp	fetch
	compif	_1squo
	kcomp	parlit		; need kernel address of (S")
	kcomp	psquote		; as a literal
	kcomp	ctok		; to compile at run time
	kcomp	commaq		; compile string to Data Seg
	kcomp	unnest
_1squo	literal	'"'		; -- char
	kcomp	parse		; -- c-addr u
	literal	sqbuff		; -- c-addr u a-addr
	kcomp	place		; --
	literal	sqbuff		; -- a-addr
	kcomp	count		; c-addr u
	kcomp	unnest		; 910911 jax

	lfa	3		; dpANS-2 CORE
	nfa	3,'S>','D'	; ( n -- d)
s_to_d	tst.l	tos
	bge.s	1$
	push	#-1
	tonext
1$	pshdsp
	moveq.l	#0,tos
	tonext			; 910718 jax

	lfa	3		; dpANS-2 CORE
	nfa	5,'SHIF','T'	; ( x1 n -- x2)
shift	move.l	(dsp)+,d0
	tst.l	tos		; shift count positive or negative?
	blt.s	1$		; negative, branch
	lsl.l	tos,d0		; positive, shift left
	move.l	d0,tos
	tonext
1$	neg.l	tos		; abs value of previously negative shift count
	lsr.l	tos,d0		; shift right
	move.l	d0,tos
	tonext			; 910714 jax

	lfa	3		; dpANS-2 CORE
	nfa	4,'SIG','N'	; ( n --)
sign	nest
	kcomp	zerolt
	compif	_1sign
	literal	"-"
	kcomp	hold
_1sign	kcomp	unnest		; 910714 jax

	lfa	3		; dpANS-2 CORE
	nfa	6,'SM/RE','M'	; ( d1 n1 -- n2 n3)
smslrem	nest
	kcomp	dup		; -- d1 n1 n1
	kcomp	zeroeq		; -- d1 n1 flag
	compif	_1smslm		; -- d1 n1
	kcomp	drop
	kcomp	twodrop		; --
	literal	-1
	literal	-1		; -1 -1
	kcomp	unnest
_1smslm	kcomp	over
	kcomp	over		; -- d1 n1 d1h n1
	kcomp	b_xor		; -- d1 n1 mask
	kcomp	pto_r		; -- d1 n1		R: -- mask
	kcomp	abs		; -- d1 n1		R: -- mask
	kcomp	pto_r		; -- d1			R: -- mask n1
	kcomp	dabs		; -- d1			R: -- mask n1
	kcomp	pr_from		; -- d1 n1		R: -- mask
	kcomp	umslmod		; -- r q		R: -- mask
	kcomp	pr_from		; -- r q mask		R: --
	kcomp	zerolt		; -- r q flag
	compif	_2smslm		; -- r q
	kcomp	negate		; -- r q
_2smslm	kcomp	unnest		; -- r q
				; 910909 jax

	lfa	3		; dpANS-2 CORE
	nfa	5,'SPAC','E'	; ( --)
space	nest
	kcomp	bl
	kcomp	emit
	kcomp	unnest		; 910714 jax

	lfa	3		; dpANS-2 CORE
	nfa	6,'SPACE','S'	; ( n --)
spaces	nest
	literal	0
	compqdo	_1space
_0space	kcomp	bl
	kcomp	emit
	comploop	_0space
_1space	kcomp	unnest		; 910714 jax

	lfa	3		; dpANS-2 CORE
	nfa	5,'STAT','E'	; ( -- a-addr)
stat	docreat	state		; 910714 jax

	lfa	3		; dpANS-2 CORE
	nfa	4,'SWA','P'	; ( x1 x2 --- x2 x1)
swap	move.l	tos,d0
	move.l	(dsp),tos
	move.l	d0,(dsp)
	tonext			; 910714 jax

	lfa	0		; dpANS-2 C CORE
	nfi	4,'THE','N'	; Compilation: ( orig --)
kthen	nest			; Execution: ( --)
*	kcomp	chkstat		; abort if interpreting
*	literal	elseflag	; compiler flag
*	kcomp	over		; flag on stack
*	kcomp	noteq		; is it the else flag?
*	kcomp	swap		; try again
*	literal ifflag		; maybe it's the if flag
*	kcomp	noteq		; maybe not
*	kcomp	b_and		; neither? ; review dpANS-2 Table 5-3.
*	abortq	"FLAG missing at THEN"	; error message
	kcomp	dpfet		; get current dict pointer
	kcomp	swap		; get resolve address
	kcomp	dpsto		; make resolve address the current DP
	kcomp	dup		; second copy of final address
	kcomp	mtok		; convert the exit address to local token
	kcomp	ctok		; compile it during runtime compiler usage
	kcomp	dpsto		; restore current dictionary pointer
	kcomp	unnest		; 910714 jax

	lfa	i3
	nfa	4,'''TI','B'	; ( -- a-adr)
tickti	docreat	ticktib

	lfa	0		; dpANS-2 CORE
	nfa	3,'TI','B'	; ( -- c-addr)
tib	nest
	kcomp	tickti
	kcomp	fetch
	kcomp	unnest		; 910714 jax

	lfa	i0
	nfa	6,'(TYPE',')'	; ( addr ct --)
ptype	nest
	literal	stdout
	kcomp	fetch
	kcomp	negrot
	kcomp	doswrit	; addr must be in data segment!
	kcomp	drop	; maybe save return in an error var?
	kcomp	unnest

	lfa	0		; dpANS-2 CORE
	nfa	4,'TYP','E'	; ( c-addr u --)
type	defer	istype		; 910714 jax

	lfa	1		; dpANS-2 CORE
	nfa	2,'U','.'	; ( u --)
udot	nest
	kcomp	depth		; -- n1 n2
	literal	1
	kcomp	lesst		; -- n1 flag
	abortq	"Stack Underflow"	; --
	literal	0
	kcomp	lsharp
	kcomp	sharps
	kcomp	sharpr
	kcomp	type
	kcomp	space
	kcomp	unnest		; 910714 jax

	lfa	1		; dpANS-2 CORE
	nfa	2,'U',<'<'>	; ( u1 u2 -- flag)
ulesst	cmp.l   (dsp)+,tos
	shi     tos       
	ext.w   tos       
	ext.l   tos       
	tonext			; 910714 jax

	lfa	1		; dpANS-2 CORE
	nfa	3,'UM',<'*'>	; ( u1 u2 --- ud)
umstar	move.l	(dsp),d0	; multiplicand
	move.l	tos,d1		; multiplier
	or.l	d0,d1
	and.l	#$FFFF0000,d1	; test for 16x16
	bne.s	_1umsta		; too big for 16x16
	mulu.w	tos,d0		; 16x16
	move.l	d0,(dsp)	; dl
	moveq.l	#0,tos		; dh
	tonext
_1umsta	move.l	tos,d1		; 32x32
	move.l	tos,d2
	move.l  d0,d3
	swap.w	d2		; d2.w <- multiplier.h 
	swap.w	d3		; d3.w <- multiplicand.h
	mulu.w	d0,tos		; tos := product0
	mulu.w	d2,d0		; d0  := product1
	mulu.w	d3,d1		; d1  := product2
	mulu.w	d3,d2		; d2  := product3
	swap.w	tos		; get high portion low for word adds
	add.w	d0,tos		; low + middle
	moveq.l	#0,d3
	addx.l	d3,d2		; product3+carry
	add.w   d1,tos		; middle + middle
	addx.l  d3,d2		; product3+carry
	swap.w	tos		; dl
	move.l  tos,(dsp)	; move to stack
	clr.w	d0
	clr.w	d1
	swap.w	d0
	swap.w	d1
	add.l	d1,d0		; middle + middle
	add.l	d2,d0		; high + middle
	move.l	d0,tos		; dh
	tonext			; 910714 jax

	lfa	1		; dpANS-2 CORE
	nfa	6,'UM/MO','D'	; ( ud u1 -- u2 u3)
umslmod	tst.l	tos		; test for division by zero
	bne.s	_0umslm		; not by zero, continue below
	moveq.l	#-1,tos		; provide answer of -1 -1 if div/0
	move.l	(dsp)+,d0	; discard udh
	move.l	#-1,(dsp)	; u2
	tonext			; exit
_0umslm	move.l	(dsp)+,d0	; udh
	move.l	(dsp),d1	; udl
	tst.l	d0		; can we do 32/32?
	bne.s	_1umslm		; no, branch to a long divide
	move.l	tos,d3		; copy of u1
	and.l	#$FFFF8000,d3	; is divisor no greater than 15 bits?
	bne.s	_1umslm		; no, branch to a long divide
	move.l	d1,d3		; copy of udl
	and.l	#$FFFF8000,d3	; is udl 15 bits or less?
	bne.s	_1umslm		; no, branch to a long divide
	divu.w	tos,d1		; "safe" 32 x 16, since it's really 15 x 15
	move.l  d1,tos		; copy to TOS
	ext.l   tos		; extend sign of quotient
	swap.l	d1		; get remainder in low word 
	ext.l   d1		; extend sign of remainder
	move.l  d1,(dsp)	; save remainder
	tonext			; done
_1umslm exg	tos,d1		; TOS <- udl D1 <- u1, TOS becomes quotient
	moveq.l #$1f,d2		; count of places to shift
_2umslm	lsl.l   #$1,tos		; "long division"
	roxl.l  #$1,d0		; shifting udl left into udh
	bcs.l   _3umslm		; shift a one out of udh? insert 1 in quotient 
	cmp.l   d1,d0		; shifted zero, compare u1 to udh
	bcs.l	_4umslm		; if u1 > udh, this step is zero, no divide
_3umslm	addq.l	#$1,tos		; insert a 1 in quotient lsb
	sub.l	d1,d0		; binary divide
_4umslm	dbf.w   d2,_2umslm	; branch until done all 32 places
	move.l  d0,(dsp)	; remainder to stack
	tonext			; 910909 jax

	lfa	i0
	nfa	8,'(UNLOOP',')'	; ( --)
pkunloo	adda.l	#(3*cellsize),rp
	tonext

	lfa	1		; dpANS-2 C CORE
	nfi	6,'UNLOO','P'	; ( --) ( R: sys --)
kunloop	nest
	kcomp	chkstat
	kcomp	parlit
	kcomp	pkunloo
	kcomp	ctok
	kcomp	unnest		; 910714 jax

	lfa	1		; dpANS-2 C CORE
	nfi	5,'UNTI','L'	; Compilation: ( dest --)
kuntil	nest			; Execution: ( x --)
	kcomp	chkstat		; abort if interpreting
*	literal	beginflag	; check for compiler flag
*	kcomp	noteq		; test	; review dpANS-2 Table 5-3.
*	abortq	"BEGINFLAG missing at UNTIL"	; abort with error
	kcomp	parlit		; need DOUNTIL engine
	kcomp	dountil		; masked as kernel
	kcomp	ctok		; compile it at compile time
	kcomp	mtok		; make token of branchback address
	kcomp	ctok		; compile it at compile time
	kcomp	unnest		; 910705 jax

	lfa	2		; dpANS-2 D CORE
	nfa	8,'VARIABL','E'	; ( "name" --)
variabl	nest			; name Execution: ( -- a-addr)
	kcomp	create
	literal	cellsize
	kcomp	allot
	kcomp	unnest		; 910714 jax

	lfa	3		; dpANS-2 C CORE
	nfi	5,'WHIL','E'	; Compilation: ( dest -- orig dest)
kwhile	nest			; Execution: ( x --)
	kcomp	chkstat		; abort if interpreting
*	literal	beginflag	; check for compiler flag
*	kcomp	noteq		; test	; review dpANS-2 Table 5-3.
*	abortq	"BEGINFLAG missing at WHILE"	; abort with error
	kcomp	parlit		; DOUNTIL engine works for WHILE
	kcomp	dountil		; the DOUNTIL engine addr as kernel token
	kcomp	ctok		; compile WHILE at Forth compile time
	kcomp	dpfet		; ( -- beginaddr whileaddr)
	kcomp	dup		; advance pointer to leave room
	kcomp	cellpl		; branch forward addr will reside
	kcomp	dpsto		; in dictionary space thus left
*	literal	whileflag	; leave compiler flag
	kcomp	unnest		; 910705 jax

	lfa	3		; dpANS-2 CORE
	nfa	4,'WOR','D'	; ( char "ccc<char>" -- c-addr)
word	nest
	kcomp	pparse		; -- addr ct
	kcomp	tickwor		; -- addr ct dest ,the "word buffer" address
	kcomp	twodup		; -- src ct dest ct dest
	kcomp	plus		; -- src ct dest c-addr
	kcomp	bl		; -- src ct dest c-addr bl
	kcomp	swap		; -- src ct dest bl c-addr
	kcomp	cstore		; -- src ct dest  ,pad string with a blank
	kcomp	place		; --  ,install string
	kcomp	tickwor		; -- c-addr  ,return word buffer addr
	kcomp	unnest		; 910714 jax

	lfa	0		; dpANS-2 CORE
	nfa	3,'XO','R'	; ( x1 x2 -- x3)
b_xor	move.l	(dsp)+,d0	; bitwise XOR
	eor.l	d0,tos		; EOR has weird addressing limitation!
	tonext			; 910714 jax

	lfa	3		; dpANS-2 C CORE
	nfi	1,'['		; ( --)
lbrack	nest
	kcomp	chkstat		; abort if interpreting
	kcomp	stat
	kcomp	off
	kcomp	unnest		; 910714 jax

	lfa	3		; dpANS-2 C CORE
	nfi	3,'[''',']'	; Compilation: ( "name" --)
braktic	nest			; Execution: ( -- xt)
	kcomp	chkstat		; abort if interpreting
	kcomp	tick
	kcomp	parlit
	kcomp	parlit
	kcomp	ctok
	kcomp	ctok
	kcomp	unnest		; 910714 jax

	lfa	3		; dpANS-2 C CORE
	nfi	6,'[CHAR',']'	; Compilation: ("name" --)
brakch	nest			; Execution: ( -- char)
	kcomp	chkstat		; abort if interpreting
	kcomp	bl
	kcomp	word
	kcomp	onepl
	kcomp	cfetch
	kcomp	parlit
	kcomp	parlit
	kcomp	ctok
	kcomp	ctok
	kcomp	unnest		; 910714 jax

	lfa	1		; dpANS-2 CORE
	nfa	1,']'		; ( --)
rbrack	nest
	kcomp	stat
	kcomp	on
	kcomp	unnest		; 910714 jax

;-----------------------------------------------------------------------;
;			    CORE EXT Word Set				;
;-----------------------------------------------------------------------;

***!!!*** ANS ... does this span multiple lines of source file?
	lfa	2		; dpANS-2 CORE EXT
	nfi	2,'.','('	; ( "ccc<)>" --)
dotpar	nest
	literal	")"
	kcomp	word
	kcomp	count
	kcomp	type
	kcomp	unnest		; 910714 jax
***!!!***

	lfa	2		; dpANS-2 CORE EXT
	nfa	2,'.','R'	; ( n1 n2 --)
dotr	nest			; -- n1 n2
	kcomp	depth		; -- n1 n2
	literal	2
	kcomp	lesst		; -- n1 flag
	abortq	"Stack Underflow"	; --
	kcomp	pto_r		; -- n1			R: -- n2
	kcomp	s_to_d		; -- d1			R: -- n2
	kcomp	tuck		; -- d1h d1		R: -- n2
	kcomp	dabs		; -- d1h _d1_		R: -- n2
	kcomp	lsharp		; -- d1h _d1_		R: -- n2
	kcomp	sharps		; -- d1h d2		R: -- n2
	kcomp	rot		; -- d2 d1h		R: -- n2
	kcomp	zerolt		; -- d2 flag		R: -- n2
	compif	_1dotr		; -- d2			R: -- n2
	literal	'-'		; -- d2 char		R: -- n2
	kcomp	hold		; -- d2			R: -- n2
_1dotr	kcomp	sharpr		; -- addr ct		R: -- n2
	kcomp	pr_from		; -- addr ct n2		R: --
	kcomp	twodup		; -- addr ct n2 ct n2
	kcomp	lesst		; -- addr ct n2 flag
	compif	_2dotr		; -- addr ct n2  ,there is extra room in field
	kcomp	over		; -- addr ct n2 ct
	kcomp	minus		; -- addr ct n3
	kcomp	spaces		; -- addr ct
	compelse	_3dotr	; -- addr ct n1  ,no extra room in field
_2dotr	kcomp	drop		; -- addr ct
_3dotr	kcomp	type		; --
	kcomp	unnest		; 910714 jax

	lfa	0		; dpANS-2 CORE EXT
	nfa	3,<'0<'>,'>'	; ( n|u -- flag)
zerone	tst.l	tos
	sne	tos
	ext.w	tos
	ext.l	tos
	tonext			; 910714 jax

	lfa	0		; dpANS-2 CORE EXT
	nfa	2,'0','>'	; ( n|u -- flag)
zerogt	tst.l	tos
	sgt	tos
	ext.w	tos
	ext.l	tos
	tonext			; 910714 jax

	lfa	i0
	nfa	4,'(2>R',')'	; ( x1 x2 --) ( R: -- x1 x2)
ptwotor	move.l	(dsp)+,-(rp)
	pop	-(rp)
	tonext			; 910714 jax

	lfa	2		; dpANS-2 C CORE EXT
	nfi	3,'2>','R'	; ( x1 x2 --) ( R: -- x1 x2)
twotor	nest
	kcomp	chkstat
	kcomp	parlit
	kcomp	ptwotor
	kcomp	ctok
	kcomp	unnest		; 910714 jax

	lfa	i0
	nfa	4,'(2R>',')'	; ( -- x1 x2) ( R: x1 x2 -- )
ptworfr	pshdsp
	move.l	(rp)+,tos
	move.l	(rp)+,-(dsp)
	tonext

	lfa	2		; dpANS-2 CORE EXT
	nfi	3,'2R','>'	; ( -- x1 x2) ( R: x1 x2 -- )
tworfro	nest
	kcomp	chkstat
	kcomp	parlit
	kcomp	ptworfr
	kcomp	ctok
	kcomp	unnest		; 910714 jax

	lfa	2		; dpANS-2 CORE EXT
	nfa	3,'2R','@'	; ( -- x1 x2) ( R: x1 x2 -- x1 x2)
tworfet	pshdsp
	move.l	(rp),tos
	move.l	4(rp),-(dsp)
	tonext			; 910714 jax

	lfa	2		; dpANS-2 CORE EXT
	nfa	7,':NONAM','E'	; ( -- xt colon-sys)
cnoname	nest			; xt Execution: (i*x -- j*x) (R: -- sys)
	kcomp	alidic
	kcomp	dpfet
	kcomp	mtok
	kcomp	las
	kcomp	store		; this so RECURSE can find the :NONAME def
	literal	unheader	; create this as a headerless def
	kcomp	ctok
	kcomp	dpfet		; current dictionary pointer
	kcomp	mtok		; convert to local code token
	kcomp	makenest	; compile a NEST
	kcomp	depth
	literal	csp
	kcomp	store		; compiler security
	literal	nonaming	; mark this so semicol doesn't UNSMUDGE
	kcomp	on
	kcomp	rbrack		; turn on compiler
	kcomp	unnest		; 910731 jax

	lfa	0		; dpANS-2 CORE EXT
	nfa	2,<'<'>,'>'	; ( x1 x2 -- flag)
noteq	cmp.l	(dsp)+,tos
	sne	tos
	ext.w	tos
	ext.l	tos
	tonext			; 910714

	lfa	3		; dpANS-2 C CORE EXT
	nfi	3,'?D','O'	; Compilation: ( -- dodest)
kqdo	nest			; Execution: ( n1|u1 n2|u2 --) ( R: -- |sys)
	kcomp	chkstat	; abort if interpreting
	kcomp	parlit	; need a literal to store into local code space
	kcomp	doqdo	; the kernel address of the lable DOQDO
	kcomp	ctok	; this is the store to local code space
	kcomp	dpfet	; leave user dict pointer on stack
	kcomp	parlit
	kcomp	noop	; place holder for branch resolve
	kcomp	ctok
	literal	doflag	; and a compiler flag
	kcomp	unnest		; 910714 jax

	lfa	1		; dpANS-2 C CORE EXT
	nfi	5,'AGAI','N'	; Compilation: ( dest --)
kagain	nest			; Execution: ( --)
	kcomp	chkstat		; abort if interpreting
*	literal	beginflag	; check for compiler flag
*	kcomp	noteq		; test	; review dpANS-2 Table 5-3.
*	abortq	"BEGINFLAG missing at AGAIN"	; abort with error
	kcomp	parlit		; we need the kernel LOOP engine
	kcomp	doelse		; the ELSE engine addr as kernel token
	kcomp	ctok		; compile it at runtime, it works for AGAIN
	kcomp	mtok		; convert BEGIN address to a local code token
	kcomp	ctok		; compile it at runtime
	kcomp	unnest		; 910705 jax

	lfa	i0
	nfa	3,'(C"',')'	; ( -- c-addr) (R: a-addr -- addr<-addr+u)
pcquote	pshdsp			; prepare stack
	move.l	(ip)+,tos	; IP was pointing at cell containing DSeg addr
	tonext

	lfa	3		; dpANS-2 C CORE EXT
	nfi	2,'C','"'	; Compilation: ( "ccc" --)
cquote	nest			; Execution: ( -- c-addr)
	kcomp	chkstat		; abort if interpreting
	kcomp	parlit		; need kernel address of (C")
	kcomp	pcquote		; as a literal
	kcomp	ctok		; to compile at run time
	kcomp	commaq		; compile string to Data Seg
	kcomp	unnest		; 910706 jax

	lfa	3		; dpANS-2 C CORE EXT
	nfi	4,'CAS','E'	; Compilation: ( -- case-sys)
case	nest			; Execution: ( --)
	kcomp	chkstat		; abort if interpreting
	literal	0		; leave a resolution count marker
	kcomp	unnest		; 910727 jax

	lfa	3		; dpANS-2 C CORE EXT
	nfi	8,'COMPILE',','	; ( xt --)
ctok	pop	<0(np,dp.l)>	; add well-formed exe token to end of user dict
	addq.l	#cellsize,dp	; inc dict pointer
	tonext			; 910714 jax

	lfa	3		; dpANS-2 CORE EXT
	nfa	7,'CONVER','T'	; ( ud1 c-addr1 -- ud2 c-addr2 --)
convert	nest
	kcomp	onepl
	literal	countstrsize
	kcomp	to_numb
	kcomp	drop
	kcomp	unnest		; 910714 jax

	lfa	1		; dpANS-2 C CORE EXT
	nfi	7,'ENDCAS','E'	; Compilation: ( case-sys --)
endcase	nest			; Execution: ( x --)
	kcomp	chkstat		; abort if interpreting
	kcomp	parlit
	kcomp	drop		; at runtime, drop case selector
	kcomp	ctok
	kcomp	dpfet		; get resolve address for all previous OFs
	kcomp	mtok
	kcomp	swap		; -- casy-sys1 .. case-sys2 resolve of-sys
	literal	0
	compqdo	_1endca		; -- cs1 cs2 res
_0endca	kcomp	tuck		; -- cs1 res cs2 res
	kcomp	swap		; -- cs1 res res cs2
	kcomp	codtoz
	kcomp	abstod
	kcomp	store		; -- cs1 res
	comploop	_0endca
_1endca	kcomp	drop		; --
	kcomp	unnest		; 910727 jax

	lfa	1		; dpANS-2 C CORE EXT
	nfi	5,'ENDO','F'	; Compilation: ( case-sys1 of-sys -- case-sys2)
endof	nest			; Execution: (  --)
	kcomp	chkstat		; abort if interpreting
	kcomp	parlit
	kcomp	doelse		; compile ELSE to get us out of the CASE
	kcomp	ctok
	kcomp	swap		; res-addr1 of-addr count
	kcomp	onepl		; increment case counter on stack
	kcomp	dpfet		; leave address to be resolved
	kcomp	swap		; -- res-addr1 of-addr res-addrn count
	kcomp	parlit
	kcomp	abort		; to be resolved
	kcomp	ctok
	kcomp	rot		; -- res-addr1 res-addrn count of-addr
	kcomp	dpfet		; and here is the res-addr of last OF
	kcomp	mtok		; convert to token
	kcomp	swap		; -- res-addr1 res-addrn count of-res of-addr
	kcomp	codtoz
	kcomp	abstod		; convert to DSeg addr for !
	kcomp	store		; resolve OF
	kcomp	unnest		; 910727 jax

	lfa	1		; dpANS-2 CORE EXT
	nfa	5,'ERAS','E'	; ( addr u --)
erase	nest
	literal	0
	kcomp	fill
	kcomp	unnest		; 910714 jax

	lfa	1		; dpANS-2 CORE EXT
	nfa	6,'EXPEC','T'	; ( c-addr +n --)
expect	nest
	kcomp	accept		; use ACCEPT to get the string
	kcomp	spa		; store results in SPAN
	kcomp	store
	kcomp	unnest		; 910714 jax

	lfa	2		; dpANS-2 CORE EXT
	nfa	5,'FALS','E'	; ( -- false)
false	doconst	0		; 910714 jax

	lfa	0		; dpANS-2 CORE EXT
	nfa	3,'HE','X'	; ( ---)
hex	nest
	literal	$10
	kcomp	bas
	kcomp	store
	kcomp	unnest		; 910714 jax

	lfa	2	; dpANS-2 C CORE EXT
	nfi	1,'J',	; ( -- n|u) ( R: sys -- sys)
kj	nest				; colon def, compiles at runtime
	kcomp	chkstat			; abort if interpreting
	kcomp	parlit
	kcomp	dodoj			; if so, compile J
	kcomp	ctok
	kcomp	unnest			; 910714 jax

;-----------------------------------------------------------------------;
; Structure of a MARKER data body:					;
;									;
;	/dp/ap/numvocs/'voc/voc -- -- -- --/'voc/voc -- -- -- -- ...	;
;									;
;-----------------------------------------------------------------------;

; undo the dictionary back to where MARKER left it
	lfa	i2
	nfa	6,'UNMAR','K'	; ( a-addr --)
unmark	pop	a0		; base DSeg addr of MARKER data body
	adda.l	bp,a0		; convert to abs addr
	move.l	(a0)+,dp	; restore dp
	move.l	(a0)+,ap	; restore ap
	move.l	(a0)+,d0	; get numvocs stored
	bra.s	4$
1$	move.l	(a0)+,a1	; 'voc
	adda.l	bp,a1		; abs address
	move.l	#(vocwidth/cellsize),d1	; number of cells to restore
	bra.s	3$
2$	move.l	(a0)+,(a1)+	; restore a voc, all threads + overhead
3$	dbra.s	d1,2$
4$	dbra.s	d0,1$
	tonext

	lfa	1		; dpANS-2 D CORE EXT
	nfa	6,'MARKE','R'	; ( "name"--)
marker	nest			; name Execution: ( --)
	kcomp	align		; align AP, just in case
	kcomp	here		; save allocation pointer
	kcomp	dup		; extra copy
	kcomp	alidic		; align DP, just in case
	kcomp	dpfet		; save before CREATE"
	kcomp	comma		; COMMA saved dict  pointer into data space
	kcomp	comma		; COMMA saved alloc pointer into data space
	kcomp	here		; -- unmark-ptr 'numvocs
	kcomp	ptwotor		; --			R: -- unp 'numvocs
	literal	0		; -- u
	kcomp	comma		; --			R: -- unp 'numvocs
	literal	voclink		; -- a-addr		R: -- unp 'numvocs
_1marke	kcomp	fetch		; -- a-addr'  ,BEGIN	R: -- unp 'numvocs
	kcomp	qdup		; -- a-addr (a-addr)	R: -- unp 'numvocs
	compif	_2marke		; -- a-addr   ,WHILE	R: -- unp 'numvocs
	literal	1		; -- a-addr 1		R: -- unp 'numvocs
	kcomp	r_fet		; -- a-addr1 a-addr2	R: -- unp 'numvocs
	kcomp	plstore		; -- a-addr1 1 a-addr2	R: -- unp 'numvocs
	kcomp	dup		; -- a-addr a-addr	R: -- unp 'numvocs
	literal	numthreads*cellsize			R: -- unp 'numvocs
	kcomp	minus		; -- 'voclink 'voc	R: -- unp 'numvocs
	kcomp	dup		; -- 'vl 'voc 'voc	R: -- unp 'numvocs
	kcomp	comma		; -- 'vl 'voc		R: -- unp 'numvocs
	kcomp	here		; -- 'vl 'voc a-addr	R: -- unp 'numvocs
	literal vocwidth	; -- 'vl 'voc a-addr n	R: -- unp 'numvocs
	kcomp	amov		; -- 'vl		R: -- unp 'numvocs
	literal	vocwidth	; -- 'vl n		R: -- unp 'numvocs
	kcomp	allot		; -- 'vl		R: -- unp 'numvocs
	compelse	_1marke	; -- a-addr   ,REPEAT	R: -- unp 'numvocs
_2marke				; --			R: -- unp 'numvocs
	kcomp	ptworfr		; -- unp 'numvocs
	kcomp	drop		; -- unp
	kcomp	creatq		; -- unp   ,make header
	kcomp	makenest	; -- unp   ,make it a colon def
	kcomp	parlit		; -- unp
	kcomp	parlit		; -- unp
	kcomp	ctok		; -- unp
	kcomp	ctok		; --       ,points to base of MARKER struct
	kcomp	parlit		;
	kcomp	unmark		; UNMARK is a token in created def
	kcomp	ctok		;
	kcomp	parlit		;
	kcomp	unnest		; and the MARKER-created def ends in UNNEST
	kcomp	ctok		;
	kcomp	unnest		; 910726 jax

	lfa	2		; dpANS-2 CORE EXT
	nfa	3,'NI','P'	; ( x1 x2 --- x2)
nip	addq.l	#4,dsp
	tonext			; 910714 jax

	lfa	3		; dpANS-2 C CORE EXT
	nfi	2,'O','F'	; Compilation: ( case-sys1 -- case-sys2 of-sys)
of	nest			; Execution: ( x1 x1 --  |x1)
	kcomp	chkstat		; abort if interpreting
	kcomp	parlit
	kcomp	over		; at runtime, DUP the selector
	kcomp	ctok
	kcomp	parlit
	kcomp	equal		; at runtime, compare selector with literal
	kcomp	ctok
	kcomp	parlit
	kcomp	doif		; then IF selector matches literal
	kcomp	ctok
	kcomp	dpfet		; save resolve address on stack for ENDOF
	kcomp	parlit
	kcomp	abort		; and here is the dummy to be resolved
	kcomp	ctok
	kcomp	parlit
	kcomp	drop		; at runtime DROP selector if we enter the OF
	kcomp	ctok
	kcomp	unnest		; 910727 jax

	lfa	0		; dpANS-2 CORE EXT
	nfa	3,'PA','D'	; ( -- c-addr)
pad	datp		; return scratch area past current data allocation
	addi.l	#$80,tos
	tonext			; 910714 jax

	lfa	i0		
	nfa	7,'(PARSE',')'	; ( char "ccc<char>" -- c-addr u)
pparse	nest			; skips leading delims
	kcomp	source	; -- ch c-a u   , get TIB or current BLOCK & char count
	kcomp	toi	; -- ch c-a u a , get addr of current interp inset var
	kcomp	fetch	; -- ch c-a u n , get current inset
	kcomp	slstr	; -- ch c-a' u'
	kcomp	over	; -- ch c-a' u' c-a'	Need a copy to increment >IN
	kcomp	pto_r	; -- ch c-a' u'		R: -- c-a'
	kcomp	dup	; -- ch c-a' u' u'	R: -- c-a'
	kcomp	zerogt	; -- ch c-a' u' t|f	R: -- c-a'
	compif	_0parse	; -- ch c-a' u'		R: -- c-a'
	literal	2	; -- ch c-a' u' 2	R: -- c-a'
	kcomp	pick	; -- ch c-a' u' ch' , copy of delim char R: -- c-a'
	kcomp	skip	; -- ch c-a'' u'' , skip leading delim	 R: -- c-a'
_9parse	kcomp	over	; -- ch c-a'' u'' c-a''	R: -- c-a'
	kcomp	pto_r	; -- ch c-a'' u'' ,save adr of 1st char R: -- c-a' c-a''
	kcomp	rot	; -- c-a' u'' ch	R: -- c-a' c-a''
	kcomp	scan	; -- c-a''' u'''	R: -- c-a' c-a''
	kcomp	drop	; -- c-a'''		R: -- c-a' c-a''
	kcomp	pr_from	; -- c-a''' c-a''	R: -- c-a'
	kcomp	pr_from	; -- c-a''' c-a'' c-a'	R: --
	literal	2	; -- c-a''' c-a'' c-a' 2
	kcomp	pick	; -- c-a''' c-a'' c-a' c-a'''
	kcomp	swap	; -- c-a''' c-a'' c-a''' c-a'
	kcomp	minus	; -- c-a''' c-a'' n
	kcomp	onepl	; account for the character itself which was parsed to.
	kcomp	toi	; -- c-a''' c-a'' n a
	kcomp	plstore	; -- c-a''' c-a''
	kcomp	tuck	; -- c-a'' c-a''' c-a''
	kcomp	minus	; -- c-addr1 u
	compelse	_1parse		; -- ch c-a u	R: -- c-a
_0parse	kcomp	r_frodr	; -- ch c-a u	R: --
	kcomp	drop	; -- ch c-a
	kcomp	nip	; -- c-a
	literal	0	; -- c-a 0
_1parse	kcomp	unnest		; 910714 jax

***!!!*** Optomize this turkey!
	lfa	0		; dpANS-2 CORE EXT
	nfa	5,'PARS','E'	; ( char "ccc<char>" -- c-addr u)
parse	nest			; hits on leading delimiters
	kcomp	source	; -- ch c-a u   , get TIB or current BLOCK & char count
	kcomp	toi	; -- ch c-a u a , get addr of current interp inset var
	kcomp	fetch	; -- ch c-a u n , get current inset
	kcomp	slstr	; -- ch c-a' u'
	kcomp	over	; -- ch c-a' u' c-a'	Need a copy to increment >IN
	kcomp	pto_r	; -- ch c-a' u'		R: -- c-a'
	kcomp	dup	; -- ch c-a' u' u'	R: -- c-a'
	kcomp	zerogt	; -- ch c-a' u' t|f	R: -- c-a'
	compif	_0parse	; -- ch c-a' u'		R: -- c-a'
	compelse	_9parse
; Clumsy hack correcting incorrect behaviour of my original PARSE and still
; allowing WORD and PARSE to share code ... fix later.
***!!!***

	lfa	0		; dpANS-2 CORE EXT
	nfa	4,'PIC','K' ; ( x(u) .. x(1) x(0) u -- x(u) .. x(1) x(0) x(u)) 
pick	lsl.l	#2,tos
	move.l	0(dsp,tos.l),tos
	tonext			; 910714 jax

	lfa	1		; dpANS-2 CORE EXT
	nfa	5,'QUER','Y'	; ( --)
query	nest
	kcomp	tib
	literal	inputsize
	kcomp	accept		; from terminal, get 80 characters
	kcomp	numti		; set #TIB
	kcomp	store
	kcomp	kblk
	kcomp	off
	kcomp	sourcfi
	kcomp	off
	kcomp	toi
	kcomp	off
	kcomp	unnest		; 910714 jax

	lfa	2		; dpANS-2 CORE EXT
	nfa	6,'REFIL','L'	; ( -- flag)
refill	nest
	kcomp	sourcfi		; -- a-addr
	kcomp	fetch		; -- x
	kcomp	true		; -- x true
	kcomp	equal		; -- flag
	compif	_1refil		; --
	kcomp	false		; -- 0
	kcomp	pexit		; -- 0
_1refil	kcomp	kblk		; -- a-addr
	kcomp	fetch		; -- n
	kcomp	qdup		; -- [ n n ] | 0
	compif	_2refil		; -- n
	kcomp	onepl		; -- n'
	kcomp	dup		; -- n' n'
	kcomp	onepl		; -- n' n''
	literal	rawblocksize	; -- n1 n2 n3
	kcomp	star		; -- n1 n2
	kcomp	blockfi		; -- n1 n2 a-addr
	kcomp	fetch		; -- n1 n2 x
	kcomp	filsiz		; -- n1 n2 ud ior
	compif	_3refil		; -- n1 n2 ud
	kcomp	twodrop		; -- n1 n2
	kcomp	twodrop		; --
	kcomp	false		; -- 0
	kcomp	pexit		; -- 0
_3refil	kcomp	drop		; -- n1 n2 u
	kcomp	greater		; -- n1 flag
	compif	_4refil		; -- n1
	kcomp	drop		; --
	kcomp	false		; -- 0
	kcomp	pexit		; -- 0
_4refil	kcomp	kblk		; -- n1 a-addr
	kcomp	store		; --
	kcomp	toi		; -- a-addr
	kcomp	off		; --
	kcomp	true		; -- true
	kcomp	pexit		; -- true
_2refil
	kcomp	sourcfi		; -- a-addr
	kcomp	fetch		; -- x
	kcomp	qdup		; -- [ x x ] | 0
	kcomp	zeroeq		; -- [ n flag ] | true
	compif	_5refil		; --
	kcomp	tib		; -- a-addr
	literal	inputsize	; -- a-addr n
	kcomp	accept		; -- n
	kcomp	numti		; -- n a-addr
	kcomp	store		; --
	kcomp	toi		; -- a-addr
	kcomp	off		; --
	kcomp	true		; -- true
	kcomp	pexit		; -- true
_5refil	kcomp	tib		; -- x a-addr
	literal	inputsize	; -- x a-addr n
	kcomp	rot		; -- a-addr n x
	kcomp	readlin		; -- u flag ior
	kcomp	drop		; -- u flag
	compif	_6refil		; -- u
	kcomp	numti		; -- u a-addr
	kcomp	store		; --
	kcomp	true		; -- true
	kcomp	pexit		; -- true
_6refil	kcomp	drop		; --
	kcomp	false		; -- 0
	kcomp	unnest		; 910827 jax

	lfa	2		; dpANS-2 CORE EXT
	nfa	$0D,'RESTORE-INPU','T'	; ( x1 .. xn n -- flag)
restinp	nest
	literal	10		; -- n0 n1 n2 x c-a f1 udpos ior f2 #items 10
	kcomp	noteq		; -- n0 n1 n2 x c-a f1 udpos ior f2 f3
	abortq"	Error at RESTORE-INPUT."
	compif	_2resti		; -- n0 n1 n2 x c-a flag1 udpos ior
	compif	_1resti		; -- n0 n1 n2 x c-a flag1 udpos
	kcomp	twodrop		; -- n0 n1 n2 x c-a flag1
	kcomp	twodrop		; -- n0 n1 n2 x
	kcomp	twodrop		; -- n0 n1
	kcomp	twodrop		; --
	kcomp	true		; -- true
	kcomp	pexit
_1resti	kcomp	sourcfi		; -- n0 n1 n2 x c-a flag1 udpos a-addr
	kcomp	fetch		; -- n0 n1 n2 x c-a flag1 udpos x
	kcomp	repofil		; -- n0 n1 n2 x c-a flag1 ior
	kcomp	drop		; -- n0 n1 n2 x c-a flag1
	compelse	_3resti
_2resti	kcomp	drop		; -- n0 n1 n2 x c-a flag1 udpos
	kcomp	twodrop		; -- n0 n1 n2 x c-a flag1
_3resti	kcomp	kendq		; -- n0 n1 n2 x c-addr flag a-addr
	kcomp	store		; -- n0 n1 n2 x c-addr
	kcomp	tickti		; -- n0 n1 n2 x c-addr a-addr
	kcomp	store		; -- n0 n1 n2 x
	kcomp	sourcfi		; -- n0 n1 n2 x a-addr
	kcomp	store		; -- n0 n1 n2
	kcomp	kblk		; -- n0 n1 n2 a-addr
	kcomp	store		; -- n0 n1
	kcomp	toi		; -- n0 n1 a-addr
	kcomp	store		; -- n0
	kcomp	numti		; -- n0 a-addr
	kcomp	store		; --
	kcomp	unnest		; 910830 jax

	lfa	2		; dpANS-2 CORE EXT
	nfa	4,'ROL','L'	; ( x(u) x(u-1) .. x(0)u -- x(u-1) .. x(0) x(u))
roll	move.l	tos,d0		; copy of index
	lsl.l	#2,tos		; turn into cellsize offset
	move.l	dsp,a0		; get current data stack pointer
	adda.l	tos,a0		; add the offset to point to u'th item
	move.l	(a0),tos	; get u'th item to TOS
	move.l	a0,a1		; copy of address of U'th item
	adda.l	#cellsize,a1	; for our predecrementing move
	bra.s	2$
1$	move.l	-(a0),-(a1)	; move rest of stack down in stack (up in mem)
2$	dbra.w	d0,1$
	adda.l	#cellsize,dsp	; index was consumed, slide stack pointer
	tonext			; 910714 jax

	lfa	3		; dpANS-2 CORE EXT
	nfa	10,'SAVE-INPU','T'	; ( -- x1 .. xn n)
savinp	nest
	kcomp	numti		; -- a-addr
	kcomp	fetch		; -- n
	kcomp	toi		; -- a-addr
	kcomp	fetch		; -- n0 n1
	kcomp	kblk		; -- n0 n1 a-addr
	kcomp	fetch		; -- n0 n1 n2
	kcomp	sourcfi		; -- n0 n1 n2 a-addr
	kcomp	fetch		; -- n0 n1 n2 x
	kcomp	tickti		; -- n0 n1 n2 x a-addr
	kcomp	fetch		; -- n0 n1 n2 x c-addr
	kcomp	kendq		; -- n0 n1 n2 x c-addr a-addr
	kcomp	fetch		; -- n0 n1 n2 x c-addr flag
	kcomp	sourcfi		; -- n0 n1 n2 x c-addr flag a-addr
	kcomp	fetch		; -- n0 n1 n2 x c-addr flag x
	kcomp	dup		; -- n0 n1 n2 x c-addr flag x x
	kcomp	true		; -- n0 n1 n2 x c-addr flag x x true
	kcomp	noteq		; -- n0 n1 n2 x c-addr flag1 x flag2
	kcomp	over		; -- n0 n1 n2 x c-addr flag1 x flag2 x
	kcomp	zerone		; -- n0 n1 n2 x c-addr flag1 x flag2 flag3
	kcomp	b_and		; -- n0 n1 n2 x c-addr flag1 x flag2'
	compif	_1savin		; -- n0 n1 n2 x c-addr flag x
	kcomp	filpos		; -- n0 n1 n2 x c-addr flag udpos ior
	kcomp	true		; -- n0 n1 n2 x c-addr flag1 udpos ior flag2
	compelse	_2savin	; -- n0 n1 n2 x c-addr flag x
_1savin	kcomp	false		; -- n0 n1 n2 x c-addr flag udgarbage
	kcomp	false		; -- n0 n1 n2 x c-addr flag udgarbage ior
	kcomp	false		; -- n0 n1 n2 x c-addr flag1 udgarbage ior flag2
_2savin	literal	10		; -- n0 n1 n2 x c-addr f1 udpos ior f2 #items
	kcomp	unnest		; 910830 jax

	lfa	3		; dpANS-2 CORE EXT
	nfa	4,'SPA','N'	; ( -- a-addr)
spa	docreat	span		; 910714 jax

to_valu	lsl.l	#1,tos		; check for kernel or local tok
	bcc.s	1$
	move.l	4(cp,tos.l),tos	; fetch kernel word data pointer
	tonext
1$	move.l	_1mkval-_0mkval(np,tos.l),tos	; fetch local word data pointer
	tonext			; 910714 jax

	lfa	0		; dpANS-2 CORE EXT
	nfi	2,'T','O'	; Usage: TO name
to	nest			; Execution: ( x --)
	kcomp	stat
	kcomp	fetch
	compif	_1to
	kcomp	parlit
	kcomp	parlit
	kcomp	ctok
	kcomp	tick
	kcomp	to_valu
	kcomp	ctok
	kcomp	parlit
	kcomp	store
	kcomp	ctok
	compelse	_2to
_1to	kcomp	tick
	kcomp	to_valu
	kcomp	store
_2to	kcomp	unnest		; 910714 jax

	lfa	0		; dpANS-2 CORE EXT
	nfa	4,'TRU','E'	; ( -- true)
true	doconst	-1		; 910714 jax

	lfa	0		; dpANS-2 CORE EXT
	nfa	4,'TUC','K'	; ( x1 x2 --- x2 x1 x2)
tuck	move.l	(dsp),-(dsp)	;
	move.l	tos,$4(dsp)
	tonext			; 910714 jax

	lfa	1		; dpANS-2 CORE EXT
	nfa	3,'U.','R'	; ( u n -- )
udotr	nest
	kcomp	depth		; -- n1 n2
	literal	2
	kcomp	lesst		; -- n1 flag
	abortq	"Stack Underflow"	; --
	kcomp	pto_r		; -- n1			R: -- n2
	kcomp	s_to_d		; -- d1			R: -- n2
	kcomp	lsharp		; -- d1h _d1_		R: -- n2
	kcomp	sharps		; -- d1h d2		R: -- n2
	kcomp	sharpr		; -- addr ct		R: -- n2
	kcomp	pr_from		; -- addr ct n2		R: --
	kcomp	twodup		; -- addr ct n2 ct n2
	kcomp	lesst		; -- addr ct n2 flag
	compif	_2udotr		; -- addr ct n2  ,there is extra room in field
	kcomp	over		; -- addr ct n2 ct
	kcomp	minus		; -- addr ct n3
	kcomp	spaces		; -- addr ct
	compelse	_3udotr	; -- addr ct n1  ,no extra room in field
_2udotr	kcomp	drop		; -- addr ct
_3udotr	kcomp	type		; --
	kcomp	unnest		; 910714 jax

	lfa	1		; dpANS-2 CORE EXT
	nfa	2,'U','>'	; ( u1 u2 -- flag)
ugreat	cmp.l   (dsp)+,tos
	scs     tos       
	ext.w   tos       
	ext.l   tos       
	tonext			; 910623ok

	lfa	1		; dpANS-2 CORE EXT
	nfa	6,'UNUSE','D'	; ( -- u)
unused	nest			; ***!!!*** quick hack
	literal	$2000		; default data space size
	kcomp	here
	kcomp	minus		; data space will be resizeable in later revs.
	kcomp	unnest		; 910727 jax

	lfa	i1
	nfa	7,'MAKEVA','L'	; ( --)
makvalue		; copy the DOVALUE engine into code space
	move.w	#(_1mkval-_0mkval),d0	; length of code to copy
	move.l	#_0mkval,a0		; KSeg addr to start from
	move.l	dp,a1			; Destination in NSeg
	adda.l	np,a1			; Convert to AbsAddr
	bra.s	2$
1$	move.b	(a0)+,(a1)+	; loop copying code to code segment
2$	dbra.w	d0,1$
	suba.l	np,a1		; convert back to NSeg addr
	move.l	a1,dp		; restore dictionary pointer
	tonext
_0mkval	move.l	tos,-(dsp)	; push stack
	move.l	*+10(pc),tos	; load TOS with this word's data ptr
	move.l	0(bp,tos.l),tos	; get value
	jmp	(np)
_1mkval

	lfa	2		; dpANS-2 D CORE EXT
	nfa	5,'VALU','E'	; ( "name" --)
value	nest			; name Execution: ( -- x)
	kcomp	creatq
	kcomp	makvalue
	kcomp	here
	kcomp	ctok
	kcomp	cell
	kcomp	allot
	kcomp	unnest		; 910714 jax

	lfa	3		; dpANS-2 CORE EXT
	nfa	6,'WITHI','N'	; ( n1|u1 n2|u2 n3|u3 -- flag)
within	move.l	(dsp)+,d0	; lowlim
	move.l	(dsp)+,d1	; item
	sub.l	d0,d1		; item-lowlim
	sub.l	d0,tos		; hilim-lowlim
	cmp.l	d1,tos		; is (hilim-lowlim) > (item-lowlim) ?
	shi.s	tos
	ext.w	tos
	ext.l	tos
	tonext			; 910714 jax

;-----------------------------------------------------------------------;
;    Oh foo, >R etc. are not going to work correctly with [COMPILE]	;
;-----------------------------------------------------------------------;

	lfa	3		; dpANS-2 C CORE EXT
	nfi	9,'[COMPILE',']'	; Compilation: ( "name" --)
bcompil	nest
	kcomp	chkstat		; abort if interpreting
	kcomp	tick		; get address of next lexical item in input
	kcomp	find		; FIND in dictionary
	compif	_1bcomp		; found?	
	kcomp	ctok		; compile it right now
	compelse	_2bcomp	; not found
_1bcomp	kcomp	tickwor
	kcomp	count
	kcomp	type
	kcomp	space
	kcomp	true
	abortq	"was not found by [COMPILE]."	; abort with informatif
_2bcomp	kcomp	unnest		; 910714 jax

	lfa	0		; dpANS-2 CORE EXT
	nfi	1,'\'		; ( "ccc<eol>" --)
backsla	nest
	kcomp	kblk		; -- a-addr
	kcomp	fetch		; -- n
	compif	_1backsl	; --
	kcomp	csll		; -- n
	kcomp	toi		; -- n a-addr
	kcomp	fetch		; -- n1 n2
	kcomp	over		; -- n1 n2 n1
	kcomp	mod		; -- n1 n2'
	kcomp	dup		; -- n1 n2' n2'
	compif	_0backsl	; -- n1 n2
	kcomp	minus		; -- n
	compelse	_9backsl
_0backsl
	kcomp	nip		; -- 0
_9backsl
	kcomp	toi		; -- n a-addr
	kcomp	fetch		; -- n1 n2
	kcomp	plus		; -- n
	literal	rawblocksize-1	; -- n1 n2
	kcomp	min		; -- n
	kcomp	dup		; -- n n 
	kcomp	toi		; -- n n a-addr
	kcomp	store		; -- n
	literal	rawblocksize-1	; -- n1 n2
	kcomp	equal		; -- flag
	compif	_2backsl	; --
_1backsl
	kcomp	kendq		; -- a-addr
	kcomp	on		; --
_2backsl
	kcomp	unnest		

;-----------------------------------------------------------------------;
;			    DOUBLE Word Set				;
;-----------------------------------------------------------------------;

	lfa	i1
	nfa	10,'MAKE2CONS','T'	; ( --)
maktwoc			; copy the DOTWOCONST engine into code space
	move.w	#(_1mktco-_0mktco),d0	; length of code to copy
	move.l	#_0mktco,a0		; KSeg addr to start from
	move.l	dp,a1			; Destination in NSeg
	adda.l	np,a1			; Convert to AbsAddr
	bra.s	2$
1$	move.b	(a0)+,(a1)+	; loop copying code to code segment
2$	dbra.w	d0,1$
	suba.l	np,a1		; convert back to NSeg addr
	move.l	a1,dp		; restore dictionary pointer
	tonext
_0mktco	pshdsp			; push stack
	move.l	*+10(pc),tos	; load TOS with stored hi literal value
	move.l	*+10(pc),-(dsp)	; load -(DSP) with stored lo literal value
	jmp	(np)
_1mktco

	lfa	2			; dpANS-2 D DOUBLE
	nfa	9,'2CONSTAN','T'	; Compilation: ( x1 x2 "name" --)
twocons	nest				; Execution: ( -- x1 x2)
	kcomp	creatq
	kcomp	maktwoc
	kcomp	ctok
	kcomp	ctok
	kcomp	unnest		; 910711 jax

	lfa	2		; dpANS-2 C DOUBLE ( x1 x2 --) (compiling)
	nfa	8,'2LITERA','L'	; ( -- x1 x2)
k2liter	nest
	kcomp	chkstat		; abort if interpreting
	kcomp	parlit		; the next token is actually a numeric literal
	kcomp	p2lit		; kernel token for (2LIT)
	kcomp	ctok		; compile token to runtime dictionary
	kcomp	ctok		; compile high-order literal itself
	kcomp	ctok		; compile low-order literal itself
	kcomp	unnest

	lfa	2			; dpANS-2 D DOUBLE
	nfa	9,'2VARIABL','E'	; Compilation: ( "name" --)
twovari	nest				; Execution: ( -- a-addr)
	kcomp	create
	literal	2*cellsize
	kcomp	allot
	kcomp	unnest		; 910714 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	2,'D','+'	; ( d1|ud11 d2|ud2 --- d3|ud3)
dplus	move.l	(dsp)+,d0	; d2l	
	move.l	(dsp)+,d1	; d1h
	add.l	(dsp),d0	; d3l
	addx.l	d1,tos		; d3h
	move.l	d0,(dsp)	; d3l
	tonext			; 910718 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	2,'D','-'	; ( d1|ud11 d2|ud2 --- d3|ud3)
dminus	move.l	(dsp)+,d0	; d2l	
	move.l	(dsp)+,d1	; d1h
	move.l	(dsp),d2	; d1l
	sub.l	d0,d2		; d3l
	subx.l	tos,d1		; d3h
	move.l	d1,tos		; d3h
	move.l	d2,(dsp)	; d3l
	tonext			; 910718 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	2,'D','.'	; ( d --)
ddot	nest
	kcomp	depth		; -- n1 n2
	literal	2
	kcomp	lesst		; -- n1 flag
	abortq	"Stack Underflow"	; --
	kcomp	tuck		; -- d1h d1
	kcomp	dabs		; -- d1h _d1_
	kcomp	lsharp		; -- d1h d1
	kcomp	sharps		; -- d1h d2
	kcomp	rot		; -- d2 d1h
	kcomp	zerolt		; -- d2 flag
	compif	_1ddot		; -- d2
	literal	'-'		; -- d2 char
	kcomp	hold		; -- d2
_1ddot	kcomp	sharpr		; -- c-addr u
	kcomp	type		; --
	kcomp	space		; --
	kcomp	unnest		; 910716 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	3,'D.','R'	; ( d n --)
ddotr	nest
	kcomp	depth		; -- n1 n2
	literal	3
	kcomp	lesst		; -- n1 flag
	abortq	"Stack Underflow"	; --
	kcomp	pto_r		; -- n1			R: -- n2
	kcomp	tuck		; -- d1h d1		R: -- n2
	kcomp	dabs		; -- d1h _d1_		R: -- n2
	kcomp	lsharp		; -- d1h _d1_		R: -- n2
	kcomp	sharps		; -- d1h d2		R: -- n2
	kcomp	rot		; -- d2 d1h		R: -- n2
	kcomp	zerolt		; -- d2 flag		R: -- n2
	compif	_1ddotr		; -- d2			R: -- n2
	literal	'-'		; -- d2 char		R: -- n2
	kcomp	hold		; -- d2			R: -- n2
_1ddotr	kcomp	sharpr		; -- addr ct		R: -- n2
	kcomp	pr_from		; -- addr ct n2		R: --
	kcomp	twodup		; -- addr ct n2 ct n2
	kcomp	lesst		; -- addr ct n2 flag
	compif	_2ddotr		; -- addr ct n2  ,there is extra room in field
	kcomp	over		; -- addr ct n2 ct
	kcomp	minus		; -- addr ct n3
	kcomp	spaces		; -- addr ct
	compelse	_3ddotr	; -- addr ct n1  ,no extra room in field
_2ddotr	kcomp	drop		; -- addr ct
_3ddotr	kcomp	type		; --
	kcomp	unnest		; 910716 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	3,'D0',<'<'>	; ( d -- flag)
dzerolt	tst.l	tos		; test hi order
	slt	tos		; set tos appropriately
	ext.w	tos
	ext.l	tos
	move.l	(dsp)+,d0	; discard lo order
	tonext			; 910718 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	3,'D0','='	; ( d|ud -- flag)
dzeroeq	or.l	(dsp)+,tos	; OR together dh dl
	tst.l	tos		; test
	seq	tos		; set tos appropriately
	ext.w	tos
	ext.l	tos
	tonext			; 910911 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	3,'D2',<'*'>	; ( d1 -- d2)
dtwosta	move.l	(dsp),d0
	lsl.l	#1,d0
	roxl.l	#1,tos
	move.l	d0,(dsp)
	tonext			; 910717 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	3,'D2',<'/'>	; ( d1 -- d2)
dtwosl	move.l	(dsp),d0
	asr.l	#1,tos
	roxr.l	#1,d0
	move.l	d0,(dsp)
	tonext			; 910718 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	2,'D',<'<'>	; ( d1 d2 -- flag)
dlesst	move.l	(dsp)+,d2	; d2l
	move.l	(dsp)+,d1	; d1h
	move.l	(dsp)+,d0	; d1l
	sub.l	d2,d0		; d1l - d2l
	subx.l	tos,d1		; d1h - d2h
	tst.l	d1		; test bit 63, effectively
	slt	tos		; set tos appropriately
	ext.w	tos
	ext.l	tos
	tonext			; 910718 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	2,'D','='	; ( xd1 xd2 -- flag)
dequal	move.l	(dsp)+,d2	; d2l
	move.l	(dsp)+,d1	; d1h
	sub.l	(dsp)+,d2	; d2l-d1l
	subx.l	d1,tos		; d2h-d1h
	or.l	d2,tos		; combine hi and low order
	seq	tos		; set tos true if result is 0
	ext.w	tos
	ext.l	tos
	tonext			; 910718 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	3,'D>','S'	; ( d -- n)
d_to_s	popdsp			; drop top portion .. report err on ov'flow?
	tonext			; no err report ... "ambiguous condition"
				; 910718 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	4,'DAB','S'	; ( d1 -- +d2)
dabs	tst.l	tos
	blt.s	dnegate
	tonext			; 910718 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	4,'DMA','X'	; ( d1 d2 -- d3)
dmax	move.l	(dsp)+,d1
	move.l	(dsp)+,d0
	cmp.l	d0,tos
	bgt.s	1$
	blt.s	2$
	cmp.l	(dsp),d1
	blt.s	2$
1$	move.l	d1,(dsp)
	tonext
2$	move.l	d0,tos
	tonext			; 910718 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	4,'DMI','N'	; ( d1 d2 -- d3)
dmin	move.l	(dsp)+,d1
	move.l	(dsp)+,d0
	cmp.l	d0,tos
	blt.s	1$
	bgt.s	2$
	cmp.l	(dsp),d1
	bgt.s	2$
1$	move.l	d1,(dsp)
	tonext
2$	move.l	d0,tos
	tonext			; 910718 jax

	lfa	0		; dpANS-2 DOUBLE
	nfa	7,'DNEGAT','E'	; ( d1 -- d2)
dnegate	neg.l	(dsp)
	negx.l	tos
	tonext			; 910718 jax

	lfa	1		; dpANS-2 DOUBLE
	nfa	3,'M*','/'	; ( d1 n1 +n2 -- d2)
mstarsl	nest
	kcomp	qdup		; non-zero divisor?
	compif	_1mstars	; yes
	kcomp	pto_r		; -- d1 n1		R: -- +n2
	kcomp	rot		; -- d1h n1 d1l		R: -- +n2
	kcomp	over		; -- d1h n1 d1l	n1	R: -- +n2
	kcomp	mstar		; -- d1h n1 t0lm	R: -- +n2
	kcomp	twoswa		; -- t0lm d1h n1	R: -- +n2
	kcomp	mstar		; -- t0lm t1mh		R: -- +n2
	kcomp	rot		; -- t0l t1m t1h t0m
	kcomp	rot		; -- t0l t1h t0m t1m
	literal 0
	kcomp	tuck
	kcomp	dplus		; -- t0l t1h tzm carry		
	kcomp	rot
	kcomp	plus		; -- tl tm th
	kcomp	dup		; -- tl tm th th
	kcomp	zerolt		; -- tl tm th flag
	compif	_0mstars	; negative triple
	kcomp	tabs
	kcomp	r_fet		; -- tl tm th +n2	R: -- +n2
	kcomp	muslmod		; -- tl r d0
	kcomp	twodrop		; -- tl r		R: -- +n2
	kcomp	pr_from		; -- tl r +n2		R: --
	kcomp	muslmod		; -- r d2
	kcomp	dnegate		; -- r -d2
	kcomp	rot		; -- -d2 r
	kcomp	drop		; -- -d2
	kcomp	pexit
_0mstars			; positive triple
	kcomp	r_fet		; -- tl tm th +n2	R: -- +n2
	kcomp	muslmod		; -- tl r d0
	kcomp	twodrop		; -- tl r
	kcomp	pr_from		; -- tl r +n2
	kcomp	muslmod		; -- r d2
	kcomp	rot
	kcomp	drop		; -- d2
	kcomp	pexit
_1mstars			; -- d1 n1
	kcomp	drop
	kcomp	twodrop		; --
	dliteral	-1,-1	; -- -1 -1
	kcomp	unnest		; 910718 jax

	lfa	1		; dpANS-2 DOUBLE
	nfa	2,'M','+'	; ( d1|ud11 n1|u1 --- d2|ud2)
mplus	moveq.l	#0,d1		; a zero reg
	move.l	(dsp)+,d0	; d1h	
	add.l	(dsp),tos	; n1+d1l
	addx.l	d0,d1		; d2h
	move.l	tos,(dsp)	; d2l
	move.l	d1,tos		; d2h
	tonext			; 910718 jax

;-----------------------------------------------------------------------;
;			   DOUBLE EXT Word Set				;
;-----------------------------------------------------------------------;

	lfa	2		; dpANS-2 DOUBLE EXT
	nfa	4,'2RO','T'	; ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2)
tworot	movem.l	(dsp)+,d0-d4
	movem.l	d0-d2,-(dsp)
	move.l	tos,-(dsp)
	move.l	d4,-(dsp)
	move.l	d3,tos
	tonext			; 91-06-23 jax

	lfa	0			; dpANS-2 DOUBLE EXT
	nfa	2,'D',<'!'>		; ( d a-addr --)
dsto	walin	tos			; no guru
	move.l	(dsp)+,0(bp,tos.l)	; move data to dataseg addr
	move.l	(dsp)+,4(bp,tos.l)	; high and low portions
	popdsp				; clear stack
	tonext				; 910718 jax

	lfa	0			; dpANS-2 DOUBLE EXT
	nfa	2,'D','@'		; ( a-addr -- d)
dfet	walin	tos			; longword fetch, no gurus!
	move.l	4(bp,tos.l),-(dsp)	; get second portion
	move.l	0(bp,tos.l),tos		; hi word was stored first in memory
	tonext				; 910718 jax

	lfa	0		; dpANS-2 DOUBLE EXT
	nfa	3,'DU',<'<'>	; ( ud1 ud2 -- flag)
dulesst	move.l	(dsp)+,d2	; d2l
	move.l	(dsp)+,d1	; d1h
	move.l	(dsp)+,d0	; d1l
	sub.l	d2,d0		; d1l - d2l
	subx.l	tos,d1		; d1h - d2h
	scs	tos		; set tos appropriately
	ext.w	tos
	ext.l	tos
	tonext			; 910718 jax

;-------------------------------------------------------;
;		FILE Access Word Set			;
;-------------------------------------------------------;

	lfa	2			; dpANS-2 FILE
	nfa	9,'BLOCK-FI','D'	; ( -- a-addr)
blockfi	docreat	blockfid		; 910915 jax

	lfa	3			; dpANS-2 FILE
	nfa	10,'CLOSE-FIL','E'	; ( fileid -- ior)
closfil	pop	d1			; fileid to AmigaDOS arg reg
	callamy	Close,dos		; close file, return in TOS
	moveq.l	#0,tos			; Amy doesn't return meaningful
	tonext				; 910728 jax

* Necessary for CREATE-FILE to have an x1
	lfa	2
	nfa	7,'NEWFIL','E'	; ( -- x1)
modnfil	doconst	MODE_NEWFILE

	lfa	i0
	nfa	11,'(OPEN-FILE',')'	; ( x1 -- x2 ior)
					; 0string is at 'WORD
popenfi	pop	d2			; access mode
	move.l	#tickword,d1		; 0string-DSeg-addr
	add.l	bp,d1			; convert to abs
	callamy	Open,dos		; AmigaDOS return in TOS
	tst.l	tos			; check for err
	bne.s	_1popen			; non-0 ok, 0 there was an err
	callamy IoErr,dos		; obtain io error in TOS
	tonext
_1popen	push	#0			; no error
	tonext

	lfa	3			; dpANS-2 FILE
	nfa	11,'CREATE-FIL','E'	; ( c-addr u x1 -- x2 ior)
creafil	nest
	kcomp	negrot			; -- x1 c-a u
	literal	tibsize-1		; -- x1 c-a u n
	kcomp	min			; -- x1 c-a u'
	kcomp	tuck			; -- x1 u' c-a u'
	kcomp	tickwor			; -- x1 u' c-a u' addr
	kcomp	swap			; -- x1 u' c-a addr u'
	kcomp	amov			; -- x1 u'
	kcomp	tickwor			; -- x1 u' addr
	kcomp	plus			; -- x1 addr'
	kcomp	false			; -- x1 addr' 0
	kcomp	swap			; -- x1 0 addr'
	kcomp	cstore			; -- x1
	kcomp	popenfi			; -- x2 ior
	kcomp	unnest			; 910728 jax

	lfa	i0
	nfa	$0D,'(DELETE-FILE',')'	; ( -- ior)
					; 0string is at 'WORD
pdelfil	move.l	#tickword,d1		; 0string-DSeg-addr
	add.l	bp,d1			; convert to abs
	callamy	DeleteFile,dos		; AmigaDOS return in TOS
	tst.l	tos			; file error?
	beq.s	_1pdelf			; branch away if none
	popdsp				; discard previous return
	callamy	IoErr,dos		; but if non-zero, get io error
_1pdelf	tonext

	lfa	0			; dpANS-2 FILE
	nfa	11,'DELETE-FIL','E'	; ( c-addr u -- ior)
delfil	nest
	literal	tibsize-1		; -- c-a u n
	kcomp	min			; -- c-a u'
	kcomp	tuck			; -- u' c-a u'
	kcomp	tickwor			; -- u' c-a u' addr
	kcomp	swap			; -- u' c-a addr u'
	kcomp	amov			; -- u'
	kcomp	tickwor			; -- u' addr
	kcomp	plus			; -- addr'
	kcomp	false			; -- addr' 0
	kcomp	swap			; -- 0 addr'
	kcomp	cstore			; --
	kcomp	pdelfil			; -- ior
	kcomp	unnest			; 910915 jax

	lfa	2			; dpANS-2 FILE
	nfa	13,'FILE-POSITIO','N'	; ( fileid -- ud ior)
filpos	move.l	tos,d1			; fileid
	moveq.l	#0,d2			; position
	move.l	#OFFSET_CURRENT,d3	; mode
	callamy	Seek,dos		; AmigaDOS
	popdsp				; discard stacked return
	move.l	d0,-(dsp)		; return
	move.l	#0,tos			; Amiga doesn't support double filepos
	cmpi.l	#-1,d0			; error?
	beq.s	_1filpo			; branch if error
	push	#0			; indicate no error
	tonext				; exit
_1filpo	callamy	IoErr,dos		; get error in TOS
	tonext				; 910728 jax

	lfa	2			; dpANS-2 FILE
	nfa	9,'FILE-SIZ','E'	; (fileid -- ud ior)
filsiz	move.l	tos,d1			; fileid
	move.l	#0,d2			; offset
	move.l	#OFFSET_BEGINNING,d3	; set back to beginning
	callamy	Seek,dos		; AmigDOS
	popdsp				; discard stacked return
	cmpi.l	#-1,d0			; file error?
	beq.w	_0filsi			; branch away on error
	move.l	d0,-(dsp)		; save previous position
	move.l	tos,d1			; fileid
	move.l	#0,d2			; offset
	move.l	#OFFSET_END,d3		; set to end
	callamy	Seek,dos		; AmigaDOS
	popdsp				; discard stacked return
	cmpi.l	#-1,d0			; file error?
	beq.s	_1filsi			; branch away on error
	move.l	tos,d1			; fileid
	move.l	#0,d2			; offset
	move.l	#OFFSET_BEGINNING,d3	; mode
	callamy	Seek,dos		; AmigaDOS
	popdsp				; discard stacked return
	cmpi.l	#-1,d0			; file error?
	beq.s	_0filsi			; branch away on error
	move.l	tos,d1			; fileid
	move.l	(dsp),d2		; previous offset
	move.l	d0,(dsp)		; return from last call is filesize
	move.l	#OFFSET_BEGINNING,d3	; mode
	callamy	Seek,dos		; AmigaDOS restores original position
	popdsp				; discard stacked return
	cmpi.l	#-1,d0			; file error?
	beq.s	_0filsi			; branch away on error
	moveq.l	#0,tos			; zero for no error
	move.l	#0,-(dsp)		; Amiga doesn't support double filesize
	tonext
_0filsi	move.l	#0,-(dsp)		; double zeroes for error
_1filsi	move.l	#0,-(dsp)
	callamy	IoErr,dos		; return non-zero error in TOS
	tonext				; 910728 jax

	headerless
alocnti	move.l	#tibsize,d0
	move.l	#MEMF_CLEAR,d1
	callamy	AllocMem,exec
	tonext

	headerless
dlocnti	pop	a1
	move.l	#tibsize,d0
	callamy	FreeMem,exec
	pop	d0
	tonext

	lfa	1			; dpANS-2 FILE
	nfa	12,'INCLUDE-FIL','E'	; (i*x fileid -- j*x)
inclufi	nest
	kcomp	pto_r		; --			R: -- fh
	kcomp	savinp		; -- (..9..)		R: -- fh
	kcomp	pr_from		; -- fh			R: --
	kcomp	dup		; -- fh fh
	kcomp	sourcfi		; -- fh fh a-addr
	kcomp	store		; -- fh
	kcomp	alocnti		; -- fh abs-a
	kcomp	dup		; -- fh abs-a abs-a
	kcomp	zeroeq		; -- fh abs-a flag
	abortq	"AllocMem() err: INCLUDE-FILE."
	kcomp	dupto_r		; -- fh abs-a		R: -- mem
	kcomp	abstod		; -- fh a		R: -- mem
	kcomp	dup		; -- fh a a		R: -- mem
	literal	tibsize		; -- fh a a n		R: -- mem
	kcomp	blank		; -- fh a		R: -- mem
	kcomp	tickti		; -- fh a a-addr	R: -- mem
	kcomp	store		; -- fh			R: -- mem
_0inclf	kcomp	dup		; -- fh fh		R: -- mem
	kcomp	tib		; -- fh fh a-addr	R: -- mem
	literal	tibsize		; -- fh fh a-addr n	R: -- mem
	kcomp	rot		; -- fh a-addr n fh	R: -- mem
	kcomp	readlin		; -- fh u2 flag ior	R: -- mem
	kcomp	drop		; -- fh u2 flag		R: -- mem
	compif	_1inclf		; -- fh u2		R: -- mem
	kcomp	toi		; -- fh u2 a-addr	R: -- mem
	kcomp	off		; -- fh u2		R: -- mem
	kcomp	kendq		; -- fh u2 a-addr	R: -- mem
	kcomp	off		; -- fh u2		R: -- mem
	kcomp	numti		; -- fh u2 a-addr	R: -- mem
	kcomp	store		; -- fh			R: -- mem
	kcomp	interp
	compelse	_0inclf
_1inclf	kcomp	twodrop		; --			R: -- mem
	kcomp	pr_from		; -- mem
	kcomp	dlocnti		; -- ( ..9..)
	kcomp	restinp		; --
	kcomp	unnest		; 910911 jax

	lfa	1			; dpANS-2 FILE
	nfa	8,'INCLUDE','D'		; (i*x c-addr u -- j*x)
include	nest
	kcomp	rslasho		; -- x
	kcomp	openfil		; -- fh ior
	kcomp	zerone		; -- fh flag
	abortq	"Couldn't open INCLUDED file."
	kcomp	dupto_r		; -- fh		R: -- fh
	kcomp	inclufi		; --
	kcomp	pr_from		; -- fh
	kcomp	closfil		; -- 0
	kcomp	drop		; --
	kcomp	unnest		; 910911 jax

	lfa	3			; dpANS-2 FILE
	nfa	9,'OPEN-FIL','E'	; ( c-addr u x1 -- x2 ior)
openfil	nest
	kcomp	creafil
	kcomp	unnest			; 910728 jax

	lfa	2		; dpANS-2 FILE
	nfa	3,'R/','O'	: ( -- x)
rslasho	doconst	MODE_OLDFILE	; BASIS clashes with AmigaDOS
				; 910911 jax

	lfa	2		; dpANS-2 FILE
	nfa	3,'R/','W'	; ( -- x)
rslashw	doconst	MODE_OLDFILE|MODE_READWRITE	; BASIS clashes with AmigaDOS
				; 910911 jax

	lfa	2			; dpANS-2 FILE
	nfa	9,'READ-FIL','E'	; ( c-addr u1 fileid -- u2 ior)
readfil	move.l	tos,d1
	move.l	(dsp)+,d3
	move.l	(dsp)+,d2
	add.l	bp,d2
	callamy	Read,dos
	cmpi.l	#-1,d0
	beq.s	_1readf
	move.l	tos,(dsp)
	moveq.l	#0,tos
	tonext
_1readf	adda.l	#4,dsp			; two items when IoErr returns
	callamy	IoErr,dos		; returns in TOS
	tonext				; 910811 jax

; Seek backwards in file from current position for READ-LINE
	headerless
mfseek					; ( bytes fh --)
	pop	d1
	pop	d2
	neg.l	d2
	move.l	#OFFSET_CURRENT,d3
	callamy	Seek,dos
	pop	d0
	tonext

	lfa	2			; dpANS-2 FILE
	nfa	9,'READ-LIN','E'	; ( c-addr u1 fileid -- u2 flag ior)
readlin	nest
	kcomp	dup			; -- c-a u1 fileid
	kcomp	filsiz			; -- c-a u1 fid ud ior
	abortq	"Error, FILE-SIZE."	; -- c-a u1 fid ud
	kcomp	drop			; -- c-a u1 fid u
	kcomp	over			; -- c-a u1 fid u fid
	kcomp	filpos			; -- c-a u1 fid u ud ior
_dummy0	abortq	"Error, FILE-POSITION."	; two ABORTQ macros need label separator
	kcomp	drop			; -- c-a u1 fid u1 u2
	kcomp	twodup			; -- c-a u1 fid u1 u2 u1 u2
	kcomp	lesst			; -- c-a u1 fid u1 u2 flag
	kcomp	negrot			; -- c-a u1 fid flag u1 u2
	kcomp	equal			; -- c-a u1 fid flag1 flag2
	kcomp	b_or			; is FILEPOS .equ. or .gt. FILESIZE?
	compif	_1readl			; -- c-a u1 fid
	kcomp	drop			; -- c-a u1
	kcomp	twodrop			; --
	kcomp	false			; -- 0
	kcomp	dup			; -- 0 0
	kcomp	dup			; -- 0 0 0
	kcomp	pexit
_1readl	kcomp	over			; -- c-a u1 fh u1
	literal	tickreadbuff		; -- c-a u1 fh u1 a-addr
	kcomp	fetch			; -- c-a u1 fh u1 x
	kcomp	qdup			; -- c-a u1 fh u1 [ [ 0 ] | [ x x ] ]
	kcomp	zeroeq			; -- c-a u1 fh u1 [ [ true ] | [ x 0 ] ]
	abortq	"No File Buffer."
	kcomp	abstod			; -- c-a u1 fh u1 a-a
	kcomp	swap			; -- c-a u1 fh a-a u1
	literal	readbuffsize		; -- c-a u1 fh a-a u1 n
	kcomp	min			; -- c-a u1 fh a-a u1'
	kcomp	rot			; -- c-a u1 a-a u1' fh
	kcomp	dupto_r			; -- c-a u1 a-a u1' fh	R: -- fh
	kcomp	readfil			; -- c-a u1 u2 ior	R: -- fh
	kcomp	dup			; -- c-a u1 u2 ior ior	R: -- fh
	compif	_2readl			; -- c-a u1 u2 ior	R: -- fh
	kcomp	r_frodr			; -- c-a u1 u2 ior	R: --
	kcomp	twoswa			; -- u2 ior c-a u1
	kcomp	twodrop			; -- u2 ior
	kcomp	false			; -- u2 ior 0
	kcomp	swap			; -- u2 0 ior
	kcomp	pexit
_2readl	kcomp	pto_r		; -- c-a u1 u2		R: -- fh ior
	literal	tickreadbuff	; -- c-a u1 u2 a-addr	R: -- fh ior
	kcomp	fetch		; -- c-a u1 u2 abs-addr	R: -- fh ior
	kcomp	abstod		; -- c-a u1 u2 a-addr	R: -- fh ior
	kcomp	swap		; -- c-a u1 a-addr u2	R: -- fh ior
	kcomp	twodup		; -- c-a u1 a u2 a u2	R: -- fh ior
	literal	eol		; -- c-a u1 a u2 a u2 eol	R: -- fh ior
	kcomp	scan		; -- c-a1 u1 a u2 c-a2 u3	R: -- fh ior
	kcomp	nip		; -- c-a1 u1 a u2 u3	R: -- fh ior
	kcomp	qdup		; -- c-a1 u1 a u2 [u3 u3] | [0]	R: -- fh ior
	compif	_9readl		; -- c-a1 u1 a u2 u3		R: -- fh ior
	kcomp	dup		; -- c-a1 u1 a u2 u3 u3		R: -- fh ior
	literal	2		; -- c-a1 u1 a u2 u3 u3 2	R: -- fh ior
	kcomp	minus		; -- c-a1 u1 a u2 u3 u4		R: -- fh ior
	kcomp	ptworfr         ; -- c-a1 u1 a u2 u3 u4	fh ior	R: --
	kcomp	pto_r		; -- c-a1 u1 a u2 u3 u4	fh 	R: -- ior
	kcomp	mfseek		; -- c-a1 u1 a u2 u3	R: -- ior
	kcomp	onemi		; -- c-a1 u1 a u2 u3'	R: -- ior
	kcomp	minus		; -- c-a1 u1 a u2	R: -- ior
	compelse	_8readl
_9readl				; -- c-a1 u1 a u2	R: -- fh ior
	kcomp	ptworfr		; -- c-a1 u1 a u2 fh ior	R: --
	kcomp	nip		; -- c-a1 u1 a u2 ior
	kcomp	pto_r		; -- c-a1 u1 a u2	R: -- ior
_8readl	kcomp	rot		; -- c-a1 a u2 u1	R: -- ior
	kcomp	drop		; -- c-a1 a u2		R: -- ior
	kcomp	rot		; -- a u2 c-a1		R: -- ior
	kcomp	swap		; -- a c-a1 u2		R: -- ior
	kcomp	dupto_r		; -- a c-a1 u2		R: -- ior u
	kcomp	amov		; --			R: -- ior u
	kcomp	pr_from		; -- u			R: -- ior
	kcomp	true		; -- u true		R: -- ior
	kcomp	pr_from		; -- u true ior		R: --
	kcomp	unnest		; 910829 jax

	lfa	2			; dpANS-2 FILE
	nfa	15,'REPOSITION-FIL','E'	; ( ud fileid -- ior)
repofil	pop	d1			; fileid
	move.l	(dsp)+,d2		; Amiga doesn't support double filepos
	popdsp				; ( --)
	move.l	#OFFSET_BEGINNING,d3	; mode
	callamy	Seek,dos		; AmigaDOS, return in TOS ( -- ior)
	tonext				; 910820 jax

***!!!***
	lfa	2			; dpANS-2 FILE
	nfa	11,'RESIZE-FIL','E'	; ( ud fileid -- ior)
resifil	nest
	kcomp	drop
	kcomp	twodrop
	kcomp	true
	kcomp	unnest
***!!!***

	lfa	3			; dpANS-2 FILE
	nfa	11,'SOURCE-FIL','E'	; ( -- a-addr)
sourcfi	docreat sourcefile		; 910911 jax

	lfa	3		; dpANS-2 FILE
	nfa	3,'W/','O'	; ( -- x)
wslasho	doconst	MODE_OLDFILE|MODE_READWRITE	; BASIS clashes with AmigaDOS
				; 910911 jax

	lfa	3			; dpANS-2 FILE
	nfa	10,'WRITE-FIL','E'	; ( c-addr u1 fileid -- ior)
writfil	move.l	tos,d1		; fh
	move.l	(dsp)+,d3	; length
	move.l	(dsp)+,d2	; buffer DSeg addr
	add.l	bp,d2		; convert to abs addr
	popdsp			; clear stack
	callamy	Write,dos	; push #bytes-written or -1 for err
	tonext			; 910728 jax

_2writl	dc.b	eol		; an LF for WRITE-LINE
	cnop	2

	lfa	3			; dpANS-2 FILE
	nfa	10,'WRITE-LIN','E'	; ( c-addr u1 fileid -- ior)
writlin nest
	kcomp	dupto_r		; -- c-a u1 fh		R: -- fh
	kcomp	writfil		; -- ior		R: -- fh
	kcomp	dup		; -- ior ior		R: -- fh
	kcomp	true		; -- ior ior true	R: -- fh
	kcomp	equal		; -- ior flag		R: -- fh
	compif	_1writl		; -- ior		R: -- fh
	kcomp	r_frodr		; -- ior
	kcomp	pexit
_1writl kcomp	drop		; --			R: -- fh
	literal	_2writl		; -- a-addr		R: -- fh
	kcomp	abstod		; -- DSeg-addr		R: -- fh
	literal	1		; -- DSeg-addr 1	R: -- fh
	kcomp	pr_from		; -- DSeg-addr 1 fh	R: --
	kcomp	writfil		; -- ior
	kcomp	unnest		; 910901 jax

;---------------------------------------------------------------;
;			BLOCK Word Set				;
;---------------------------------------------------------------;

; -- BLOCK etc. is a bit hacked here presuming only two BLOCK buffs,
; -- it's sorta hardwired in in places.

***!!!*** This is all going to have to be re-examined in light of
***!!!*** 11.1.2180 ... a buffer will have to hold the BLOCK-FID of
***!!!*** the file the given BLOCK came from.

	lfa	2			; dpANS-2 BLOCK
	nfa	5,'BLOC','K'		; ( u -- a-addr)
block	nest
	literal	tickblockbuff	; -- u a-addr
	kcomp	fetch		; -- u abs-a-addr
	kcomp	abstod		; -- u a-addr
	literal	numblockbuffs	; -- u a-addr n
	literal	0		; -- u a-addr n 0
	compdo	_2block		; -- u
_0block	kcomp	twodup		; -- u a-addr u a-addr
	kcomp	fetch		; -- u a-addr u d|b
	literal	~dirtybit	; -- u a-addr u d|b mask
	kcomp	b_and		; -- u a-addr u blocknum
	kcomp	equal		; -- u a-addr flag
	compif	_1block		; -- u a-addr
	kcomp	drop		; -- u
	kcomp	buffer		; -- a-addr
	kcomp	pkunloo
	kcomp	pexit
_1block	literal blocksize	; -- u a-addr n
	kcomp	plus		; -- u a-addr'
	comploop	_0block
_2block	kcomp	drop		; -- u
	kcomp	dup		; -- u u
	kcomp	buffer		; -- u a-addr
	kcomp	swap		; -- a-addr u
	kcomp	bslbuf		; -- a-addr u n
	kcomp	umstar		; -- a-addr d
	kcomp	blockfi		; -- a-addr1 d a-addr2
	kcomp	fetch		; -- a-addr d x
	kcomp	repofil		; -- a-addr ior
	kcomp	drop		; -- a-addr
_3block	kcomp	dup		; -- a-addr a-addr
	kcomp	bslbuf		; -- a-addr a-addr n
	kcomp	blockfi		; -- a-addr1 a-addr1 n a-addr2
	kcomp	fetch		; -- a-addr a-addr n x
	kcomp	readfil		; -- a-addr ior
	abortq	"Error reading BLOCK."	; -- a-addr u
	kcomp	drop		; -- a-addr
	kcomp	unnest		; 910820 jax

	lfa	i0
	nfa	8,'(BUFFER',')'
		; ( blocknum bufnum -- addr update-flag same-flag)
pbuffe	nest
	literal	blocksize	; -- bln bun n
	kcomp	star		; -- bln n'
	literal	tickblockbuff	; -- bln n' a-addr
	kcomp	fetch		; -- bln n' abs-a-addr'
	kcomp	abstod		; -- bln n' a-addr'
	kcomp	plus		; -- bln a-addr''
	kcomp	dupto_r		; -- bln a-addr''	R: -- a-addr
	kcomp	fetch		; -- bln mask		R: -- a-addr
	kcomp	tuck		; -- mask bln mask	R: -- a-addr
	literal	~dirtybit	; -- mask1 bln mask1 mask2	R: -- a-addr
	kcomp	b_and		; -- mask bln mask'	R: -- a-addr
	kcomp	equal		; -- mask same-flag	R: -- a-addr
	kcomp	swap		; -- same-flag mask	R: -- a-addr
	literal	dirtybit	; -- same-flag mask1 mask2	R: -- a-addr
	kcomp	b_and		; -- same-flag update-flag
	kcomp	zerone		; -- same-flag update-flag	R: -- a-addr
	kcomp	swap		; -- update-flag same-flag	R: -- a-addr
	kcomp	pr_from		; -- update-flag same-flag a-addr	R: --
	kcomp	negrot		; -- a-addr update-flag same-flag
	kcomp	unnest

	lfa	i0
	nfa	6,'(BUFF',')'	; (u a-addr1 -- a-addr2)
pbu	nest
	kcomp	tuck		; -- a u a
	kcomp	store		; -- a
	literal	blockoversize	; -- a n
	kcomp	plus		; -- a
	kcomp	unnest

	lfa	2		; dpANS-2 BLOCK
	nfa	6,'BUFFE','R'	; ( u -- a-addr)
buffer	nest
	literal	lastblk		; -- u a
	kcomp	fetch		; -- u n
	literal	1		; -- u n 1
	kcomp	b_and		; -- u n'
	kcomp	twodup		; -- u n' u n'
	kcomp	pbuffe		; -- u n' a f1 f2
	compif	_9buffe		; -- u n' a f1
_0buffe	kcomp	drop		; -- u n' a
	kcomp	swap		; -- u a n'
	literal	lastblk		; -- u a n' a-addr
	kcomp	store		; -- u a
	kcomp	nip		; -- a
	literal	blockoversize	; -- a n
	kcomp	plus		; -- a-addr
	kcomp	pexit		; -- a-addr
_9buffe	kcomp	twodrop		; -- u n'
	literal	1		; -- u n' n1
	kcomp	b_xor		; -- u n''
	kcomp	dup		; -- u n'' n''
	literal	lastblk		; -- u n'' n'' a-addr
	kcomp	store		; -- u n''
	kcomp	underdu		; -- u u n''
	kcomp	pbuffe		; -- u a f1 f2
	compif	_7buffe		; -- u a f1
	kcomp	drop		; -- u a
	kcomp	nip		; -- a
	literal	blockoversize	; -- a n
	kcomp	plus		; -- a'
	kcomp	pexit		; -- a'
_7buffe compif	_8buffe		; -- u a
	kcomp	dup		; -- u a a
	kcomp	fetch		; -- u1 a u2
	kcomp	over		; -- u1 a u2 a
	kcomp	psaveb		; -- u a
	kcomp	pbu		; -- a-addr
	kcomp	pexit		; -- a-addr
_8buffe	kcomp	pbu		; -- a-addr
	kcomp	unnest		; 910818 jax

	lfa	2		; dpANS-2 BLOCK
	nfa	5,'FLUS','H'	; ( --)
flush	nest
	kcomp	savebuf
	kcomp	emptbuf
	kcomp	unnest		; 910825 jax

	lfa	i0
	nfa	11,'SAVE-BUFFE','R'	; ( u a --)
psaveb	nest
	kcomp	tuck		; -- a u a
	kcomp	dup		; -- a u a a
	kcomp	fetch		; -- a u a mask
	literal	~dirtybit	; -- a u a mask1 mask2
	kcomp	b_and		; -- a u a mask1'
	kcomp	swap		; -- a u mask1' a
	kcomp	store		; -- a u
	literal	rawblocksize	; -- a u n
	kcomp	umstar		; -- a d
	kcomp	blockfi		; -- a d a-addr
	kcomp	fetch		; -- a d x
	kcomp	repofil		; -- a ior
	kcomp	drop		; --  ,doesn't mean much here
_0psavb	literal	blockoversize	; -- a n
	kcomp	plus		; -- a-addr
	literal	rawblocksize	; -- a-addr n
	kcomp	blockfi		; -- a-addr1 n a-addr2
	kcomp	fetch		; -- a-addr n x
	kcomp	writfil		; -- ior
	kcomp	true		; -- ior flag
	kcomp	equal		; -- flag
	abortq	"Error, BLOCK file write."
	kcomp	unnest

	lfa	3			; dpANS-2 BLOCK
	nfa	12,'SAVE-BUFFER','S'	; ( --)
savebuf	nest
	literal	tickblockbuff	; -- a-addr
	kcomp	fetch		; -- abs-a-addr
	kcomp	abstod		; -- a-addr
	literal	numblockbuffs	; -- a-addr n
	literal	0		; -- a-addr n 0
	compdo	_3saveb		; -- a-addr
_0saveb	kcomp	dup		; -- addr addr
	kcomp	fetch		; -- addr dirty|blocknum
	kcomp	dup		; -- addr dirty|blocknum dirty|blocknum
	literal	dirtybit	; -- a d|b d|b mask
	kcomp	b_and		; -- a d|b flag
	compif	_1saveb		; -- a d|b
	literal	~dirtybit
	kcomp	b_and		; -- a u
	kcomp	over		; -- a u a
	kcomp	psaveb		; -- a
	compelse	_2saveb
_1saveb	kcomp	drop		; -- a
_2saveb	literal	blocksize	; -- a n
	kcomp	plus		; -- a'
	comploop	_0saveb	; -- a
_3saveb	kcomp	drop		; --
	kcomp	unnest		; 910825 jax

	lfa	1		; dpANS-2 BLOCK
	nfa	6,'UPDAT','E'	; ( --)
update	nest
	literal	lastblk		; -- a-addr
	kcomp	fetch		; -- n
	literal	numblockbuffs	; -- n1 n2
	kcomp	mod		; -- n
	literal	blocksize	; -- n1 n2
	kcomp	star		; -- n
	literal	tickblockbuff	; -- n a-addr
	kcomp	fetch		; -- n abs-a-addr
	kcomp	abstod		; -- n a-addr
	kcomp	plus		; -- a-addr
	kcomp	dup		; -- a-addr a-addr
	kcomp	fetch		; -- a-addr d|b
	literal	dirtybit	; -- a-addr d|b mask
	kcomp	b_or		; -- a-addr d|b
	kcomp	swap		; -- d|b a-addr
	kcomp	store		; --
	kcomp	unnest		; 910818 jax

;---------------------------------------------------------------;
;		    BLOCK Extensions Word Set			;
;---------------------------------------------------------------;

	lfa	1			; dpANS-2 BLOCK EXT
	nfa	13,'EMPTY-BUFFER','S'	; ( --)
emptbuf	nest
	literal	tickblockbuff	; -- a-addr
	kcomp	fetch		; -- abs-a-addr
	kcomp	abstod		; -- a-addr
	kcomp	dup		; -- a-addr a-addr
	literal	blockbuffsize	; -- a-addr a-addr n
	kcomp	blank		; -- a-addr
	literal	numblockbuffs	; -- a-addr n
	literal	0		; -- a-addr n 0
	compdo	_1mtbu		; -- a-addr
_0mtbu	literal	~dirtybit	; -- a-addr n
	kcomp	over		; -- a-addr n a-addr
	kcomp	store		; -- a-addr
	literal	blocksize	; -- a-addr n
	kcomp	plus		; -- a-addr'
	comploop	_0mtbu
_1mtbu	kcomp	drop		; --
	kcomp	unnest		; 910818 jax

	lfa	0		; dpANS-2 BLOCK EXT
	nfa	4,'LIS','T'	; ( u --)
list	nest
	kcomp	dup		; -- u u
	kcomp	dup		; -- u u u
	kcomp	kscr		; -- u u u a-addr
	kcomp	store		; -- u u
	kcomp	cr		; -- u u
	dotq	"Screen # "	; -- u u
	kcomp	dot		; -- u
	kcomp	cr		; -- u
	kcomp	block		; -- a-addr
	kcomp	lslscr		; -- a-addr n
	literal	0		; -- a-addr n 0
	compdo	_1list		; -- a-addr
_0list	kcomp	dodoi		; -- a-addr n
	kcomp	dup		; -- a-addr n n
	literal	2		; -- a-addr n n 2
	kcomp	dotr		; -- a-addr n
	kcomp	space		; -- a-addr n
	kcomp	csll		; -- a-addr n1 n2
	kcomp	star		; -- a-addr n
	kcomp	over		; -- a-addr n a-addr
	kcomp	plus		; -- a-addr1 a-addr2
	kcomp	csll		; -- a-addr1 a-addr2 n
	kcomp	type		; -- a-addr
	kcomp	cr		; -- a-addr
	comploop	_0list	; -- a-addr
_1list	kcomp	drop		; --
	kcomp	unnest		; 910820 jax

	lfa	0		; dpANS-2 BLOCK EXT
	nfa	4,'LOA','D'	; ( i*x u -- j*x)
load	nest
	kcomp	toi		; -- u a-addr
	kcomp	fetch		; -- u n
	kcomp	kblk		; -- u n a-addr
	kcomp	fetch		; -- u n1 n2
	kcomp	ptwotor		; -- u			R: -- n1 n2
	kcomp	sourcfi		; -- u a-addr		R: -- n1 n2
	kcomp	fetch		; -- u x		R: -- n1 n2
	kcomp	tickti		; -- u x a-addr		R: -- n1 n2
	kcomp	fetch		; -- u x c-addr		R: -- n1 n2
	kcomp	ptwotor		; -- u			R: -- n1 n2 x c-addr
	kcomp	kblk		; -- u a-addr		R: -- n1 n2 x c-addr
	kcomp	store		; --			R: -- n1 n2 x c-addr
	kcomp	toi		; -- a-addr		R: -- n1 n2 x c-addr
	kcomp	off		; --			R: -- n1 n2 x c-addr
	kcomp	kendq		; -- a-addr		R: -- n1 n2 x c-addr
	kcomp	fetch		; -- flag		R: -- n1 n2 x c-addr
	kcomp	pto_r		; --			R: -- n1 n2 x c-addr f
	kcomp	kendq		; -- a-addr		R: -- n1 n2 x c-addr f
	kcomp	off		; --			R: -- n1 n2 x c-addr f
	kcomp	interp		; --			R: -- n1 n2 x c-addr f
	kcomp	pr_from		; -- flag		R: -- n1 n2 x c-addr
	kcomp	kendq		; -- flag a-addr	R: -- n1 n2 x c-addr
	kcomp	store		; --			R: -- n1 n2 x c-addr
	kcomp	ptworfr		; -- x c-addr		R: -- n1 n2
	kcomp	tickti		; -- x c-addr a-addr	R: -- n1 n2
	kcomp	store		; -- x			R: -- n1 n2
	kcomp	sourcfi		; -- x a-addr		R: -- n1 n2
	kcomp	store		; --			R: -- n1 n2
	kcomp	ptworfr		; -- n1 n2		R: --
	kcomp	kblk		; -- n1 n2 a-addr
	kcomp	store		; -- n
	kcomp	toi		; -- n a-addr
	kcomp	store		; --
	kcomp	unnest		; 910915 jax

	lfa	3		; dpANS-2 BLOCK EXT
	nfa	3,'SC','R'	; ( -- a-addr)
kscr	docreat	scr		; 910915 jax

	lfa	0		; dpANS-2 BLOCK EXT
	nfa	4,'THR','U'	; ( u1 u2 --)
thru	nest
	kcomp	onepl
	kcomp	swap
	compdo	_1thru
_0thru	kcomp	dodoi
	kcomp	load
	comploop	_0thru
_1thru	kcomp	unnest		; 910915 jax

;-----------------------------------------------------------------------;
;			FLOATing Point Word Set				;
;-----------------------------------------------------------------------;

;-----------------------------------------------------------------------;
;			Programming Tools Word Set			;
;-----------------------------------------------------------------------;

;-----------------------------------------------------------------------;
;			ERROR Handling Word Set				;
;-----------------------------------------------------------------------;

	lfa	i3
	nfa	8,'''CATCHE','R'	; ( -- a-addr)
catche	docreat	catcher		; initialized at powerup to (@RP0)-1cell

	lfa	3		; dpANS-2 ERROR
	nfa	5,'CATC','H'	; ( i*x xt -- j*x 0 | i*x n)
catch	nest
	kcomp	spfet
	kcomp	cellpl		; disregard execution token
	kcomp	pto_r		; save current stack pointer
	kcomp	catche
	kcomp	fetch
	kcomp	pto_r		; save last CATCH frame
	kcomp	rpfet
	kcomp	catche
	kcomp	store		; establish current CATCH frame
	kcomp	execute	; having saved the SP, this doesn't shorten the stack
			; if THROW is invoked, so stack is thus the right depth
			; for THROW's error return.
	kcomp	pr_from	; no THROW
	kcomp	catche
	kcomp	store	; restore previous CATCH frame
	kcomp	pr_from
	kcomp	drop	; discard saved stack pointer
	kcomp	false	; return flag indicating no THROW
	kcomp	unnest	; 910915 jax

	lfa	0		; dpANS-2 ERROR
	nfa	5,'THRO','W'	; ( k*x n -- k*x | i*x n)
throw	nest
	kcomp	catche		; no CATCH frame?
	kcomp	fetch
	kcomp	zeroeq
	kcomp	abort		; then abort
	kcomp	qdup		; error return?
	compif	_1throw		; yes
	kcomp	catche
	kcomp	fetch
	kcomp	rpsto		; restore RP
	kcomp	pr_from
	kcomp	catche
	kcomp	store		; restore previous CATCH frame
	kcomp	pr_from		; -- throw-arg @sp
	kcomp	swap		; -- @sp throw-arg
	kcomp	pto_r		; -- @sp		R: -- ip throw-arg
	kcomp	spsto		; restore SP
	kcomp	pr_from		; get back input to THROW
	kcomp	nip		; and discard meaningless pushed TOS contents
	kcomp	pr_from		; discard middle of CATCHER from Ret Stack
	kcomp	drop		; --
_1throw	kcomp	unnest		; no error return, continue
				; 910915 jax

;-----------------------------------------------------------------------;
; Error return is in TOS. Restored stack was left one deep by the cfa	;
; which was waiting to EXECUTE in CATCH at the time stack was saved.	;
;-----------------------------------------------------------------------;

;-------------------------------------------------------;
;		SEARCH Order Word Set			;
;-------------------------------------------------------;

	lfa	0			; dpANS-2 SEARCH
	nfa	11,'DEFINITION','S'	; ( --)
definit	movea.l	#contextarray,a0
	movea.l	#current,a1
	move.l	0(bp,a0.l),0(bp,a1.l)
	tonext				; 910719 jax

	lfa	2			; dpANS-2 SEARCH
	nfa	14,'FORTH-WORDLIS','T'	; ( -- wid)
forwdls	doconst	forthvoc		; 910719 jax

	lfa	1
	nfa	20,'IMPLEMENTOR-WORDLIS','T'	; ( -- wid)
impwdls	doconst	impvoc

	lfa	3			; dpANS-2 SEARCH
	nfa	11,'GET-CURREN','T'	; ( -- wid)
getcurr	push	#current
	move.l	0(bp,tos.l),tos
	tonext				; 910719 jax

	lfa	3			; dpANS-2 SEARCH
	nfa	9,'GET-ORDE','R'	; ( -- wid1 ... widn n)
getorde	pshdsp
	moveq.l	#0,tos			; count of wids
	move.l	#contextarray,a0	; array of wids in search order
	adda.l	bp,a0			; abs addr
	moveq.l	#numvocs,d1		; loop index
	bra.s	_1getor			; enter loop
_0getor	move.l	(a0)+,d0		; count valid wordlist entries
_1getor	dbeq.w	d1,_0getor		; exit if a null is found
	subi.l	#(numvocs-1),d1		; calc number of wordlists found
	neg.l	d1			; finish calc
	tst.l	d0			; did we exit loop because of a null?
	bne.s	_4getor			; no, go get wids
	suba.l	#cellsize,a0		; yes, back up address pointer
	bge.s	_4getor			; and go get wids if any wids in order
	tonext				; exit if none
_3getor	move.l	-(a0),-(dsp)		; push a wid on stack
	addq.l	#1,tos			; increment count of wids
_4getor	dbra.w	d1,_3getor
	tonext				; 910719 jax

	lfa	3			; dpANS-2 SEARCH
	nfa	15,'SEARCH-WORDLIS','T'	; ( c-addr u wid -- 0 | xt 1 | xt -1)
srchwl	nest
	literal	2		; -- c-addr u wid 2
	kcomp	pick		; -- c-addr u wid c-addr
	kcomp	onemi		; -- c-addr u wid $addr
	kcomp	hash		; -- c-addr u wid n
	kcomp	cells		; -- c-addr u wid w
	kcomp	plus		; -- c-addr u thread
	kcomp	negrot		; -- thread addr ct
	kcomp	twodup		; -- thread addr ct addr ct
	kcomp	ptwotor		; -- thread addr ct		R: -- adr ct
	kcomp	rot		; -- addr ct thread		R: -- adr ct
_1srchw	kcomp	fetch		; -- addr ct link-tok		R: -- adr ct
	kcomp	dup		; -- addr ct link-tok link-tok	R: -- adr ct
	kcomp	pto_r		; -- addr ct link-tok		R: -- a c lt
	kcomp	ltodat		; -- addr ct link-addr		R: -- a c lt
	kcomp	ltonam		; -- addr ct name-addr		R: -- a c lt
	kcomp	count		; -- addr ct name-addr ct	R: -- a c lt
	kcomp	ncompar		; -- cfa t|f			R: -- a c lt
	compif	_2srchw		; -- cfa , IF			R: -- a c lt
	kcomp	pr_from		; -- cfa link-tok		R: -- a c
	kcomp	qinkern		; -- tok link-tok		R: -- a c
	kcomp	ltodat		; -- tok link-addr		R: -- a c
	kcomp	qimmed		; -- tok 1|-1			R: -- a c
	kcomp	ptworfr		; -- tok 1|-1 n n		R: --
	kcomp	twodrop		; -- tok 1|-1
	kcomp	pexit		; -- tok 1|-1 , quick getaway
_2srchw				; -- cfa , THEN			R: -- a c lt
	kcomp	drop		; --				R: -- a c lt
	kcomp	pr_from		; -- link-tok			R: -- a c
	kcomp	ltodat		; -- link-addr			R: -- a c
	kcomp	dup		; -- link-addr l-a		R: -- a c
	kcomp	fetch		; -- l-a link-tok|0		R: -- a c
	compif	_3srchw		; -- l-a, IF a valid link	R: -- a c
	kcomp	ptworfr		; -- l-a a c			R: --
	kcomp	twodup		; -- l-a a c a c
	kcomp	ptwotor		; -- l-a a c			R: -- a c
	kcomp	rot		; -- a c l-a			R: -- a c
	compelse	_1srchw	; -- a c l-a ,AGAIN		R: -- a c
_3srchw				; -- l-a ,no more links		R: -- a c
	kcomp	drop		; --				R: -- a c
	kcomp	ptworfr		; -- addr ct			R: --
	kcomp	drop		; -- addr
	kcomp	drop		; --
	kcomp	false		; -- 0
	kcomp	unnest		; -- 0	; 910719 jax

	lfa	3			; dpANS-2 SEARCH
	nfa	11,'SET-CURREN','T'	; ( wid --)
setcurr	move.l	#current,a0
	pop	<0(bp,a0.l)>
	tonext				; 910719 jax

;-----------------------------------------------------------------------;
; And *this* l'il devil SET-ORDER should check stack depth first.	;
;-----------------------------------------------------------------------;

	lfa	3			; dpANS-2 SEARCH
	nfa	9,'SET-ORDE','R'	; ( wid1 ... widn n --)
setorde	move.l	#contextarray,a0
	adda.l	bp,a0
	move.l	#numvocs,d0
	bra.s	2$
1$	clr.l	(a0)+			; erase order
2$	dbra.s	d0,1$
	tst.l	tos
	bgt.s	_9setor			; positive count
	beq.s	3$			; zero count, just exit
	move.l	#contextarray,a0	; on any negative count, ONLY FORTH
	adda.l	bp,a0
	move.l	#forthvoc,(a0)
3$	popdsp
	tonext
_9setor	cmpi.l	#numvocs,tos
	ble.s	_0setor		; an OK number of vocs in TOS
	move.l	#numvocs,tos	; too many, stuff max vocs in TOS
_0setor	move.l	#contextarray,a0
	adda.l	bp,a0
	bra.s	_2setor
_1setor	move.l	(dsp)+,(a0)+
_2setor	dbra.w	tos,_1setor
	popdsp
_3setor	tonext				; 910726 jax

	lfa	3			; dpANS-2 SEARCH
	nfa	8,'WORDLIS','T'		; ( -- wid)
wordlis	nest
	kcomp	align
	kcomp	here		; -- 'new-wl
	literal	vocwidth-(2*cellsize)	; -- 'nw n  , sans voc-link & backptr
	kcomp	allot		; -- 'nw
	kcomp	here		; -- 'nw 'new-voc-link
	literal	voclink		; -- 'nw 'nvl 'voc-link
	kcomp	dup		; -- 'nw 'nvl 'vl 'vl
	kcomp	fetch		; -- 'nw 'nvl 'vl vl
	kcomp	comma		; -- 'nw 'nvl 'vl   , compile voc-link
	kcomp	store		; -- 'nw
	kcomp	false		; -- 'nw 0 ,NULL name backpointer
	kcomp	comma		; -- 'nw
	kcomp	unnest		; 910719 jax

;-----------------------------------------------------------------------;
;		SEARCH Order Extensions Word Set			;
;-----------------------------------------------------------------------;

	lfa	1		; dpANS-2 SEARCH EXT
	nfa	4,'ALS','O'	; ( --)
also	nest
	kcomp	context
	kcomp	dup
	kcomp	cellpl
	literal	((numvocs-1)*cellsize)
	kcomp	amov
	kcomp	unnest		; 910719 jax

	lfa	2		; dpANS-2 SEARCH EXT
fthnam	nfa	5,'FORT','H'	; ( --)
forth	dovoc	forthvoc	; 910719 jax

	lfa	1
impnam	nfa	11,'IMPLEMENTO','R'	; ( --)
imp	dovoc	impvoc

	lfa	3		; dpANS-2 SEARCH EXT
	nfa	4,'ONL','Y'	; ( --)
only	nest
	kcomp	context
	literal (numvocs*cellsize)
	kcomp	erase
	kcomp	forth
	kcomp	unnest		; 910719 jax

	lfa	3		; dpANS-2 SEARCH EXT
	nfa	5,'ORDE','R'	; ( --)
order	nest
	dotq	"Order:"
	kcomp	context
_0order	kcomp	dup		; begin
	kcomp	fetch
	compif	_1order		; while non-zero in search order
	kcomp	dup
	kcomp	fetch
	kcomp	dup
	literal	12
	kcomp	udotr
	kcomp	space
	literal	((numthreads*cellsize)+cellsize)
	kcomp	plus
	kcomp	fetch
	kcomp	qdup
	compif	_8order
	kcomp	dotname
	kcomp	space
	compelse	_9order
_8order	dotq	"*wordlist* "
_9order	kcomp	cellpl
	compelse	_0order	; repeat
_1order	kcomp	drop
	kcomp	cr
	dotq	"Current:"
	kcomp	getcurr
	kcomp	dup
	literal	10
	kcomp	udotr
	kcomp	space
	literal	((numthreads*cellsize)+cellsize)
	kcomp	plus
	kcomp	fetch
	kcomp	qdup
	compif	_7order
	kcomp	dotname
	kcomp	space
	compelse	_6order
_7order	dotq	"*wordlist* "
_6order	kcomp	unnest		; 910811 jax

	lfa	0		; dpANS-2 SEARCH EXT
	nfa	8,'PREVIOU','S'	; ( --)
previou	nest
	kcomp	context
	kcomp	dup
	kcomp	cellpl
	kcomp	swap
	literal	((numvocs-1)*cellsize)
	kcomp	amov
	kcomp	context
	literal	((numvocs-1)*cellsize)
	kcomp	plus
	kcomp	off
	kcomp	unnest		; 910719 jax

;---------------------------------------------------------------;
;			STRING Word Set				;
;---------------------------------------------------------------;

***!!!*** Optimize (see startup code for stripping blanks from command line)
	lfa	1			; dpANS-2 STRING
	nfa	9,'-TRAILIN','G'	; ( c-addr u1 -- c-addr u2)
mtrail	move.l	(dsp),a0	; string addr to A0
	adda.l	bp,a0		; this is data segment access
	adda.l	tos,a0		; points one byte past end of string
	moveq.l	#$20,d0		; we are looking to rid ourselves of blanks
	moveq.l	#0,d1		; to set zero flag
	bra.s	2$
1$	cmp.b	-(a0),d0	; a BLANK?
2$	dbne	tos,1$		; +n1 limited to $FFFF, count string to $100
	addq.l	#1,tos		; make count one-based
	tonext			; 910707 jax

	lfa	3			; dpANS-2 STRING
	nfa	7,<'/STRIN'>,'G'	; ( c-addr1 u1 n --- c-addr2 u2)
slstr	add.l	tos,4(dsp)
	neg.l	tos
	add.l	(dsp)+,tos
	tonext			; 910707 jax

	lfa	2		; dpANS-2 STRING
	nfa	5,'BLAN','K'	; ( c-addr u ---)
blank	nest
	kcomp	bl
	kcomp	fill
	kcomp	unnest		; 910707 jax

* CMOVE & CMOVE> up in the CORE for now due to short branch convenience

	lfa	3		; dpANS-2 STRING
	nfa	7,'COMPAR','E'	; ( c-addr1 u1 c-addr2 u2 -- n)
compare	moveq.l	#0,d2		; marker indicates both strings equal
	move.l	(dsp)+,a0	; dest addr
	move.l	(dsp)+,d0	; count of source string
	move.l	(dsp)+,a1	; src addr
	adda.l	bp,a0		; this is a data segment access
	adda.l	bp,a1		; likewise
	cmp.l	d0,tos		; which string count is longer?
	beq.s	1$		; they're the same
	blt.s	9$		; D0 (string 1) is longer
	move.l	d0,tos		; TOS (string 2) longer, use shorter length
	move.l	#-1,d2		; prepare to indicate string 2 is greater
	bra.s	1$
9$	moveq.l	#1,d2		; prepare to indicate string 1 is greater
1$	bra.s	3$		; jump into loop
2$	cmp.b	(a1)+,(a0)+	; do byte comparison
3$	dbne	tos,2$		; exit if different
	beq.s	4$		; src = dest
	blt.s	5$		; src < dest
	moveq.l	#1,tos		; src > dest
	tonext			; onwards!
4$	move.l	d2,tos		; src = dest, which string longer, if any?
	tonext			; onwards!
5$	move.l	#-1,tos		; src < dest
	tonext			; 910707 jax

	lfa	3		; dpANS-2 STRING
	nfa	6,'SEARC','H'	; ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag)
search	move.l	(dsp)+,d3	; c-addr2
	move.l	(dsp)+,d1	; u1
	move.l	(dsp),d2	; c-addr1
	subi.l	#1,d2		; backup address one char for pre-increment loop
	cmp.l	tos,d1		; string 2 at least as long as string1?
	bge.s	1$		; continue if string 2 is at least as long as 1
	push	#0		; failure
	tonext
1$	add.l	bp,d3		; absolute address of string two
	move.l	d1,d0		; count of string one
	sub.l	tos,d0		; countdiff==times to search for string
2$	move.l	tos,d4		; length of search string
	movea.l	d3,a0		; get string2 address
	addi.l	#1,d2		; pre-increment string1 address
	lea.l	0(bp,d2.l),a1	; string1 address
	move.w	#4,ccr		; to set Z flag for 4$
	bra.s	4$
3$	cmp.b	(a0)+,(a1)+	; compare bytes
4$	dbne	d4,3$		; exit if mismatch
	cmpi.w	#-1,d4		; did we finish loop without mismatch
5$	dbeq	d0,2$		; exit on no mismatch
	bne.s	6$		; fell thru with mismatches, exit with failure
	move.l	d2,(dsp)	; c-addr3
	add.l	d0,tos		; u3
	move.l	tos,-(dsp)	; u3
	moveq.l	#-1,tos		; success
	tonext
6$	move.l	d1,-(dsp)	; u3 ( == u1)
	moveq.l	#0,tos		; failure
	tonext			; 910707 jax

;---------------------------------------------------------------;
;		STRING Extensions Word Set			;
;---------------------------------------------------------------;

	lfa	0		; dpANS-2 STRING EXT
	nfa	3,'LE','X'
; ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 c-addr1 u4 char true) if found
; ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 false) if not found
lex	move.l	(dsp)+,d3	; c-addr2
	move.l	(dsp),d1	; u1
	move.l	4(dsp),d2	; c-addr1
	tst.l	tos		; is u2 non-zero?
	bne.s	1$		; continue if string 2 has any chars
	moveq.l	#0,tos		; failure
	tonext
1$	add.l	bp,d3		; absolute address of string two
	lea.l	0(bp,d2.l),a0	; absolute address of string one
	moveq.l	#0,d4		; byte comparison register
2$	movea.l	d3,a1		; get string2 abs address
	move.b	(a0)+,d4	; next character to examine
	move.l	tos,d0		; u2, which is non-zero or we wouldn't be here
	bra.s	4$		; so we branch to 4$ with NZ set
3$	cmp.b	(a1)+,d4	; compare bytes
4$	dbeq	d0,3$		; exit if match
	cmpi.w	#-1,d0		; did we finish loop without a match
5$	dbne	d1,2$		; loop for u1 bytes, exit on match
	beq.s	6$		; fell thru without a match, exit with failure
	suba.l	bp,a0		; c-addr3
	move.l	a0,4(dsp)	; c-addr3
	suba.l	d2,a0		; u4
	suba.l	#1,a0		; so that char isn't included in count
	move.l	(dsp),d0	; get original count
	sub.l	a0,d0		; u3
	subq.l	#1,d0		; so that  char  isn't included in count
	move.l	d0,(dsp)	; u3
	move.l	d2,-(dsp)	; c-addr1
	move.l	a0,-(dsp)	; u4
	move.l	d4,-(dsp)	; char
	moveq.l	#-1,tos		; success
	tonext
6$	moveq.l	#0,tos		; failure
	tonext			; 910707 jax

;---------------------------------------------------------------;
;			LOCALS Word Set				;
;---------------------------------------------------------------;

;---------------------------------------------------------------;
;		MEMORY Allocation Word Set			;
;---------------------------------------------------------------;

	lfa	i1		; needed for Amiga memory
	nfa	8,'MEM-TYP','E'	; ( -- a-addr)
memtyp	docreat	memtype

	lfa	1		; dpANS-2 MEMORY
	nfa	8,'ALLOCAT','E'	; ( u -- a-addr ior)
allocat	move.l	#memtype,a0
	tst.l	0(bp,a0.l)	; has user specified requirements?
	beq.s	_1alloc		; no, branch away
	move.l	0(bp,a0.l),d1	; yes, requirements
	bra.s	_2alloc
_1alloc	move.l	#MEMF_CLEAR,d1	; requirements
_2alloc	move.l	tos,d0		; bytesize
	addq.l	#cellsize,d0	; extra cell for record of size
	callamy	AllocMem,exec	; get memory
	tst.l	d0		; return
	bne.s	_3alloc
	moveq.l	#-1,tos		; failure
	tonext
_3alloc	moveq.l	#0,tos		; success
	move.l	d0,a0		; move alloc to an address reg
	move.l	(dsp),(a0)	; original bytesize saved, store in first cell
	sub.l	bp,d0		; turn into data address
	addq.l	#cellsize,d0	; advance returned address past bytesize record
	move.l	d0,(dsp)	; return alloc address (plus one cell)
	tonext			; 910726 jax

	lfa	2		; dpANS-2 MEMORY
	nfa	4,'FRE','E'	; ( a-addr -- ior)
free	pop	a1		; nominal address of memory
	adda.l	bp,a1		; machine address
	suba.l	#cellsize,a1	; actual base address of mem alloc
	move.l	(a1),d0		; original (stored) bytesize requirment
	addq.l	#cellsize,d0	; to account for byte req. storage cell
	callamy	FreeMem,exec	; free
	moveq.l	#0,tos		; return success always
	tonext			; 910726 jax

	lfa	2		; dpANS-2 MEMORY
	nfa	6,'RESIZ','E'	; ( a-addr1 u -- a-addr2 ior)
resize	movea.l	(dsp),a1	; get address of already-allocated mem
	adda.l	bp,a1		; convert to AbsAddr
	move.l	-4(a1),d0	; get current size
	sub.l	d0,tos		; compare resize request with current allocation
	bne.s	1$
	moveq.l	#0,tos		; success, nothing has changed
	tonext
1$	blt.w	_1resiz		; TOS is a "shrink" request
	adda.l	d0,a1		; get address where expanded allocation starts
	move.l	tos,d0		; and this is the number of added bytes
	callamy	AllocAbs,exec	; attempt to expand exact allocation
	tst.l	d0		; success?
	beq.s	2$
	moveq.l	#0,tos		; indicate success
	move.l	(dsp)+,d0	; get back incremental allocation
	move.l	(dsp),a0	; get back original membase
	add.l	d0,-cellsize(bp,a0.l)	; increase alloc record by increment
	tonext
2$	popdsp			; discard return
	move.l	tos,d0		; get back incremental requirement
	movea.l	(dsp),a0	; get original allocation address
	add.l	-cellsize(bp,a0.l),d0	; total new replacement allocation needed
	addq.l	#cellsize,d0	; plus one cell for bytesize record
	move.l	#memtype,a0
	tst.l	0(bp,a0.l)	; has user specified requirements?
	beq.s	3$		; no, branch away
	move.l	0(bp,a0.l),d1	; yes, requirements
	bra.s	4$
3$	move.l	#MEMF_CLEAR,d1	; requirements
4$	callamy	AllocMem,exec	; get memory
	tst.l	d0		; return
	bne.s	_0resiz		; branch away on success
	popdsp			; discard incremental requirement
	moveq.l	#-1,tos		; indicate failure
	tonext
_0resiz	move.l	4(dsp),a1	; get back original membase
	adda.l	bp,a1		; convert to AbsAddr
	move.l	(dsp),d3	; get incremental alloc back
	add.l	-cellsize(a1),d3	; add byte record to incremental alloc
	move.l	d3,(dsp)	; store cumulative alloc
	move.l	tos,a0		; new memory region
	move.l	(dsp)+,(a0)+	; store new bytesize record in new alloc
	move.l	-cellsize(a1),d2	; count of bytes to move
	move.l	d2,d0		; extra copy for the FreeMem call later
	bra.s	6$
5$	move.b	(a1)+,(a0)+	; copy mem region
6$	dbra.s	d2,5$
	move.l	(dsp),a1	; get back original membase
	adda.l	bp,a1		; abs addr
	suba.l	#cellsize,a1	; point to byte allocation record
	addq.l	#cellsize,d0	; actual count of allocated mem
	callamy	FreeMem,exec	; free old allocation
	moveq.l	#0,tos		; indicate success
	move.l	(dsp)+,d0	; get new allocation abs address back
	sub.l	bp,d0		; convert to DSeg address
	addq.l	#cellsize,d0	; and advance one cell for allocation record
	move.l	d0,(dsp)	; return new address to user
	tonext
_1resiz	add.l	d0,tos		; get back new requirement
	move.l	tos,d0		; byte size
	addq.l	#cellsize,d0	; add one for allocation record
	move.l	#memtype,a0
	tst.l	0(bp,a0.l)	; has user specified requirements?
	beq.s	1$		; no, branch away
	move.l	0(bp,a0.l),d1	; yes, requirements
	bra.s	2$
1$	move.l	#MEMF_CLEAR,d1	; requirements
2$	callamy	AllocMem,exec	; get memory
	tst.l	d0		; return
	bne.s	_9resiz		; branch away on success
	popdsp			; discard incremental requirement
	moveq.l	#-1,tos		; indicate failure
	tonext
_9resiz	move.l	tos,a0		; new memory
	move.l	(dsp),(a0)+	; size record stored to new mem
	move.l	(dsp)+,d1	; resize request, count of bytes to copy
	move.l	(dsp),a1	; get back original membase
	adda.l	bp,a1		; convert to AbsAddr
	bra.s	2$
1$	move.b	(a1)+,(a0)+	; copy mem region
2$	dbra.s	d1,1$		; copy only that which will fit in new alloc!
	move.l	(dsp)+,a1	; get back original membase
	adda.l	bp,a1		; abs addr
	suba.l	#cellsize,a1	; point to byte allocation record
	move.l	(a1),d0		; actual count of allocated mem
	callamy	FreeMem,exec	; free old allocation
	move.l	bp,d0		; get DSeg pointer
	sub.l	d0,(dsp)	; convert new alloc to DSeg addr
	addi.l	#cellsize,(dsp)	; bump past allocation record
	moveq.l	#0,tos		; return success
	tonext			; 910726 jax

;---------------------------------------------------------------;
;	     MEMORY Allocation Extensions Word Set		;
;---------------------------------------------------------------;

	lfa	1			; dpANS-2 MEMORY EXT
	nfa	9,'AVAILABL','E'	; ( -- u)
availab	move.l	#memtype,a0
	tst.l	0(bp,a0.l)	; has user specified requirements?
	beq.s	1$		; no, branch away
	move.l	0(bp,a0.l),d1	; yes, requirements
	bra.s	2$
1$	move.l	#MEMF_CLEAR,d1	; no, this mask is sufficient
2$	callamy	AvailMem,exec	; get memory
	tonext			; 910726 jax

;---------------------------------------------------------------;
;			FACILITY Word Set			;
;---------------------------------------------------------------;

* empty wordset

;---------------------------------------------------------------;
;		    FACILITY Extensions Word Set		;
;---------------------------------------------------------------;

	lfa	1		; dpANS-2 FACILITY EXT
	nfa	5,'AT-X','Y'	; ( u1 u2 --)
at_xy	nest			; -- col row
	kcomp	bas		; -- col row addr
	kcomp	fetch		; -- col addr n
	kcomp	negrot		; -- n col row
	kcomp	decimal		; set base to DECIMAL for Amiga console string
	literal	$9B		; -- n row col CSI
	kcomp	emitbu		; -- n row col CSI addr
	kcomp	tuck		; -- n row col addr CSI addr
	kcomp	cstore		; -- n row col addr
	kcomp	onepl		; -- n row col addr1
	kcomp	swap		; -- n row addr1 col
	literal	0		; -- n row addr1 col 0
	kcomp	lsharp		; -- n row addr1 col 0
	kcomp	sharps		; -- n row addr1 d
	kcomp	sharpr		; -- n row addr1 addr ct
	kcomp	rot		; -- n row addr ct addr1
	kcomp	twodup		; -- n row addr ct addr1 ct addr1
	kcomp	plus		; -- n row addr ct addr1 addr2
	kcomp	pto_r		; -- n row addr ct addr1	R: -- addr2
	kcomp	swap		; -- n row addr addr1 ct	R: -- addr2
	kcomp	amov		; -- n row			R: -- addr2
	kcomp	pr_from		; -- n row addr2		R: --
	literal	";"		; -- n row addr2 char
	kcomp	over		; -- n row addr2 char addr2
	kcomp	cstore		; -- n row addr2
	kcomp	onepl		; -- n row addr3
	kcomp	swap		; -- n addr3 row
	literal	0		; -- n addr3 row 0
	kcomp	lsharp		; -- n addr3 row 0
	kcomp	sharps		; -- n addr3 d
	kcomp	sharpr		; -- n addr3 addr ct
	kcomp	rot		; -- n addr ct addr3
	kcomp	twodup		; -- n addr ct addr3 ct addr3
	kcomp	plus		; -- n addr ct addr3 addr4
	kcomp	pto_r		; -- n addr ct addr3		R: --addr4
	kcomp	swap		; -- n addr addr3 ct		R: --addr4
	kcomp	amov		; -- n				R: --addr4
	kcomp	pr_from		; -- n addr4
	literal	"H"		; -- n addr4 char
	kcomp	over		; -- n addr4 char addr4
	kcomp	cstore		; -- n addr4
	kcomp	onepl		; -- n addr5
	kcomp	emitbu		; -- n addr5 addr
	kcomp	tuck		; -- n addr addr5 addr
	kcomp	minus		; -- n addr ct
	kcomp	type		; -- n
	kcomp	bas		; -- n addr
	kcomp	store		; --		, restore BASE
	kcomp	unnest		; 910705 jax

	lfa	1		; dpANS-2 FACILITY EXT
	nfa	4,'EKE','Y'	; ( -- u)
ekey	nest
	kcomp	key
	kcomp	unnest		; 910706 jax

	lfa	1		; dpANS-2 FACILITY EXT
	nfa	5,'EKEY','?'	; ( -- flag)
ekeyq	nest
	kcomp	keyq
	kcomp	unnest		; 910706 jax

	lfa	1		; dpANS-2 FACILITY EXT
	nfa	5,'EMIT','?'	; ( -- flag)
emitq	push	#-1
	tonext			; 910706 jax

	lfa	3		; dpANS-2 FACILITY EXT
	nfa	4,'KEY','?'	; ( -- flag)
keyq	moveq.l #0,d0		; clear return reg
	move.l	#stdin,a0	; variable holding console file handle
	move.l	0(bp,a0.l),d1	; deref into the correct register for the call
	moveq.l #1,d2		; timeout bug in timer.device, don't use zero!
	callamy WaitForChar,dos ; returns -1 in TOS if char waiting, 0 if no
	tonext			; 910706 jax

	lfa	1		; dpANS-2 FACILITY EXT
	nfa	2,'M','S'	; ( u --) \ u < 1,310,720
ms	tst.l	tos		; test for zero
	beq.s	_1ms		; AmigaDOS bug, musn't pass 0x0L to Delay()!
	divu.w	#20,tos		; 20 AmigaDOS ticks per MS
	moveq.l	#0,d1		; prepare AmigaDOS arg register
	move.w	tos,d1		; ticks, possible remainder to be added
	andi.l	#$ffff0000,tos	; any remainder?
	beq.s	_0ms		; no, continue on
	addq.l	#1,d1		; yes, increment tick count
_0ms	callamy	Delay,dos	; delay politely
	popdsp			; discard AmigaDOS return
_1ms	popdsp			; discard original argument
	tonext			; 910705 jax

	lfa	0		; dpANS-2 FACILITY EXT
	nfa	4,'PAG','E'	; ( --)
page	nest
	literal	$0c
	kcomp	emit
	kcomp	unnest		; 910705 jax

	lfa	i0
	nfa	9,'DATESTAM','P'	; ( -- reg-d0)
datestp	move.l	#datestamp,d1
	add.l	bp,d1
	callamy	DateStamp,dos	; return in TOS
	tonext

	lfa	i0
	nfa	5,'TIME','?'	; ( -- seconds minutes hours)
timeq	move.l	#datestamp+cellsize,a0
	adda.l	bp,a0
	move.l	(a0)+,d1
	move.l	(a0)+,d2
	divu.w	#50,d2		; seconds from tix
	move.l	d2,d3
	swap.w	d2		; remainder
	tst.w	d2		; any?
	beq.s	1$
	add.w	#1,d3		; add one to second count if remainder
1$	andi.l	#$ffff,d3	; get rid of remainder in high order
	push	d3		; seconds
	divu.w	#60,d1		; quotient is hours, remainder is minutes
	move.l	d1,d3
	swap.w	d3
	andi.l	#$ffff,d3
	push	d3		; minutes
	andi.l	#$ffff,d1
	push	d1		; hours
	tonext

	lfa	i1
	nfa	5,'YEAR','?'	; ( -- days year-1976)
yearq	nest
	literal	datestamp	; -- addr
	kcomp	fetch		; -- days
	literal	2		; -- days 2 ( start in 1978)
_0yearq	kcomp	twodup		; -- days n days n
	literal	4
	kcomp	mod		; -- days n days flag
	kcomp	zeroeq
	compif	_1yearq
	literal	366		; leap year
	compelse	_2yearq
_1yearq	literal 365		; regular
_2yearq	kcomp	minus		; days n days-(366|365)
	kcomp	zerolt		; days n flag ( ran out of days?)
	kcomp	zeroeq		; -- days 2 flag
	compif	_6yearq		; WHILE we succeeded in counting a year
	kcomp	dup
	literal 4
	kcomp	mod
	kcomp	zeroeq
	compif	_4yearq
	literal	366
	compelse	_5yearq
_4yearq	literal	365
_5yearq	kcomp	rot		; -- n 365|366 days
	kcomp	swap
	kcomp	minus		; -- n days'
	kcomp	swap
	kcomp	onepl		; -- days' n+1
	compelse	_0yearq	; REPEAT
_6yearq	kcomp	unnest		; until we ran out of years

months	dc.b	31,28,31,30,31,30,31,31,30,31,30,31

	lfa	i1
	nfa	6,'MONTH','?'	; ( days year-1976 -- day month year)
monthq	tst.l	(dsp)
	bne.s	1$		; branch away if there remain days
	move.l	(dsp),tos	; no days, get year
	move.l	#1,(dsp)	; push January 1 on the stack
	move.l	#1,-(dsp)
	bra.w	4$		; giddoudahere
1$	move.l	(dsp),d3	; days
	movea.l	#months,a0	; month byte array
	moveq.l	#0,d1		; clear d1 for bytes
	moveq.l	#12,d0		; loop index
	bra.s	3$		; previous MOVEQ reset C and Z flags
2$	move.l	d3,d2		; copy current day count
	move.b	(a0)+,d1	; prepare to subtract next month's days
	sub.w	d1,d3		; subtract days for this month
3$	dbls.s	d0,2$		; loop while positive days left
	addi.l	#1,d2		; days ( one-based)
	move.l	d2,(dsp)	; day
	moveq.l	#12,d2		; months
	sub.l	d0,d2		; subtract remaining loop index from months%year
	move.l	d2,-(dsp)	; month
4$	addi.l	#1976,tos	; turn year offset into calendar year
	tonext

	lfa	0		; dpANS-2 FACILITY EXT
	nfa	9,'TIME&DAT','E'	; ( -- +n1 +n2 +n3 +n4 +n5 +n6)
getdate	nest
	kcomp	datestp		; -- amiga return
	kcomp	drop		; --
	kcomp	timeq		; -- sec min hr
	kcomp	yearq		; -- sec min hr year-1976 days
	kcomp	monthq		; -- sec min hr day mo yr
	kcomp	unnest		; 910706 jax

;-----------------------------------------------;
;	End of BASIS-Specified Word Sets	;
;-----------------------------------------------;

;-------------------------------------------------------;
;   All the following are in the IMPLEMENTOR wordlist	;
;-------------------------------------------------------;

*--- Execution

* UNNEST terminates most colon definitions

	lfa	i1
	nfa	8,'UNNES','T'	; ( ---)
unnest	rpop	ip	; restore ip to return from nested colon def
	tonext		; jump next

* The dichotomy between UNNEST and EXIT allows a debugger to distinguish
* between a quick getaway and the actual end of a colon definition.

*--- Dictionary

	lfa	i1
	nfa	10,'ALIGN-DIC','T' ( --)
alidic	wdpalin			; word-align dictionary
	tonext

	lfa	i2		; Print a name header
	nfa	5,'.NAM','E'	; ( namtok --)
dotname	lsl.l	#1,tos
	bcc.s	1$		; branch away if it's a local token
	add.l	cp,tos		; kernel token, add Code Pointer for Abs Addr
	bra.s	2$		; continue
1$	add.l	np,tos		; local token, add Next Pointer for Abs Addr
2$	pop	a0		; pointing to count byte
	moveq.l	#0,d0		; clear d0 for indexing
	move.b	(a0)+,d0	; masked count to D0
	andi.l	#maxncount,d0	; unmask count
	move.l	d0,d3		; copy of count
	movea.l	#emitbuf,a1	; address to move name string
	adda.l	bp,a1		; convert to abs
	bra.s	4$
3$	move.b	(a0)+,d2	; get name char
	move.b	d2,d1		; save copy
	andi.l	#maxnchar,d2	; unmask char (if necessary)
	move.b	d2,(a1)+	; store char in emit buffer
	tst.b	d1		; check to see if it was masked
4$	dblt.s	d0,3$		; loop until masked byte encountered
	tst.w	d0		; did loop complete?
	ble.s	6$		; yes, skip padding
5$	move.b	#'_',(a1)+	; pad with understrokes if name short
	dbra.s	d0,5$		; loop till done
6$	move.l	#emitbuf,d2	; DSeg address
	add.l	bp,d2		; Abs Address of string
	move.l	#stdout,d1
	move.l	0(bp,d1.l),d1	; fhandle
	callamy	Write,dos	; make system call, D3 already had count
	move.l	(dsp)+,tos	; discard CALLAMY return 
	tonext

; hide a definition by acting to restore previous link to correct thread
	lfa	i3
	nfa	6,'SMUDG','E'	; ( --)
smudge	nest
	kcomp	las
	kcomp	fetch		; -- NSeg-tok
	kcomp	twostar		; -- NSeg-addr
	kcomp	codtoz
	kcomp	abstod		; -- a-addr
	kcomp	dup		; -- a-addr a-addr
	kcomp	onepl		; -- a-addr c-addr
	kcomp	cfetch		; -- a-addr char
	literal	numthreads-1
	kcomp	b_and		; -- a-addr thread#
	kcomp	cells
	kcomp	getcurr
	kcomp	plus		; -- a-addr vocthread
	kcomp	swap		; -- voct a-addr
	kcomp	cell
	kcomp	minus		; -- voct lfa
	kcomp	fetch		; -- voct link
	kcomp	swap
	kcomp	store		; --
	kcomp	unnest

; reveal a definition by acting to restore its link to correct thread
	lfa	i1
	nfa	8,'UNSMUDG','E'	; ( --)
unsmudge	nest
	kcomp	las
	kcomp	fetch		; -- NSeg-NFA-tok
	kcomp	dup		; -- tok tok
	kcomp	twomi		; -- nfa-tok lfa-tok ; dicey mathematically
	kcomp	swap		; -- lfa-tok nfa-tok
	kcomp	twostar		; -- tok NSeg-addr
	kcomp	codtoz
	kcomp	abstod		; -- tok a-addr
	kcomp	dup		; -- tok a-addr a-addr
	kcomp	onepl		; -- tok a-addr c-addr
	kcomp	cfetch		; -- tok a-addr char
	literal	numthreads-1
	kcomp	b_and		; -- tok a-addr thread#
	kcomp	cells
	kcomp	getcurr
	kcomp	plus		; -- tok a-addr vocthread
	kcomp	tuck		; -- tok vocthread a-addr vocthread
	kcomp	fetch		; -- tok vocthread a-addr linkptr
	kcomp	swap		; -- tok vocthread linkptr a-addr
	kcomp	cell
	kcomp	minus		; -- t voct lp lfa
	kcomp	store		; -- t voct
	kcomp	store		; --
	kcomp	unnest

	lfa	i1
	nfa	7,'MAKEVO','C'	; ( --)
makvoc			; copy the DOTWOCONST engine into code space
	move.w	#(_1makvo-_0makvo),d0	; length of code to copy
	move.l	#_0makvo,a0		; KSeg addr to start from
	move.l	dp,a1			; Destination in NSeg
	adda.l	np,a1			; Convert to AbsAddr
	bra.s	2$
1$	move.b	(a0)+,(a1)+	; loop copying code to code segment
2$	dbra.w	d0,1$
	suba.l	np,a1		; convert back to NSeg addr
	move.l	a1,dp		; restore dictionary pointer
	tonext
_0makvo	move.l	#contextarray,d0
	move.l	*+8(pc),0(bp,d0.l)	; CONTEXT[0] <- DSeg.forthvoc
	tonext			; return to Forth
_1makvo

	lfa	i2
	nfa	10,'VOCABULAR','Y'	; ( --)
vocab	nest
	kcomp	creatq		; header
	kcomp	makvoc		; execution engine
	kcomp	wordlis		; allocate thread array
	kcomp	ctok		; compile pointer to same
	kcomp	las
	kcomp	fetch		; name header address
	kcomp	here
	kcomp	cell
	kcomp	minus		; name back-pointer of vocab
	kcomp	store		; save for ORDER, etc.
	kcomp	unnest

*--- Stack Operators

	lfa	i1
	nfa	4,'-RO','T'	; ( w1 w2 w3 --- w3 w1 w2)
negrot	pop	d0
	move.l	(dsp),-(dsp)
	move.l	d0,4(dsp)
	tonext

	lfa	i0
	nfa	7,'(DUP>R',')'	; ( w1 -- w1) ( R: -- w1)
dupto_r	move.l	tos,-(rp)
	tonext

	lfa	i0
	nfa	8,'(R>DROP',')'	; ( --) ( R: w --)
r_frodr	move.l	(rp)+,d0
	tonext

	lfa	i0
	nfa	5,'DUP>','R'	; ( w1 -- w1) ( R: -- w1)
kdupto_r	nest
	kcomp	chkstat
	kcomp	parlit
	kcomp	dupto_r
	kcomp	ctok
	kcomp	unnest

	lfa	i2
	nfa	6,'R>DRO','P'	; ( --) ( R: w --)
kr_frodr	nest
	kcomp	chkstat
	kcomp	parlit
	kcomp	r_frodr
	kcomp	ctok
	kcomp	unnest

	lfa	i3
	nfa	3,'SP','0'	; ( -- adr)
spzer	docreat	spzero

	lfa	i3
	nfa	3,'SP','@'	; ( -- w1)
spfet	push	dsp		; current "second-on-stack" pointer
	sub.l	bp,tos		; convert to DSeg address
	tonext

	lfa	i3
	nfa	3,'SP','!'	; ( a-addr --)
spsto	lea	0(bp,tos.l),dsp	; stack arg is a DSeg addr
	tonext

	lfa	i2
	nfa	3,'RP','0'	; ( -- adr)
rpzer	docreat	rpzero

	lfa	i2
	nfa	3,'RP','@'	; ( -- w1)
rpfet	push	rp
	sub.l	bp,tos		; convert to DSeg addr
	tonext

	lfa	i2
	nfa	3,'RP','!'	; ( w1 -- )
rpsto	lea	0(bp,tos.l),rp	; load RP with DSeg addr converted to abs
	popdsp
	tonext

*	lfa	i2
*	nfa	6,'RPSIZ','E'	; ( -- adr)
*rpsiz	docreat	rpsize

	lfa	i1
	nfa	8,'UNDERDU','P'	; ( n1 n2 -- n1 n1 n2)
underdu	move.l	(dsp),-(dsp)
	tonext

; This should be sprinkled in the file words which have a real potential
; to crash the system.
	lfa	i3
	nfa	7,'?ENOUG','H'	; ( i*x n -- i*x -or- --)
qenuff	nest
	kcomp	depth
	kcomp	lesst
	kcomp	zeroeq
	abortq	"Args?"
	kcomp	unnest

; this has to have an overflow test, too, along the lines of RP@ >=
	lfa	i3
	nfa	'?STAC','K'	; ( i*x -- i*x -or- --)
qstack	nest
	kcomp	spfet
	kcomp	spzer
	kcomp	fetch
	kcomp	greater
	abortq	"Stack Underflow"
	kcomp	unnest

*--- The most useful construct on any language processor: NOOP

	lfa	i2
	nfa	4,'NOO','P'	; ( --)
noop	nop
	tonext

*--- Moving Data

	lfa	i0		; SRC >= DEST
	nfa	6,'LMOV','E'	; ( src dest byte-ct ---)
lmove	tst.l	tos		; non-zero count?
	bne.s	_1lmove		; yes, proceed
	addq.l	#8,dsp		; no, clear stack and exit
	popdsp
	tonext
_1lmove	lindex			; set up addresses
	lsr.l	#2,tos		; word moves, divide byte count by 4
	bra.s	2$		; correct entry to Moto DBcc loop
1$	move.l	(a0)+,(a1)+	; move lwords left, progressing right
2$	dbra	tos,1$		; dec and loop
	popdsp			; discard count
	tonext			; jump next

	lfa	i0		; DEST > SRC
	nfa	5,'LMOVE','>'	; ( src dest byte-ct --)
lmovr	tst.l	tos		; non-zero count?
	bne.s	_1lmovr		; yes, proceed
	addq.l	#8,dsp		; no, clear stack and exit
	popdsp
	tonext
_1lmovr	rindex
	lsr.l	#2,tos
	bra.s	2$
1$	move.l	-(a0),-(a1)	; move data right by progressing left
2$	dbra	tos,1$
	popdsp
	tonext

	lfa	i3		; DEST > SRC
	nfa	6,'WMOVE','>'	; ( src dest byte-ct --)
wmovr	tst.l	tos		; non-zero count?
	bne.s	_1wmovr		; yes, proceed
	addq.l	#8,dsp		; no, clear stack and exit
	popdsp
	tonext
_1wmovr	rindex			; as lmovr, but .w
	lsr.l	#1,tos		; turn byte index to word
	bra.s	2$		; correct entry to Moto DBcc loop
1$	move.w	-(a0),-(a1)	; move predecrementing
2$	dbra	d0,1$
	popdsp
	tonext

	lfa	i0		; SRC >= DEST
	nfa	6,'WMOV','E'	; (src dest byte-ct ---)
wmove	tst.l	tos		; non-zero count?
	bne.s	_1wmove		; yes, proceed
	addq.l	#8,dsp		; no, clear stack and exit
	popdsp
	tonext
_1wmove	lindex			; as lmove, but .w
	lsr.l	#1,tos
	bra.s	2$		; correct entry to Moto DBcc loop
1$	move.w	(a0)+,(a1)+
2$	dbra	d0,1$
	popdsp
	tonext

	lfa	i0
	nfa	5,'PLAC','E'	; ( c-addr1 u c-addr2 --)
place	nest
	kcomp	twodup	; we have to install count
	kcomp	cstore	; install count
	kcomp	onepl	; increment destination address
	kcomp	swap	; count to top of stack
	kcomp	amov	; install string
	kcomp	unnest

*--- Fetching and Storing Data
	
	lfa	i3
	nfa	2,'W','@'	; ( a-addr --- 16b) BASIS12
wfetch	walin	tos		; no guru
	move.l	tos,a0		; move source to an address register
	moveq.l #0,tos		; clear TOS for word fetch
	move.w	0(bp,a0.l),tos	; fetch word from dataseg
	tonext

	lfa	i3
	nfa	2,'W',<','>	; ( 16b --) BASIS12
wcomma	wapalin			; no gurus
	move.w	tos,0(bp,ap.l)	; store to dataseg
	addq.l	#2,ap		; post-increment allocation pointer
	popdsp			; discard TOS
	tonext

	lfa	i3
	nfa	2,'W','!'	; ( 16b a-addr ---) BASIS12
wstore	walin	tos		; no guru
	move.l	(dsp)+,d0	; pop second on stack
	move.w	d0,0(bp,tos.l)	; move to dataseg
	popdsp			; drop tos
	tonext

	lfa	i2
	nfa	2,'2',<','>	; ( w1 w2 ---)
twocom	wapalin			; align allocation pointer, no gurus!
	pop	<0(bp,ap.l)>	; store to dataseg
	addq.l	#4,ap		; post-increment the allocation pointer
	pop	<0(bp,ap.l)>	; do it again
	addq.l	#4,ap		; for a double-precision constant
	tonext

	lfa	i3
	nfa	2,'O','N'	; ( a-addr --)
on	walin	tos		; no gurus
	move.l	#-1,0(bp,tos.l)
	popdsp
	tonext

	lfa	i3
	nfa	3,'OF','F'	; ( a-addr --)
off	walin	tos		; no gurus
	clr.l	0(bp,tos.l)
	popdsp
	tonext

*--- Comparison

	lfa	i0
	nfa	3,'0>','='	; ( w1 -- flag)
zeroge	tst.l	tos
	sge	tos
	ext.w	tos
	ext.l	tos
	tonext

	lfa	i0
	nfa	3,<'0<'>,'='	; ( w1 -- flag)
zerole	tst.l	tos
	sle	tos
	ext.w	tos
	ext.l	tos
	tonext

	lfa	i2
	nfa	7,'BETWEE','N'	; ( n1 n2 n3 -- flag)
between	addq.l	#1,tos
	bra.w	within

*--- Numbers

	lfa	i0
	nfa	3,'HL','D'	; ( -- a-addr)
hl	docreat	hld

*--- Mathematics

	lfa	i2
	nfa	2,'2','+'	; ( w1 -- w2) BASIS12
twopl	addq.l	#2,tos
	tonext

	lfa	i2
	nfa	2,'2','-'	; ( w1 -- w2) BASIS12
twomi	subq.l	#2,tos
	tonext

	lfa	i1
	nfa	6,'MU/MO','D'	; ( ud u -- u.rem ud.quot )       
muslmod	nest		; -- ud u
	kcomp	pto_r	; -- ud			R: -- u
	literal	0	; -- ud 0		R: -- u
	kcomp	r_fet	; -- ud 0 u		R: -- u
	kcomp	umslmod	; -- udl urem udqh	R: -- u
	kcomp	pr_from	; -- udl urem udqh u	R: --
	kcomp	swap	; -- udl urem u udqh	R: --
	kcomp	pto_r	; -- udl urem u		R: -- udqh
	kcomp	umslmod	; -- urem udql		R: -- udqh
	kcomp	pr_from ; -- urem udqot
	kcomp	unnest

	lfa	i1
	nfa	4,'TAB','S'	; ( t1 -- _t1_) abs value of a triple
tabs	neg.l	4(dsp)
	negx.l	(dsp)
	negx.l	tos
	tonext			; 910718 jax

	lfa	i1
	nfa	6,'UNDER','+'	; ( n1 n2 n3 -- n1+n3 n2)
underpl	add.l	tos,4(dsp)
	popdsp
	tonext

	lfa	i3
	nfa	8,'?DNEGAT','E'	; ( ud flag -- ud|-ud)
qdnegat	tst.l	tos
	beq.s	1$
	move.l	(dsp)+,tos
	neg.l	(dsp)
	negx.l	tos
	tonext
1$	move.l	(dsp)+,tos
	tonext

*--- Characters

	lfa	i3
	nfa	4,'CAP','S'		; ( -- a-addr)
cap	docreat	caps

	lfa	i1
	nfa	3,'UP','C'		; ( char1 -- char2)
upc	cmpi.l	#'a',tos
	blt.s	1$
	cmpi.l	#'z',tos
	bgt.s	1$
	subi.l	#('a'-'A'),tos
1$	tonext

*--- Strings

;-----------------------------------------------------------------------;
; These all access the data segment, they won't work on the dictionary	;
; without first converting addresses, e.g., .. addr KERN>ABS ABS>DATA	;
; 4 UPPER .. etc.							;
;-----------------------------------------------------------------------;

	lfa	i1
	nfa	5,'UPPE','R'	( c-addr u --)
upper	nest
	kcomp	bounds		; -- outer inner
	compqdo	_1upper		; --
_0upper	kcomp	dodoi		; -- c-addr
	kcomp	dup		; -- c-addr c-a
	kcomp	cfetch		; -- c-a char
	kcomp	upc		; -- c-a char'
	kcomp	swap		; -- char' c-a
	kcomp	cstore		; --
	comploop	_0upper
_1upper	kcomp	unnest

	lfa	i1
	nfa	10,'?UPPERCAS','E'	; ( c-addr --)
qupperc	nest
	kcomp	cap
	kcomp	fetch
	compif	_1quppe
	kcomp	dup
	kcomp	count
	kcomp	upper
_1quppe	kcomp	unnest

	lfa	i3
	nfa	4,'SKI','P'	; ( b-addr1 u1 char --- b-addr2 u2)
skip	move.l	(dsp)+,d0	; count to iteration register, limit 2^16
	move.l	(dsp),a0	; address of start of string
	adda.l	bp,a0		; add offset to base of data seg
	eor.w	d1,d1		; set zero flag!
	bra.s	2$		; jump into loop (exhausted input handling)
1$	cmp.b	(a0)+,tos	; compare char at deref'ed addr
2$	dbne	d0,1$		; branch to done if char <> test char
	subq.l	#1,a0		; back up address
	addi.w	#1,d0		; back up count
	suba.l	bp,a0		; re-Forth the address
	move.l	a0,(dsp)	; new addr
	move.l	d0,tos		; new ct
	tonext

	lfa	i3
	nfa	4,'SCA','N'	; ( addr ct char --- addr ct)
scan	move.l	(dsp)+,d0	; count to iteration register, limit 2^16
	move.l	(dsp),a0	; address of start of string
	adda.l	bp,a0		; add offset to base of data seg
				; no need to set NZ, the ADDA.L BP,A0 did it
1$	cmp.b	(a0)+,tos	; compare char at deref'ed addr
	dbeq	d0,1$		; branch to done if char = test char
	subq.l	#1,a0		; back up address
	addi.w	#1,d0		; back up count
	suba.l	bp,a0		; re-Forth the string address
	move.l	a0,(dsp)	; new addr
	move.l	d0,tos		; new ct
	tonext

*--- Addressing

	headerless	; abs to kernel address
ztokrn	sub.l	cp,tos
	tonext

	headerless	; abs to local code address
ztocod	sub.l	np,tos
	tonext

	headerless	; NSeg to abs address
codtoz	add.l	np,tos
	tonext

	headerless	; KSeg to abs address
krntoz	add.l	cp,tos
	tonext

	headerless
ctoktoc	lsl.l	#1,tos	; Local code token to NSeg addr
	tonext

	lfa	i3
	nfa	8,'KERN>AB','S'	; ( resident-kernel-token --- abs-addr)
ktoabs	krn2abs	tos	; convert kernel token to machine address
	tonext

	lfa	i3
	nfa	8,'CODE>AB','S'	; ( local-code-token --- abs-addr)
ctoabs	cod2abs	tos	; convert local code addr to machine address
	tonext

	lfa	i0
	nfa	8,'DATA>AB','S'	; ( dat-addr --- abs-addr)
dtoabs	dat2abs	tos	; convert data addr to machine address
	tonext

	lfa	i1
	nfa	8,'ABS>KER','N'	; ( abs-addr --- resident-kernel-token)
abstok	abs2krn	tos	; convert machine address to kernel token
	tonext

	lfa	i1
	nfa	8,'ABS>COD','E'	; ( abs-addr --- local-code-addr)
abstoc	abs2cod	tos	; convert machine address to local code addr
	tonext

	lfa	i1
	nfa	8,'ABS>DAT','A'	; ( abs-addr --- data-addr)
abstod	abs2dat	tos	; convert data addr to machine address
	tonext

; Convert a link pointer, (or a name token, for that matter,) to a data address.

	lfa	i0
	nfa	6,'L>DAT','A'	; ( link -- data-seg-relative-addr)
ltodat	lsl.l	#1,tos		; shift tokenized link to offset
	bcc.s	_1ltoda		; carry set == kernel link
	add.l	cp,tos		; convert kernel offset to absolute address
	bra.s	_2ltoda	
_1ltoda	add.l	np,tos		; convert local code offset to abs address
_2ltoda	abs2dat	tos		; convert abs address to data seg address
	tonext

	lfa	i3
	nfa	4,'CEL','L'	; ( -- n)
	headerless
cell	doconst	4

	lfa	i2
	nfa	6,'BOUND','S'	; ( addr u -- outerlim innerlim)
bounds	move.l	(dsp),d0
	add.l	tos,(dsp)
	move.l	d0,tos
	tonext

*--- Dictionary

	lfa	i0
	nfa	3,'DP','!'	; ( a-addr --- )
dpsto	pop	dp	; store to  user dictionary pointer
	tonext

	lfa	i0
	nfa	3,'DP','@'	; ( --- a-addr)
dpfet	push	dp	; get user dictionary pointer
	tonext

	lfa	i3
	nfa	7,'CONTEX','T'	; ( -- addr)
context	docreat	contextarray	; holds array of vocablulary pointers

	lfa	i3
	nfa	5,'WIDT','H'	; ( -- a-addr)
widt	docreat	width		; controls width of name fields

	lfa	i0
	nfa	4,'HAS','H'	; ( $addr -- thread#)
hash	nest			; picks one of four threads from first char
	kcomp	onepl
	kcomp	cfetch
	literal numthreads
	kcomp	onemi
	kcomp	b_and
	kcomp	unnest
	
	lfa	i3		; ***ANS*** ENVIRONMENT? WORDLISTS
	nfa	5,'#VOC','S'	; ( -- n)
numvoc	doconst	numvocs		; number of vocabularies in search order

	lfa	i0
	nfa	6,'L>NAM','E'	; ( link-tok -- name-tok)
ltonam	addq.l	#4,tos
	tonext

	lfa	i0
	nfa	6,<'L<NAM'>,'E'	; ( name-tok -- link-tok)
lfronam	subq.l	#4,tos
	tonext

	lfa	i0
	nfa	8,'TRAVERS','E'	; ( name-tok -- exe-tok)
travers	move.l	tos,d0		; save a copy of original token
	move.l	tos,d2		; and another copy
	lsl.l	#1,d0		; shift tokenized address to offset
	bcc.s	_1trave		; carry set == kernel link
	krn2abs	tos		; convert kernel token to abs address
	bra.s	_2trave
_1trave	cod2abs	tos		; convert local code seg token to abs address
_2trave	move.l	tos,a0		; and this is the copy to test for HEADERLESS
	cmpi.l	#-1,(a0)	; now see if it is HEADERLESS
	bne.s	_9trave		; it ain't, branch away
	addq.l	#cellsize,tos	; it is, CFA is one cell ahead
	bra.s	_8trave		; convert to token and leave
_9trave	addq.l	#1,tos		; advance past count byte
	movea.l	tos,a0		; address pointer
_3trave	move.b	(a0)+,d1
	andi.b	#$80,d1		; is the high bit set?	
	beq.s	_3trave		; no, keep searching
	move.l	a0,tos		; abs address of code field
	walin	tos		; align address
_8trave	andi.l	#kernbit,d2	; was it a kernel address?
	beq	_4trave		; no, branch
	abs2krn	tos		; convert abs to kernel token
	tonext
_4trave	abs2cod	tos		; convert abs to local code token
	tonext

	lfa	i0
	nfa	5,'LINK','>'	; ( linktok -- exetok)
linkfro	nest
	kcomp	ltonam
	kcomp	travers
	kcomp	unnest

*--- Compiling

	lfa	i3
	nfa	11,'CHECK-STAT','E' ( --)
chkstat	nest
	kcomp	stat			; check for compiling
	kcomp	fetch
	kcomp	zeroeq			; interpreting?
	compif	_1chkst
	kcomp	tickwor
	kcomp	count
	kcomp	type
	kcomp	space
	kcomp	true
	abortq	"is for compilation only."	; abort with err
_1chkst	kcomp	unnest

*--- Operating System

	lfa	i0
	nfa	3,'DO','S'	; ( -- addr)
dosli	docreat	doslib	; initialized at startup

	lfa	i1
	nfa	4,'EXE','C'	; ( -- addr)
execli	docreat	execlib	; initialized at startup

;-------------------------------------------------------;
; ARGARRY holds D0-D6/A0-A5 to be loaded for a lib call	;
;-------------------------------------------------------;

	lfa	i1
	nfa	8,'ARGARRA','Y'	; ( -- addr)
argarra	docreat argarray	; 56 bytes

	lfa	i2
	nfa	5,'>DRE','G'		; ( arg dreg# --)
to_dreg	andi.l	#6,tos			; not to big for array!
	lsl.l	#2,tos			; convert to offset
	addi.l	#argarray,tos		; add base address	
	move.l	(dsp)+,0(bp,tos.l)	; pop arg into pseudoreg
	popdsp				; clean stack
	tonext

	lfa	i2
	nfa	5,'>ARE','G'		; ( arg areg# --)
to_areg	andi.l	#5,tos			; not to big for array!
	lsl.l	#2,tos			; convert to offset
	addi.l	#argarray+$1C,tos	; add base address	
	move.l	(dsp)+,0(bp,tos.l)	; pop arg into pseudoreg
	popdsp				; clean stack
	tonext

	lfa	i3
	nfa	4,'CAL','L'	; ( offset lib-ptr-var-addr -- ret)
kcall	pop	a0	; variable holding lib ptr
	savereg		; save Forth machine on stack
	movea.l	0(bp,a0.l),a6	; library pointer
	getarg		; load D0-D6/A0-A5 with the contents of ARGARRAY
	jsr	0(a6,tos.l)	; do call
	getreg		; restore Forth machine
	move.l	d0,tos	; save return from OS
	tonext

*--- Character I/O

	lfa	i3
	nfa	6,'STDOU','T'	; ( -- addr)
stdo	docreat	stdout

	lfa	i3
	nfa	5,'STDI','N'	; ( -- addr)
stdi	docreat	stdin

	lfa	i1
	nfa	7,'EMITBU','F'	; ( -- addr)
emitbu	docreat	emitbuf

	lfa	i0
	nfa	8,'DOSWRIT','E'	; ( fh rel-addr ct -- ret)
doswrit	move.l	tos,d3		; count
	move.l	(dsp)+,d2	; address
	add.l	bp,d2		; addr must be in data segment!
	move.l	(dsp)+,d1	; fhandle
	popdsp			; clear stack
	callamy	Write,dos	; make system call
	tonext			; CALLAMY macro stacks retval

	lfa	i3
	nfa	5,'WHER','E'	; ( --)
where	defer 	iswhere

	lfa	i3
	nfa	6,'?ERRO','R'	; ( c-addr u flag --)
qerror	defer	isqerror

	lfa	i0
	nfa	6,'(?ERROR',')'	; ( c-addr u flag --)
pqerror	nest		; -- c-addr u flag
_0pqerr	compif	_3pqerr	; -- c-addr u
	kcomp	pto_r	; -- c-addr		R: -- u
	kcomp	pto_r	; --			R: -- u c-addr
	kcomp	spzer	; -- a-addr		R: -- u c-addr
	kcomp	fetch	; -- a-addr		R: -- u c-addr
	kcomp	spsto	; --			R: -- u c-addr
	kcomp	kblk	; -- a-addr		R: -- u c-addr
	kcomp	fetch	; -- u			R: -- u c-addr
_1pqerr	compif	_2pqerr	; --			R: -- u c-addr
	kcomp	toi	; -- a-addr		R: -- u c-addr
	kcomp	fetch	; -- u			R: -- u c-addr
	kcomp	kblk	; -- u a-addr		R: -- u c-addr
	kcomp	fetch	; -- u u		R: -- u c-addr
	kcomp	where	; --			R: -- u c-addr
_2pqerr	kcomp	pr_from	; -- c-addr		R: -- u
	kcomp	pr_from	; -- c-addr u		R: --
	kcomp	space	; -- c-addr u
	kcomp	type	; --
	kcomp	space	; --
	kcomp	quit	; --
	compelse	_4pqerr	; -- c-addr u
_3pqerr	kcomp	twodrop	; --
_4pqerr	kcomp	unnest

*--- Compiler

	lfa	i0
	nfa	4,'LAS','T'	; ( -- a-addr)
las	docreat	last

	lfa	i1
	nfa	10,'MAKE-TOKE','N'	; ( local-code-addr --- local-token)
mtok	lsr.l	#1,tos
	tonext

*--- BLOCK Support

	lfa	i2
	nfa	5,'B/BU','F'	; ( -- n)
bslbuf	doconst rawblocksize

*--- File Support

	lfa	i3
	nfa	10,'OPEN-FILE','"'	( "ccc<"> -- fh ior)
openfiq	nest
	literal	'"'
	kcomp	parse
	kcomp	rslashw
	kcomp	openfil
	kcomp	unnest

*--- Interpreter

;-----------------------------------------------------------------------;
; Much of this interpreter code still needs to be altered to meet ANS	;
;-----------------------------------------------------------------------;

	lfa	i3
	nfa	5,'''WOR','D'	; ( -- a-addr)
tickwor	docreat	tickword

	lfa	i0
	nfa	8,'(SOURCE',')'	; ( -- c-addr u)
psource	nest
	kcomp	kblk		; check BLK
	kcomp	fetch
	kcomp	qdup
	compif	_1psour		; if it's a BLOCK
	kcomp	block		; get address of the BLOCK
	kcomp	bslbuf		; and a count of 1024
	compelse	_2psour	; otherwise
_1psour	kcomp	tib		; get TIB address
	kcomp	numti		; get count of chars in TIB
	kcomp	fetch
_2psour	kcomp	unnest

	lfa	i3
	nfa	6,'SOURC','E'	; ( -- c-addr u)
source	defer issource

	lfa	i0
	nfa	3,'DP','L'		; ( -- a-adr)
kdpl	docreat	dpl	; variable holding various number input info

	lfa	i0
	nfa	7,'DOUBLE','?'	; ( -- flag)
doubleq	nest
	kcomp	kdpl	; variable holding various number input info
	kcomp	fetch
	literal	$7fffffff
	kcomp	b_and	; mask out "negative" bit
	kcomp	zeroeq	; DPL started out == $FFFFFFFF or $7FFFFFFF
	kcomp	unnest	; otherwise, a float or a single

	lfa	i1
	nfa	4,'END','?'	; ( -- a-addr)
kendq	docreat	endq

	lfa	i0
	nfa	5,'DONE','?'	; ( flag1 -- flag2)
done_q	nest
	kcomp	stat
	kcomp	fetch
	kcomp	noteq
	kcomp	kendq
	kcomp	fetch
	kcomp	b_or
	kcomp	kendq
	kcomp	off
	kcomp	unnest

	lfa	i0
	nfa	7,'DEFINE','D'	; ( --  [ 'word 0 ] | [ cfa 1|-1 ])
defined	nest
	kcomp	bl
	kcomp	word
	kcomp	qupperc
	kcomp	find
	kcomp	unnest

	lfa	i1
	nfa	9,'INTERPRE','T'	; ( --)
interp	nest
_0inter				; Begin
	kcomp	qstack		; --
	kcomp	defined		; -- [ 'word 0 ] | [ cfa 1|-1 ]
	kcomp	qdup		; -- [ 'word 0 ] | [ cfa 1|-1 1|-1]
	compif	_1inter		; -- cfa 1|-1
	kcomp	stat
	kcomp	fetch		; -- cfa 1|-1 flag
	compif	_9inter		; compiling
	kcomp	zerolt		; non-immediate?
	compif	_8inter		; yes, compile it
	kcomp	ctok		; --
	compelse	_0inter	; --
_8inter	kcomp	execute		; --
	compelse	_0inter	; --
_9inter	kcomp	drop		; -- cfa  ,interpreting
	kcomp	execute		; --   ,execute found word
	kcomp	kendq
	kcomp	fetch		; -- t|f ,see if input stream exhausted
	compif	_0inter		; -- loop if not exhausted
	kcomp	pexit		; -- ,exhausted? exit INTERPRET
_1inter	kcomp	kendq		; input stream exhausted?
	kcomp	fetch		; -- c-addr flag
	compif	_5inter		; yes
	kcomp	drop		; discard c-addr
	kcomp	pexit		; exit INTERPRET
_5inter	dliteral	0,0	; starting double for >NUMBER
	kcomp	rot		; -- 0 0 c-addr
	kcomp	count		; -- ud1' c-addr1 u1
	kcomp	to_numb		; -- ud2 c-addr2 u2
	kcomp	zerone		; -- ud2 c-addr2 t|f ,a "legal" number?
	compif	_zinter
	kcomp	tickwor		; show offending lexical item
	kcomp	count
	kcomp	type
	kcomp	true
	abortq	" ?"		; -- ud2 c-addr2 ,if not, abort with error
_zinter	kcomp	drop		; -- ud2
	kcomp	doubleq		; -- ud2 t|f ,check for double precision
	kcomp	b_not		; -- ud2 t|f
	compif	_6inter		; -- ud2
	kcomp	drop		; -- u  ,drop hi-order if not double precis
	kcomp	stat		; -- u addr
	kcomp	fetch		; -- u flag
	compif	_2inter		; -- u
	kcomp	klitera		; --
	compelse	_2inter	; -- u
_6inter	kcomp	stat		; -- ud2 addr
	kcomp	fetch		; -- ud2 flag
	compif	_2inter		; -- ud2
	kcomp	k2liter		; --
_2inter				; Then
	kcomp	kendq
	kcomp	fetch		; -- flag
	compuntil	_0inter	; Until
	kcomp	unnest

	lfa	i3
	nfa	5,'CRAS','H'	; ( --)
crash	nest
	kcomp	true
	abortq "Uninitialized execution vector."

	lfa	i3
	nfa	8,'?MISSIN','G'	; ( t|f --)
qmissing	nest
	compif	_1qmiss
	kcomp	tickwor
	kcomp	count
	kcomp	type
	kcomp	true
	abortq	"?"
_1qmiss	kcomp	unnest

	lfa	i3
	nfa	6,'STATU','S'	; ( --)
status	nest
	kcomp	stat
	kcomp	fetch
	compif	_1statu
	kcomp	pexit
_1statu	kcomp	cr
	kcomp	unnest

*--- Control Flow

	headerless
pqleave	tst.l	tos
	beq.s	1$
	adda.l	#(2*cellsize),rp
	rpop	ip
	dereftok	ip
1$	popdsp
	tonext

	lfa	i3
	nfi	6,'?LEAV','E'	; ( flag --) ( R: sys --) ( --)
qleave	nest
	kcomp	chkstat
	kcomp	parlit
	kcomp	pqleave
	kcomp	ctok
	kcomp	unnest

*--- Screen File Support

	lfa	i3
	nfa	3,'C/','L'
csll	doconst	charsperline

	lfa	i0
	nfa	5,'L/SC','R'
lslscr	doconst	linesperscreen

*--- One Extra Word for Convenience

	lfa	i0
	nfa	5,'DEBU','G'	; ( --)
kdebug	tonext			; for now just a word to breakpoint

*--- Forth Startup & Exit

forthstart

;-----------------------------------------------------------------------;
; We are just going to start from CLI and not parse our args just yet	;
;-----------------------------------------------------------------------;

saveargs		; much of this modelled on Commodore 1.3 STARTUP.ASM
	move.l	d0,d2
	move.l	a0,a2

getexec
	move.l	4,a6
	suba.l	a1,a1		; clear a1
	callos	FindTask
	move.l	d0,a4		; keep task address in a4
	move.l	pr_CLI(a4),d0	; are we CLI or Workbench?
	beq	fromwb		; no CLI means WB launched us

fromcli
	move.l	#dosname,a1	; dos.library
	moveq.l #0,d0		; version
	callos	OpenLibrary	; open DOS
	tst.l	d0		; dos lib ptr
	beq.w	nodos		; exit
	move.l	d0,a6		; for subsequent DOS calls
	tst.l	d2		; arg string count
	beq.s	loaddef		; no command line, load default image

;-----------------------------------------------------------------------;
; For now, this will only load images, no passed in command line!	;
;-----------------------------------------------------------------------;

	movea.l	a2,a0
	adda.l	d2,a0
1$	cmp.b   #' ',-(a0)   	; -TRAILING
	dbhi    d2,1$
	clr.b	1(a0)		; null terminate
2$	cmp.b	#' ',(a2)+
	bne.s	3$
	cmp.b	#0,-1(a2)
	beq.s	3$
	bra.s	2$
3$	suba.l	#1,a2		; back up to hit char
	cmp.b	#0,(a2)		; did we "bottom out" on a null?
	beq.s	loaddef		; yes, load default image
	move.l	a2,d1		; null-terminated image name from arg string
	callos	LoadSeg		; load the local image
	tst.l	d0		; check return
	bne.s	loaded		; all is well

* Otherwise, fall thru into loading the default image

loaddef	move.l	#imagename,d1	; default image
	callos	LoadSeg		; load the local image
	tst.l	d0		; check return
	beq	noimage		; abort!
loaded	lsl.l	#2,d0		; convert BPTR to address
	addq.l	#4,d0		; convert AmigaDOS segptr to codeptr
	move.l	d0,np		; set NP to point to local code image
	jsr	NSstart(np)	; jump into local image for an init
	callos	Output		; get output handle from DOS, DOS ptr in A6
	beq	nooutput	; error
	move.l	#stdout,tos	; so we can save our output handle
	move.l	d0,0(bp,tos.l)	; save to Forth variable STDOUT
	callos  Input		; get output handle from DOS, DOS ptr in A6
	beq	noinput		; error
	move.l	#stdin,tos	; so we can save our input handle
	move.l	d0,0(bp,tos.l)	; save to Forth variable STDIN
	bra.s	sharstart	; rest of stuff to do in startup

;-----------------------------------------------------------------------;
; The problem with this next body of code is that if user invokes	;
; I/O redirection, JAX4TH would defeat it by opening a window and	;
; using that handle for I/O. So JAX4TH apparently cannot be RUN		;
; unless we can find a way to determine if it is genuinely being RUN	;
; without I/O redirection .. since IsInteractive returns 0 for both	;
; RUN and I/O-redirected programs.					;
;-----------------------------------------------------------------------;

*	move.l	d0,d1
*	callos	IsInteractive
*	tst.l	d0
*	bne	sharstart
*	move.l	#_AppWindow,d1	; name of window (file) to open
*	move.l	#MODE_NEWFILE,d2	; mode
*	callos	Open
*	tst.l	d0
*	beq	noinput
*	move.l	#stdin,tos	; so we can save our input handle
*	move.l	d0,0(bp,tos.l)	; save to Forth variable STDIN
*	bra.s	sharstart	; rest of stuff to do in startup

***!!!*** Much more has to be done herebelow. Get the WBMsg, lock a dir ..

fromwb	; temporary till we figger out wbench args
	move.l	#dosname,a1	; dos.library
	moveq.l #0,d0		; version
	callos	OpenLibrary	; open DOS
	tst.l	d0		; dos lib ptr
	beq.w	nodos		; exit
	move.l	#imagename,d1	; default image
	callos	LoadSeg		; load local image, DOS ptr in A6
	tst.l	d0		; check return
	beq	nowbimage	; abort, different stack depth than cli abort
	lsl.l	#2,d0		; convert BPTR to address
	addq.l	#4,d0		; convert AmigaDOS segptr to codeptr
	move.l	d0,np		; set NP to point to local code image
	jsr	NSstart(np)	; jump into local image for an init
	move.l	#_AppWindow,d1	; name of window (file) to open
	move.l	#MODE_NEWFILE,d2	; mode
	callos	Open
	tst.l	d0
	beq	noappwin

;----------------------------------------------------------------------------;
; Eventually we will allow user to open custom window and save the address   ;
; of such a routine (coded in assembler) in the APPWIN var in a saved image. ;
; For now we will just open a NEWCON: window when launched from WB (tooltype ;
; not yet supported).							     ;
;----------------------------------------------------------------------------;

	move.l	#appwin,tos
	move.l	#-1,0(bp,tos.l)	; mark that we have opened STDIO by hand
	move.l	#stdin,tos	; so we can save our input handle
	move.l	d0,0(bp,tos.l)	; save to Forth variable STDIN
	move.l	#stdout,tos	; so we can save our output handle
	move.l	d0,0(bp,tos.l)	; save to Forth variable STDOUT

sharstart
	addi.l	#1,instant	; increment invocation instance count
	move.l	#doslib,a0	; get doslib var address
	move.l	a6,0(bp,a0.l)	; save DOS lib ptr before we mess up A6
	move.l	#spzero,tos	; save initial sp with RetAddr on top
	move.l	sp,d0		; copy of stack pointer
	move.l	sp,d1		; and another
	sub.l	bp,d0		; turn stack base address into DSeg addr
	move.l	d0,0(bp,tos.l)	; preserve initial stack pointer as DSeg addr
*	move.l	#rpsize,tos	; let's see if we have a saved RPSIZE
*	move.l	0(bp,tos.l),d0	; the defimage has a zero there
*	beq	1$		; no saved rstacksize, use default
*	cmp.l	#$800,tos	; see if we have minimum ret stack
*	bge	2$		; we have at least minimum, allocate
1$	subi.l	#$800,d1	; $800 below current SP is base of RStack
	movea.l	d1,rp		; now we have a return stack
	move.l	#rpzero,a0	; RP0 variable DSeg addr
	sub.l	bp,d1		; Convert original Return Pointer to DSeg addr
	move.l	d1,0(bp,a0.l)	; store original CATCH frame addr in CATCHER
	move.l	#execlib,a0	; get execlib var address
	move.l	4,0(bp,a0.l)	; save Exec lib ptr
	movea.l	#start,cp	; now we have a code pointer
	bra	cold		; jump to Forth

;--- flesh these out later

nodos
alertDOS:
	;------ do recoverable alert for no DOS and exit
		ALERT	(AG_OpenLib!AO_DOSLib)

noimage	; exit with error code of 20 per jax4th.doc
	move.l	a6,a1			; to close DOS library
	move.l	4,a6			; Exec
	callos	CloseLibrary		; close DOS
	move.l	#20,d0
	rts

nooutput
noinput
	move.l	#30,d0
	rts
noappwin
	move.l	np,d1			; ((LoadSeg<<2))+4
	subq.l	#4,d1			; point to segment list
	lsr.l	#2,d1			; APTR>BPTR
	callos	UnLoadSeg		; discard the local images
	move.l	a6,a1			; to close DOS library
	move.l	4,a6			; Exec
	callos	CloseLibrary		; close DOS
	move.l	#30,d0			; ret code ... correct?
	rts

nowbimage
	nop
nowbout
	nop

*--- Startup Words

	headerless
dfrini	nest	; Headerless initialisation of DEFERs.
	is	istype,ptype
	is	isemit,pemit
	is	iswhere,twodrop		; temporary
	is	isqerror,pqerror
	is	issource,psource
	kcomp	unnest

	headerless
init4th	move.l	#savelynx,a0	; init the FORTH Vocab from saved links
	move.l	#forthvoc,a1
	adda.l	bp,a1
	move.l	#numthreads,d0
	bra.s	2$
1$	move.l	(a0)+,(a1)+	; init threads
2$	dbra	d0,1$
	move.l	cellsize(a0),cellsize(a1)	; move name backpointer in
	move.l	#voclink,a0
	suba.l	bp,a1		; convert FORTH's voclink back to DSeg addr
	move.l	a1,0(bp,a0.l)	; set voclink to FORTH
	tonext

	headerless
initimp	move.l	#saveimp,a0	; init the FORTH Vocab from saved links
	move.l	#impvoc,a1
	adda.l	bp,a1
	move.l	#numthreads,d0
	bra.s	2$
1$	move.l	(a0)+,(a1)+	; init threads
2$	dbra	d0,1$
	move.l	cellsize(a0),cellsize(a1)	; move name backpointer in
	move.l	#voclink,a0
	move.l	0(bp,a0.l),(a1)	; move previous vlink into vlink of IMP
	suba.l	bp,a1		; convert IMPLEMENTORS's vlink back to DSeg addr
	move.l	a1,0(bp,a0.l)	; set voclink to IMPLEMENTOR
	tonext

* Later, put test in this to allow frozen image to specify no buffers
	headerless	; allocate fileread and block buffers
alocbuf	move.l	#(blockbuffsize+readbuffsize),d0	; requirements
	move.l	#MEMF_CLEAR,d1			; clear on allocation
	callamy	AllocMem,exec			; Exec
	move.l	#tickreadbuff,a0		; holds abs addr of readbuff
	pop	<0(bp,a0.l)>			; store abs addr, discard return
	move.l	#tickblockbuff,a0		; holds abs addr of blockbuff
	tst.l	d0				; memalloc failed?
	beq.s	_1alocb				; yes, branch away
	addi.l	#readbuffsize,d0		; no, add offset to blockbuff
	bra.s	_2alocb				; and branch to finish up
_1alocb	moveq.l	#0,d0				; err, store 0
_2alocb	move.l	d0,0(bp,a0.l)			; whatever, store
	tonext

* subroutine to be called by BYE to deallocate the above allocation
dealob	move.l	#tickreadbuff,d0
	move.l	0(bp,d0.l),d0			; allocation
	tst.l	d0				; was there an allocation?
	beq.s	_1deal				; no, branch away
	move.l	d0,a1				; mem allocation
	move.l	#(blockbuffsize+readbuffsize),d0	; size
	callamy	FreeMem,exec
	popdsp					; discard saved return
_1deal	rts

	lfa	i1
	nfa	9,'AUTOSTAR','T'	; ( -- a-addr)
autosta	docreat	autostart

	lfa	i3		; the lowest-level user-invocable startup
	nfa	4,'COL','D'	; ( --)
cold	nest
	literal	savedimage
	kcomp	fetch
	kcomp	zeroeq
	compif	_1cold		; only init if *not* a saved image
	kcomp	init4th		; init FORTH thread array
	kcomp	initimp		; init IMPLEMENTOR thread array
_1cold	kcomp	alocbuf		; allocate file and block buffers
	kcomp	dfrini		; init deferred words
	kcomp	imp		; set search order
	kcomp	also
	kcomp	forth
	kcomp	forwdls
	kcomp	setcurr		; make FORTH the current voc
	kcomp	decimal		; set number base
	kcomp	catche		; init CATCHER to "No-Catch-Frame"
	kcomp	off
	kcomp	kdpl
	kcomp	on		; default is a single number
	literal	tibuf	; TIBUF should be a memalloc(), not in data area ...
	kcomp	tickti	; ... and this init should be done at startup in asm.
	literal	lastblk	; reset most-recently-accessed-BLOCK pointer
	kcomp	off
*	kcomp	emptbuf	; clear out BLOCK buffers
	kcomp	store
	kcomp	stat	; set interpret mode
	kcomp	off
	kcomp	cap
	kcomp	on
	kcomp	autosta		; check for autostart vector
	kcomp	fetch
	kcomp	qdup		; non-null?
	kcomp	zerone
	compif	_2cold
	kcomp	execute		; yes, execute token
_2cold	kcomp	parlit
	kcomp	logo
	kcomp	ktoabs
	kcomp	abstod
	literal	logoln		; afterwards (or otherwise) continue
	kcomp	type		; display logo
	kcomp	warm

	headerless
	lfa	i3
	nfa	4,'WAR','M'	; ( --)
warm	nest
	kcomp	true
	abortq	<"ok ",10>
	tonext

	lfa	i1
	nfa	9,'INSTANCE','S'	; ( -- +n)
instanc	push	instant			; get number of instances of invocation
	tonext

	headerless			; ( -- fh | 0)
opolimg	move.l	#imagename,d1
	move.l	#MODE_OLDFILE,d2
	callamy	Open,dos
	tonext

	headerless			; ( fh -- #read | -1)
rdcdimg	pop	d1
	move.l	#tickreadbuff,d2
	move.l	0(bp,d2.l),d2
	move.l	#$100,d3	; should be enough to get hunk header
	callamy	Read,dos
	cmp.l	#$100,tos	; read what we asked for?
	beq.s	1$
	moveq.l	#-1,tos		; if not, return err
1$	tonext

	headerless			; ( -- address-of-#code-Lwords | 0)
fichimg push	#0			; dummy seg length on stack
	move.l	#$40,d0			; length of header read in Lwords
	move.l	#tickreadbuff,a0
	movea.l	0(bp,a0.l),a0			; absaddr of buff
	bra.l	2$
1$	cmp.l	#$3e9,(a0)+		; found hunk_code yet?
	beq.s	_1fich
2$	dbra.s	d0,1$
	tonext
_1fich	move.l	a0,tos			; address-of-#Lwords in code hunk	
	tonext

	headerless			; ( fh addr-#c-Lwords -- #writ | -1)
wrcdimg	move.l	#tickreadbuff,d2
	move.l	0(bp,d2.l),d2		; abs addr of write buff
	move.l	d2,d3			; copy to calc count
	sub.l	tos,d3			; inverse of offset consumed by 1st hdrs
	neg.l	d3			; positive
	addq.l	#4,d3			; add one cell for the a-c-L itself
	addi.l	#S_end,d3		; add the portion of the default image
					; which *must* be copied literally
					; to preserve relocation words
	push	d3			; save copy of count to write
	move.l	4(dsp),d1		; fh
	callamy	Write,dos		; write header info
	cmp.l	(dsp)+,tos		; ok write?
	beq.s	_1wrcd			; yes continue
	adda.l	#8,dsp			; clear stack on failure
	moveq.l	#-1,tos			; indicate failure
	tonext				; and return
_1wrcd	move.l	(dsp)+,a0		; address of count of words
	move.l	(a0),d3			; so same count to write (for now)
	lsl.l	#2,d3			; convert to bytes
	subi.l	#S_end,d3		; subtract the length of code
					; literally copied from the default
					; image above
	move.l	(dsp)+,d1		; fh
	move.l	np,d2			; "buffer" is local code segment
	addi.l	#S_end,d2		; but start copying from the RTS
					; immmediately following the portion
					; of the default image which must be
					; copied literally
	move.l	d3,tos			; copy of bytes-to-write
	callamy	Write,dos
	cmp.l	(dsp)+,tos		; ok write?
	beq.s	_2wrcd			; yes continue
	moveq.l	#-1,tos			; no, indicate err
_2wrcd	tonext

	headerless			; ( fh addr-#c-Lwords -- #read | -1)
rddimg	move.l	#tickreadbuff,d2
	move.l	0(bp,d2.l),d2
	sub.l	tos,d2			; inv. offset consumed by first headers
	neg.l	d2			; positive
	pop	a0			; a-c-L
	move.l	(a0),d0			; #data-words
	lsl.l	#2,d0
	add.l	d0,d2			; offset to end of code image
	move.l	tos,d1			; fh
	move.l	#OFFSET_BEGINNING,d3
	callamy	Seek,dos
	move.l	(dsp)+,d1		; fh
	popdsp				; discard return from Seek()
	move.l	#tickreadbuff,d2
	move.l	0(bp,d2.l),d2
	move.l	#readbuffsize,d3
	callamy	Read,dos
	cmp.l	#readbuffsize,tos	; read what we asked for?
	beq.l	1$
	moveq.l	#-1,tos			; return error on short read
1$	tonext

	headerless			; ( -- address-of-#data-Lwords | 0)
fidhimg push	#0			; dummy seg length on stack
	move.l	#(readbuffsize/4),d0	; length of header read in Lwords
	move.l	#tickreadbuff,a0
	movea.l	0(bp,a0.l),a0			; absaddr of buff
	bra.l	2$
1$	cmp.l	#$3ea,(a0)+		; found hunk_data yet?
	beq.s	_1fidh
2$	dbra.s	d0,1$
	tonext
_1fidh	move.l	a0,tos			; address-of-#Lwords in data hunk	
	tonext

	headerless			; ( fh addr-#d-Lwords -- #writ | -1)
wrdtimg	move.l	#tickreadbuff,d2
	move.l	0(bp,d2.l),d2		; abs addr of write buff
	move.l	d2,d3			; copy to calc count
	sub.l	tos,d3			; inv offset consumed by mid headers
	neg.l	d3			; positive
	addq.l	#4,d2			; add one cell for the a-d-L itself
	push	d3			; save copy of count to write
	move.l	4(dsp),d1		; fh
	callamy	Write,dos		; write header info
	cmp.l	(dsp)+,tos		; ok write?
	beq.s	_1wrdt			; yes continue
	adda.l	#8,dsp			; clear stack on failure
	moveq.l	#-1,tos			; indicate failure
	tonext				; and return
_1wrdt	move.l	(dsp)+,a0		; address of count of words
	move.l	(a0),d3			; so same count to write (for now)
	lsl.l	#2,d3			; convert to bytes
	move.l	(dsp)+,d1		; fh
	move.l	bp,d2			; "buffer" is local code segment
	move.l	d3,tos			; copy of byte write request
	callamy	Write,dos
	cmp.l	(dsp)+,tos
	beq.s	_2wrdt
	moveq.l	#-1,tos
_2wrdt	tonext

	headerless			; ( fh addr-#data-Lwords -- #read|-1)
rdtlimg	move.l	#tickreadbuff,d2
	move.l	0(bp,d2.l),d2
	sub.l	tos,d2			; inv offset consumed by middle headers
	neg.l	d2			; positive
	addq.l	#4,d2			; add one cell for the a-d-L itself
	pop	a0
	move.l	(a0),d0
	lsl.l	#2,d0
	add.l	d0,d2			; offset to end of data image + buffer
	subi.l	#readbuffsize,d2	; since we already read this much
	move.l	tos,d1			; fh
	move.l	#OFFSET_CURRENT,d3
	callamy	Seek,dos
	move.l	(dsp)+,d1		; fh
	move.l	(dsp)+,tos		; clear stack from Seek return
	move.l	#tickreadbuff,d2
	move.l	0(bp,d2.l),d2
	move.l	#readbuffsize,d3
	callamy	Read,dos
	tonext

	headerless			; ( fh #read -- #writ|-1)
wrtlimg	move.l	#tickreadbuff,d2
	move.l	0(bp,d2.l),d2
	move.l	(dsp)+,d1
	pop	d3
	callamy	Write,dos
	tonext

	lfa	i3
	nfa	10,'SAVE-IMAG','E'	; ( c-addr ct -- 0|ior)
savimg	nest
	literal	savedimage		; mark that this is saved image
	kcomp	on			; so that voc threads persist
	kcomp	modnfil			; -- addr ct x
	kcomp	creafil			; -- x ior
	kcomp	zerone			; -- x
	compif	_1savim
	kcomp	drop			; --
	literal	1			; -- 1 ,couldn't open new imagefile
	kcomp	unnest
_1savim	kcomp	opolimg			; -- x1 x2|0
	kcomp	qdup			; -- x1 [ x2 x2 ]|[0]
	kcomp	zeroeq
	compif	_2savim			; -- x1
	kcomp	closfil			; -- ior , close new imagefile
	kcomp	drop			; --
	literal	2			; -- 2 ,couldn't open old imagefile
	kcomp	unnest
_2savim	kcomp	dup			; -- x1 x2 x2
	kcomp	rdcdimg			; -- x1 x2 #read|-1
	kcomp	true
	kcomp	equal			; -- x1 x2 flag
	compif	_3savim			; -- x1 x2
	kcomp	closfil
	kcomp	drop			; -- x1
	kcomp	closfil
	kcomp	drop			; --
	literal	3			; -- 3 , couldn't read image header
	kcomp	unnest
_3savim	kcomp	fichimg			; -- x1 x2 a-c-L|0
	kcomp	qdup			; -- x1 x2 [ a-c-L a-c-L ]|0
	kcomp	zeroeq
	compif	_4savim			; -- x1 x2
	kcomp	closfil
	kcomp	drop			; -- x1
	kcomp	closfil
	kcomp	drop			; --
	literal	4			; -- 4 , couldn't find code hunk
	kcomp	unnest
_4savim	literal	2			; -- x1 x2 a-c-L 2
	kcomp	pick			; -- x1 x2 a-c-L x1
	kcomp	over			; -- x1 x2 a-c-L x1 a-c-L
	kcomp	wrcdimg			; -- x1 x2 a-c-L #read|-1
	kcomp	true
	kcomp	equal
	compif	_5savim			; -- x1 x2 a-c-L
	kcomp	drop
	kcomp	closfil
	kcomp	drop			; -- x1
	kcomp	closfil
	kcomp	drop			; --
	literal	5			; -- 5 , couldn't write new code hunk
	kcomp	unnest
_5savim	kcomp	underdu			; -- x1 x2 x2 a-c-L
	kcomp	rddimg			; -- x1 x2 #read|-1
	kcomp	true
	kcomp	equal
	compif	_6savim			; -- x1 x2
	kcomp	closfil
	kcomp	drop			; -- x1
	kcomp	closfil
	kcomp	drop			; --
	literal	6			; -- 6 , couldn't size data hunk
	kcomp	unnest
_6savim	kcomp	fidhimg			; -- x1 x2 a-d-L|0
	kcomp	qdup
	kcomp	zeroeq
	compif	_7savim			; -- x1 x2
	kcomp	closfil
	kcomp	drop			; -- x1
	kcomp	closfil
	kcomp	drop			; --
	literal	7			; -- 7 , couldn't size data hunk
	kcomp	unnest
_7savim	kcomp	tuck			; -- x1 a-d-L x2 a-d-L
	kcomp	ptwotor			; -- x1 a-d-L		R: -- x2 a-d-L
	kcomp	underdu			; -- x1 x1 a-d-L	R: -- x2 a-d-L
	kcomp	wrdtimg			; -- x1 #writ|-1	R: -- x2 a-d-L
	kcomp	true
	kcomp	equal
	compif	_8savim			; -- x1			R: -- x2 a-d-L
	kcomp	ptworfr			; -- x1 x2 a-d-L
	kcomp	twodrop			; -- x1
	kcomp	closfil
	kcomp	drop			; --
	literal	8			; -- 8 , couldn't write data hunk
	kcomp	unnest
_8savim	kcomp	ptworfr			; -- x1 x2 a-d-L
	kcomp	underdu			; -- x1 x2 x2 a-d-L
	kcomp	rdtlimg			; -- x1 x2 #read|-1
	kcomp	swap			; -- x1 #read|-1 x2
	kcomp	closfil
	kcomp	drop
	kcomp	dup			; -- x1 #read|-1 #read|-1
	kcomp	true
	kcomp	equal
	compif	_9savim			
	kcomp	drop			; -- x1
	kcomp	closfil
	kcomp	drop			; --
	literal	9			; -- 9 , couldn't get tail hunk(s)
	kcomp	unnest
_9savim	kcomp	underdu			; -- x1 x1 #read
	kcomp	wrtlimg			; -- x1 #writ|-1
	kcomp	swap
	kcomp	closfil
	kcomp	drop			; -- #writ|-1
	kcomp	true
	kcomp	equal
	compif	_endsvm
	literal	10			; -- 10 , couldn't write tail hunk(s)
	kcomp	unnest
_endsvm	kcomp	false			; -- 0 , no error
	kcomp	unnest

	lfa	2			; dpANS-2 TOOLKIT EXT
	nfa	3,'BY','E' 		; ( --)
bye	move.l	#appwin,tos		; did we open an appwin?
	move.l	0(bp,tos.l),tos		; did we open an appwin?
	beq.s	_1bye
*	cmp.l	#-1,0(bp,tos.l)		; did we open a custom appwin?
*	beq.s	_0bye
	move.l	#stdin,tos		; file handle for window
	move.l	d1,0(bp,tos.l)		; deref
	callamy Close,dos		; close it
*	bra.s	_1bye
*_0bye	
_1bye	bsr.w	dealob			; deallocate file buffers
	move.l	#spzero,a0		; stored SP from startup
	move.l	0(bp,a0.l),tos		; get original SP (as DSeg addr)
	add.l	bp,tos			; convert back to abs address
	move.l	np,d1			; ((LoadSeg<<2))+4
	subq.l	#4,d1			; point to segment list
	lsr.l	#2,d1			; APTR>BPTR
	move.l	#doslib,a0		; where we kept the DOS lib ptr
	move.l	0(bp,a0.l),a6		; our DOS lib ptr
	callos	UnLoadSeg		; discard the local images
	move.l	a6,a1			; to close DOS library
	move.l	4,a6			; Exec
	callos	CloseLibrary		; close DOS
	move.l	tos,sp			; get original SP
	subi.l	#1,instant		; decrement instance count
	rts				; exit

*--- Some Data That Doesn't Change

; We have to be able to init the FORTH Vocabulary at powerup
savelynx	dc.l	link0,link1,link2,link3,0
		kcomp	fthnam
saveimp		dc.l	linki0,linki1,linki2,linki3,0
		kcomp	impnam

dosname	dc.b	'dos.library',0

_AppWindow	dc.b	'NEWCON:0/10/400/100/Jax4th ©1991 jack j. woehr',0
	cnop	2

imagename	dc.b	'JX4:defimage.jx4',0
	cnop	2

logo	dc.b	10
	dc.b	'               JAX4TH 0.dpANS-2.3.10',10
	dc.b	'             ©1991,1992 jack j. woehr',10
	dc.b	'                All Rights Reserved.',10
	dc.b	'   Coded after X3J14 dpANS-2, ENTIRELY UNNOFICIAL',10
	dc.b	'      No Warranty, No Guarantee, No Soap Radio',10
	dc.b	'             Yer On Yer Own, Bub/Sis!',10
logoln	equ	*-logo
	cnop	2

instant	dc.l	0	; holds number of instances of invocation

	end