collapseos/forth/forth.asm

; Collapse OS' Forth
;
; Unlike other assembler parts of Collapse OS, this unit is one huge file.
;
; I do this because as Forth takes a bigger place, assembler is bound to take
; less and less place. I am thus consolidating that assembler code in one
; place so that I have a better visibility of what to minimize.
;
; I also want to reduce the featureset of the assembler so that Collapse OS
; self-hosts in a more compact manner. File include is a big part of the
; complexity in zasm. If we can get rid of it, we'll be more compact.

; *** ABI STABILITY ***
;
; This unit needs to have some of its entry points stay at a stable offset.
; These have a comment over them indicating the expected offset. These should
; not move until the Grand Bootstrapping operation has been completed.
;
; When you see random ".fill" here and there, it's to ensure that stability.

; *** Defines ***
; GETC: address of a GetC routine
; PUTC: address of a PutC routine
;
; Those GetC/PutC routines are hooked through defines and have this API:
;
; GetC: Blocks until a character is read from the device and return that
;       character in A.
;
; PutC: Write character specified in A onto the device.
;
; *** Const ***
; Base of the Return Stack
.equ	RS_ADDR		0xf000
; Number of bytes we keep as a padding between HERE and the scratchpad
.equ	PADDING		0x20
; Buffer where WORD copies its read word to.
.equ	WORD_BUFSIZE		0x20
; Allocated space for sysvars (see comment above SYSVCNT)
.equ	SYSV_BUFSIZE		0x10

; Flags for the "flag field" of the word structure
; IMMEDIATE word
.equ	FLAG_IMMED	7

; *** Variables ***
.equ	INITIAL_SP	RAMSTART
; wordref of the last entry of the dict.
.equ	CURRENT		@+2
; Pointer to the next free byte in dict.
.equ	HERE		@+2
; Interpreter pointer. See Execution model comment below.
.equ	IP		@+2
; Global flags
; Bit 0: whether the interpreter is executing a word (as opposed to parsing)
.equ	FLAGS		@+2
; Pointer to the system's number parsing function. It points to then entry that
; had the "(parse)" name at startup. During stage0, it's out builtin PARSE,
; but at stage1, it becomes "(parse)" from core.fs. It can also be changed at
; runtime.
.equ	PARSEPTR	@+2
; Pointer to the word executed by "C<". During stage0, this points to KEY.
; However, KEY ain't very interactive. This is why we implement a readline
; interface in Forth, which we plug in during init. If "(c<)" exists in the
; dict, CINPTR is set to it. Otherwise, we set KEY
.equ	CINPTR		@+2
; Pointer to (emit) word
.equ	EMITPTR		@+2
.equ	WORDBUF		@+2
; Sys Vars are variables with their value living in the system RAM segment. We
; need this mechanisms for core Forth source needing variables. Because core
; Forth source is pre-compiled, it needs to be able to live in ROM, which means
; that we can't compile a regular variable in it. SYSVNXT points to the next
; free space in SYSVBUF. Then, at the word level, it's a regular sysvarWord.
.equ	SYSVNXT		@+WORD_BUFSIZE
.equ	SYSVBUF		@+2
.equ	RAMEND		@+SYSV_BUFSIZE

; (HERE) usually starts at RAMEND, but in certain situations, such as in stage0,
; (HERE) will begin at a strategic place.
.equ	HERE_INITIAL	RAMEND

; EXECUTION MODEL
; After having read a line through readline, we want to interpret it. As
; a general rule, we go like this:
;
; 1. read single word from line
; 2. Can we find the word in dict?
; 3. If yes, execute that word, goto 1
; 4. Is it a number?
; 5. If yes, push that number to PS, goto 1
; 6. Error: undefined word.
;
; EXECUTING A WORD
;
; At it's core, executing a word is having the wordref in IY and call
; EXECUTE. Then, we let the word do its things. Some words are special,
; but most of them are of the compiledWord type, and that's their execution that
; we describe here.
;
; First of all, at all time during execution, the Interpreter Pointer (IP)
; points to the wordref we're executing next.
;
; When we execute a compiledWord, the first thing we do is push IP to the Return
; Stack (RS). Therefore, RS' top of stack will contain a wordref to execute
; next, after we EXIT.
;
; At the end of every compiledWord is an EXIT. This pops RS, sets IP to it, and
; continues.

; *** Stable ABI ***
; Those jumps below are supposed to stay at these offsets, always. If they
; change bootstrap binaries have to be adjusted because they rely on them.
; We're at 0 here
	jp	forthMain
.fill 0x17-$
JUMPTBL:
	jp	nativeWord
	jp	next
	jp	chkPS
NUMBER:
	.dw	numberWord
LIT:
	.dw	litWord

; *** Code ***
forthMain:
	; STACK OVERFLOW PROTECTION:
	; To avoid having to check for stack underflow after each pop operation
	; (which can end up being prohibitive in terms of costs), we give
	; ourselves a nice 6 bytes buffer. 6 bytes because we seldom have words
	; requiring more than 3 items from the stack. Then, at each "exit" call
	; we check for stack underflow.
	push	af \ push af \ push af
	ld	(INITIAL_SP), sp
	ld	ix, RS_ADDR
	; LATEST is a label to the latest entry of the dict. This can be
	; overridden if a binary dict has been grafted to the end of this
	; binary
	ld	hl, LATEST
	ld	(CURRENT), hl
	ld	hl, HERE_INITIAL
	ld	(HERE), hl
	; Set up PARSEPTR
	ld	hl, .parseName
	call	find
	ld	(PARSEPTR), de
	; Set up EMITPTR
	ld	hl, .emitName
	call	find
	ld	(EMITPTR), de
	; Set up CINPTR
	; do we have a (c<) impl?
	ld	hl, .cinName
	call	find
	jr	z, .skip
	; no? then use KEY
	ld	hl, .keyName
	call	find
.skip:
	ld	(CINPTR), de
	; Set up SYSVNXT
	ld	hl, SYSVBUF
	ld	(SYSVNXT), hl
	ld	hl, BEGIN
	push	hl
	jp	EXECUTE+2

.parseName:
	.db	"(parse)", 0
.cinName:
	.db	"(c<)", 0
.emitName:
	.db	"(emit)", 0
.keyName:
	.db	"KEY", 0

BEGIN:
	.dw	compiledWord
	.dw	LIT
	.db	"(c<$)", 0
	.dw	FIND_
	.dw	NOT
	.dw	CSKIP
	.dw	EXECUTE
	.dw	INTERPRET

INTERPRET:
	.dw	compiledWord
	.dw	LIT
	.db	"INTERPRET", 0
	.dw	FIND_
	.dw	DROP
	.dw	EXECUTE

.fill 31

; *** Collapse OS lib copy ***
; In the process of Forth-ifying Collapse OS, apps will be slowly rewritten to
; Forth and the concept of ASM libs will become obsolete. To facilitate this
; transition, I make, right now, a copy of the routines actually used by Forth's
; native core. This also has the effect of reducing binary size right now and
; give us an idea of Forth's compactness.
; These routines below are copy/paste from apps/lib and stdio.

; copy (HL) into DE, then exchange the two, utilising the optimised HL instructions.
; ld must be done little endian, so least significant byte first.
intoHL:
	push 	de
	ld 	e, (hl)
	inc 	hl
	ld 	d, (hl)
	ex 	de, hl
	pop 	de
	ret

; add the value of A into HL
; affects carry flag according to the 16-bit addition, Z, S and P untouched.
addHL:
	push	de
	ld 	d, 0
	ld	e, a
	add	hl, de
	pop	de
	ret

; Copy string from (HL) in (DE), that is, copy bytes until a null char is
; encountered. The null char is also copied.
; HL and DE point to the char right after the null char.
; B indicates the length of the copied string, including null-termination.
strcpy:
	ld	b, 0
.loop:
	ld	a, (hl)
	ld	(de), a
	inc	hl
	inc	de
	inc	b
	or	a
	jr	nz, .loop
	ret

; Compares strings pointed to by HL and DE until one of them hits its null char.
; If equal, Z is set. If not equal, Z is reset. C is set if HL > DE
strcmp:
	push	hl
	push	de

.loop:
	ld	a, (de)
	cp	(hl)
	jr	nz, .end	; not equal? break early. NZ is carried out
				; to the caller
	or	a		; If our chars are null, stop the cmp
	inc	hl
	inc	de
	jr	nz, .loop	; Z is carried through

.end:
	pop	de
	pop	hl
	; Because we don't call anything else than CP that modify the Z flag,
	; our Z value will be that of the last cp (reset if we broke the loop
	; early, set otherwise)
	ret

; Given a string at (HL), move HL until it points to the end of that string.
strskip:
	push	bc
	ex	af, af'
	xor	a	; look for null char
	ld	b, a
	ld	c, a
	cpir	; advances HL regardless of comparison, so goes one too far
	dec	hl
	ex	af, af'
	pop	bc
	ret

; Parse string at (HL) as a decimal value and return value in DE.
; Reads as many digits as it can and stop when:
; 1 - A non-digit character is read
; 2 - The number overflows from 16-bit
; HL is advanced to the character following the last successfully read char.
; Error conditions are:
; 1 - There wasn't at least one character that could be read.
; 2 - Overflow.
; Sets Z on success, unset on error.

parseDecimal:
	; First char is special: it has to succeed.
	ld	a, (hl)
	cp	'-'
	jr	z, .negative
	; Parse the decimal char at A and extract it's 0-9 numerical value. Put the
	; result in A.
	; On success, the carry flag is reset. On error, it is set.
	add	a, 0xff-'9'	; maps '0'-'9' onto 0xf6-0xff
	sub	0xff-9		; maps to 0-9 and carries if not a digit
	ret	c		; Error. If it's C, it's also going to be NZ
	; During this routine, we switch between HL and its shadow. On one side,
	; we have HL the string pointer, and on the other side, we have HL the
	; numerical result. We also use EXX to preserve BC, saving us a push.
	exx		; HL as a result
	ld	h, 0
	ld	l, a	; load first digit in without multiplying

.loop:
	exx		; HL as a string pointer
	inc hl
	ld a, (hl)
	exx		; HL as a numerical result

	; same as other above
	add	a, 0xff-'9'
	sub	0xff-9
	jr	c, .end

	ld	b, a	; we can now use a for overflow checking
	add	hl, hl	; x2
	sbc	a, a	; a=0 if no overflow, a=0xFF otherwise
	ld	d, h
	ld	e, l		; de is x2
	add	hl, hl	; x4
	rla
	add	hl, hl	; x8
	rla
	add	hl, de	; x10
	rla
	ld	d, a	; a is zero unless there's an overflow
	ld	e, b
	add	hl, de
	adc	a, a	; same as rla except affects Z
	; Did we oveflow?
	jr	z, .loop	; No? continue
	; error, NZ already set
	exx		; HL is now string pointer, restore BC
	; HL points to the char following the last success.
	ret

.end:
	push	hl	; --> lvl 1, result
	exx		; HL as a string pointer, restore BC
	pop	de	; <-- lvl 1, result
	cp	a	; ensure Z
	ret

.negative:
	inc	hl
	call	parseDecimal
	ret	nz
	push	hl	; --> lvl 1
	or	a	; clear carry
	ld	hl, 0
	sbc	hl, de
	ex	de, hl
	pop	hl	; <-- lvl 1
	xor	a	; set Z
	ret

; *** Support routines ***
; Find the entry corresponding to word where (HL) points to and sets DE to
; point to that entry.
; Z if found, NZ if not.
find:
	push	bc
	push	hl
	; First, figure out string len
	ld	bc, 0
	xor	a
	cpir
	; C has our length, negative, -1
	ld	a, c
	neg
	dec	a
	; special case. zero len? we never find anything.
	jr	z, .fail
	ld	c, a		; C holds our length
	; Let's do something weird: We'll hold HL by the *tail*. Because of our
	; dict structure and because we know our lengths, it's easier to
	; compare starting from the end. Currently, after CPIR, HL points to
	; char after null. Let's adjust
	; Because the compare loop pre-decrements, instead of DECing HL twice,
	; we DEC it once.
	dec	hl
	ld	de, (CURRENT)
.inner:
	; DE is a wordref. First step, do our len correspond?
	push	hl		; --> lvl 1
	push	de		; --> lvl 2
	dec	de
	ld	a, (de)
	and	0x7f		; remove IMMEDIATE flag
	cp	c
	jr	nz, .loopend
	; match, let's compare the string then
	dec	de \ dec de	; skip prev field. One less because we
				; pre-decrement
	ld	b, c		; loop C times
.loop:
	; pre-decrement for easier Z matching
	dec	de
	dec	hl
	ld	a, (de)
	cp	(hl)
	jr	nz, .loopend
	djnz	.loop
.loopend:
	; At this point, Z is set if we have a match. In all cases, we want
	; to pop HL and DE
	pop	de		; <-- lvl 2
	pop	hl		; <-- lvl 1
	jr	z, .end		; match? we're done!
	; no match, go to prev and continue
	push	hl			; --> lvl 1
	dec	de \ dec de \ dec de	; prev field
	push	de			; --> lvl 2
	ex 	de, hl
	call 	intoHL
	ex 	de, hl			; DE contains prev offset
	pop	hl			; <-- lvl 2
	; HL is prev field's addr
	; Is offset zero?
	ld	a, d
	or	e
	jr	z, .noprev		; no prev entry
	; get absolute addr from offset
	; carry cleared from "or e"
	sbc	hl, de
	ex	de, hl			; result in DE
.noprev:
	pop	hl			; <-- lvl 1
	jr	nz, .inner		; try to match again
	; Z set? end of dict unset Z
.fail:
	xor	a
	inc	a
.end:
	pop	hl
	pop	bc
	ret

; Checks flags Z and S and sets BC to 0 if Z, 1 if C and -1 otherwise
flagsToBC:
	ld	bc, 0
	ret	z	; equal
	inc	bc
	ret	m	; >
	; <
	dec	bc
	dec	bc
	ret

; Write DE in (HL), advancing HL by 2.
DEinHL:
	ld	(hl), e
	inc	hl
	ld	(hl), d
	inc	hl
	ret

; *** Stack management ***
; The Parameter stack (PS) is maintained by SP and the Return stack (RS) is
; maintained by IX. This allows us to generally use push and pop freely because
; PS is the most frequently used. However, this causes a problem with routine
; calls: because in Forth, the stack isn't balanced within each call, our return
; offset, when placed by a CALL, messes everything up. This is one of the
; reasons why we need stack management routines below. IX always points to RS'
; Top Of Stack (TOS)
;
; This return stack contain "Interpreter pointers", that is a pointer to the
; address of a word, as seen in a compiled list of words.

; Push value HL to RS
pushRS:
	inc	ix
	inc	ix
	ld	(ix), l
	ld	(ix+1), h
	ret

; Pop RS' TOS to HL
popRS:
	ld	l, (ix)
	ld	h, (ix+1)
	dec ix
	dec ix
	ret

popRSIP:
	call	popRS
	ld	(IP), hl
	ret

; Verifies that SP and RS are within bounds. If it's not, call ABORT
chkRS:
	push	ix \ pop hl
	push	de		; --> lvl 1
	ld	de, RS_ADDR
	or	a		; clear carry
	sbc	hl, de
	pop	de		; <-- lvl 1
	jp	c, abortUnderflow
	ret

chkPS:
	push	hl
	ld	hl, (INITIAL_SP)
	; We have the return address for this very call on the stack and
	; protected registers. Let's compensate
	dec	hl \ dec hl
	dec	hl \ dec hl
	or	a		; clear carry
	sbc	hl, sp
	pop	hl
	ret	nc		; (INITIAL_SP) >= SP? good
	jp	abortUnderflow

; *** Dictionary ***
; It's important that this part is at the end of the resulting binary.
; A dictionary entry has this structure:
; - Xb name. Arbitrary long number of character (but can't be bigger than
;   input buffer, of course). not null-terminated
; - 2b prev offset
; - 1b size + IMMEDIATE flag
; - 2b code pointer
; - Parameter field (PF)
;
; The prev offset is the number of bytes between the prev field and the
; previous word's code pointer.
;
; The size + flag indicate the size of the name field, with the 7th bit
; being the IMMEDIATE flag.
;
; The code pointer point to "word routines". These routines expect to be called
; with IY pointing to the PF. They themselves are expected to end by jumping
; to the address at (IP). They will usually do so with "jp next".
;
; That's for "regular" words (words that are part of the dict chain). There are
; also "special words", for example NUMBER, LIT, FBR, that have a slightly
; different structure. They're also a pointer to an executable, but as for the
; other fields, the only one they have is the "flags" field.

; This routine is jumped to at the end of every word. In it, we jump to current
; IP, but we also take care of increasing it my 2 before jumping
next:
	; Before we continue: are stacks within bounds?
	call	chkPS
	call	chkRS
	ld	de, (IP)
	ld	h, d
	ld	l, e
	inc	de \ inc de
	ld	(IP), de
	; HL is an atom list pointer. We need to go into it to have a wordref
	ld	e, (hl)
	inc	hl
	ld	d, (hl)
	push	de
	jp	EXECUTE+2


; Execute a word containing native code at its PF address (PFA)
nativeWord:
	jp	(iy)

; Execute a list of atoms, which always end with EXIT.
; IY points to that list. What do we do:
; 1. Push current IP to RS
; 2. Set new IP to the second atom of the list
; 3. Execute the first atom of the list.
compiledWord:
	ld	hl, (IP)
	call	pushRS
	push	iy \ pop hl
	inc	hl
	inc	hl
	ld	(IP), hl
	; IY still is our atom reference...
	ld	l, (iy)
	ld	h, (iy+1)
	push	hl	; argument for EXECUTE
	jp	EXECUTE+2

; Pushes the PFA directly
cellWord:
	push	iy
	jp	next

; Pushes the address in the first word of the PF
sysvarWord:
	ld	l, (iy)
	ld	h, (iy+1)
	push	hl
	jp	next

; The word was spawned from a definition word that has a DOES>. PFA+2 (right
; after the actual cell) is a link to the slot right after that DOES>.
; Therefore, what we need to do push the cell addr like a regular cell, then
; follow the link from the PFA, and then continue as a regular compiledWord.
doesWord:
	push	iy	; like a regular cell
	ld	l, (iy+2)
	ld	h, (iy+3)
	push	hl \ pop iy
	jr	compiledWord

; This is not a word, but a number literal. This works a bit differently than
; others: PF means nothing and the actual number is placed next to the
; numberWord reference in the compiled word list. What we need to do to fetch
; that number is to play with the IP.
numberWord:
	ld	hl, (IP)	; (HL) is out number
	ld	e, (hl)
	inc	hl
	ld	d, (hl)
	inc	hl
	ld	(IP), hl	; advance IP by 2
	push	de
	jp	next

; Similarly to numberWord, this is not a real word, but a string literal.
; Instead of being followed by a 2 bytes number, it's followed by a
; null-terminated string. When called, puts the string's address on PS
litWord:
	ld	hl, (IP)
	push	hl
	call	strskip
	inc	hl		; after null termination
	ld	(IP), hl
	jp	next

; Pop previous IP from Return stack and execute it.
; ( R:I -- )
	.db	"EXIT"
	.dw	0
	.db	4
EXIT:
	.dw nativeWord
	call	popRSIP
	jp	next

; ( R:I -- )
	.db "QUIT"
	.dw $-EXIT
	.db 4
QUIT:
	.dw compiledWord
	.dw	NUMBER
	.dw	0
	.dw	FLAGS_
	.dw	STORE
	.dw	.private
	.dw	INTERPRET

.private:
	.dw	nativeWord
	ld	ix, RS_ADDR
	jp	next

	.db "ABORT"
	.dw $-QUIT
	.db 5
ABORT:
	.dw	compiledWord
	.dw	.private
	.dw	QUIT

.private:
	.dw	nativeWord
	; Reinitialize PS
	ld	sp, (INITIAL_SP)
	jp	next

abortUnderflow:
	ld	hl, .word
	push	hl
	jp	EXECUTE+2
.word:
	.dw	compiledWord
	.dw	LIT
	.db	"stack underflow", 0
	.dw	PRINT
	.dw	ABORT

	.db "BYE"
	.dw $-ABORT
	.db 3
BYE:
	.dw nativeWord
	halt

; ( c -- )
	.db "EMIT"
	.dw $-BYE
	.db 4
EMIT:
	.dw	compiledWord
	.dw	NUMBER
	.dw	EMITPTR
	.dw	FETCH
	.dw	EXECUTE
	.dw	EXIT


	.db	"(print)"
	.dw	$-EMIT
	.db	7
PRINT:
	.dw	compiledWord	; a
	; BBR mark
	.dw	DUP		; a a
	.dw	.getc		; a c
	.dw	DUP		; a c f
	.dw	CSKIP		; a c
	; zero, end of string
	.dw	FBR
	.db	12
	.dw	EMIT		; a
	.dw	NUMBER		; a 1
	.dw	1
	.dw	PLUS		; a+1
	.dw	BBR
	.db	21
	; FBR mark
	.dw	DROP
	.dw	DROP
	.dw	EXIT

; Yes, very much like C@, but it has already been Forth-ified...
.getc:
	.dw	nativeWord
	pop	hl
	call	chkPS
	ld	l, (hl)
	ld	h, 0
	push	hl
	jp	next


	.db	"C,"
	.dw	$-PRINT
	.db	2
CWR:
	.dw	nativeWord
	pop	de
	call	chkPS
	ld	hl, (HERE)
	ld	(hl), e
	inc	hl
	ld	(HERE), hl
	jp	next


	.db	","
	.dw	$-CWR
	.db	1
WR:
	.dw	nativeWord
	pop	de
	call	chkPS
	ld	hl, (HERE)
	call	DEinHL
	ld	(HERE), hl
	jp	next


	.db	"ROUTINE"
	.dw	$-WR
	.db	0x87			; IMMEDIATE
ROUTINE:
	.dw	compiledWord
	.dw	WORD
	.dw	.private
	.dw	EXIT

.private:
	.dw	nativeWord
	pop	hl
	call	chkPS
	ld	a, (hl)
	ld	de, cellWord
	cp	'C'
	jr	z, .end
	ld	de, compiledWord
	cp	'L'
	jr	z, .end
	ld	de, JUMPTBL
	cp	'V'
	jr	z, .end
	ld	de, JUMPTBL+3
	cp	'N'
	jr	z, .end
	ld	de, sysvarWord
	cp	'Y'
	jr	z, .end
	ld	de, doesWord
	cp	'D'
	jr	z, .end
	ld	de, LIT
	cp	'S'
	jr	z, .end
	ld	de, NUMBER
	cp	'M'
	jr	z, .end
	ld	de, JUMPTBL+6
	cp	'P'
	jr	nz, .notgood
	; continue to end on match
.end:
	; is our slen 1?
	inc	hl
	ld	a, (hl)
	or	a
	jr	z, .good
.notgood:
	ld	de, 0
.good:
	push	de
	jp	next

; ( addr -- )
	.db "EXECUTE"
	.dw $-ROUTINE
	.db 7
; STABLE ABI
; Offset: 0388
.out $
EXECUTE:
	.dw nativeWord
	pop	iy	; is a wordref
	call	chkPS
	ld	l, (iy)
	ld	h, (iy+1)
	; HL points to code pointer
	inc	iy
	inc	iy
	; IY points to PFA
	jp	(hl)	; go!


	.db	";"
	.dw	$-EXECUTE
	.db	0x81		; IMMEDIATE
ENDDEF:
	.dw	compiledWord
	.dw	NUMBER
	.dw	EXIT
	.dw	WR
	.dw	R2P		; exit COMPILE
	.dw	DROP
	.dw	R2P		; exit DEFINE
	.dw	DROP
	.dw	EXIT

	.db	":"
	.dw	$-ENDDEF
	.db	0x81		; IMMEDIATE
DEFINE:
	.dw	compiledWord
	.dw	ENTRYHEAD
	.dw	NUMBER
	.dw	compiledWord
	.dw	WR
	; BBR branch mark
	.dw	.compile
	.dw	BBR
	.db	4
	; no need for EXIT, ENDDEF takes care of taking us out

.compile:
	.dw	compiledWord
	.dw	WORD
	.dw	FIND_
	.dw	NOT
	.dw	CSKIP
	.dw	FBR
	.db	7
	; Maybe number
	.dw	PARSEI
	.dw	LITN
	.dw	EXIT
	; FBR mark
	.dw	DUP
	.dw	ISIMMED
	.dw	CSKIP
	.dw	FBR
	.db	5
	; is immediate. just execute.
	.dw	EXECUTE
	.dw	EXIT
	; FBR mark
	; just a word, write
	.dw	WR
	.dw	EXIT



	.db "DOES>"
	.dw $-DEFINE
	.db 5
DOES:
	.dw nativeWord
	; We run this when we're in an entry creation context. Many things we
	; need to do.
	; 1. Change the code link to doesWord
	; 2. Leave 2 bytes for regular cell variable.
	; 3. Write down IP+2 to entry.
	; 3. exit. we're done here.
	ld	hl, (CURRENT)
	ld	de, doesWord
	call	DEinHL
	inc	hl \ inc hl		; cell variable space
	ld	de, (IP)
	call	DEinHL
	ld	(HERE), hl
	jp	EXIT+2


	.db "IMMEDIATE"
	.dw $-DOES
	.db 9
IMMEDIATE:
	.dw nativeWord
	ld	hl, (CURRENT)
	dec	hl
	set	FLAG_IMMED, (hl)
	jp	next


	.db	"IMMED?"
	.dw	$-IMMEDIATE
	.db	6
ISIMMED:
	.dw	nativeWord
	pop	hl
	call	chkPS
	dec	hl
	ld	de, 0
	bit	FLAG_IMMED, (hl)
	jr	z, .notset
	inc	de
.notset:
	push	de
	jp	next

; ( n -- )
	.db	"LITN"
	.dw	$-ISIMMED
	.db	4
LITN:
	.dw nativeWord
	ld	hl, (HERE)
	ld	de, NUMBER
	call	DEinHL
	pop	de		; number from stack
	call	chkPS
	call	DEinHL
	ld	(HERE), hl
	jp	next

	.db	"SCPY"
	.dw	$-LITN
	.db	4
SCPY:
	.dw	nativeWord
	pop	hl
	ld	de, (HERE)
	call	strcpy
	ld	(HERE), de
	jp	next


	.db	"(find)"
	.dw	$-SCPY
	.db	6
; STABLE ABI
; Offset: 047c
.out $
FIND_:
	.dw	nativeWord
	pop	hl
	call	find
	jr	z, .found
	; not found
	push	hl
	ld	de, 0
	push	de
	jp	next
.found:
	push	de
	ld	de, 1
	push	de
	jp	next

; This is an indirect word that can be redirected through "CINPTR"
; code: it is replaced in readln.fs.
	.db "C<"
	.dw $-FIND_
	.db 2
CIN:
	.dw	compiledWord
	.dw	NUMBER
	.dw	CINPTR
	.dw	FETCH
	.dw	EXECUTE
	.dw	EXIT


; ( c -- f )
; 33 CMP 1 + NOT
; The NOT is to normalize the negative/positive numbers to 1 or 0.
; Hadn't we wanted to normalize, we'd have written:
; 32 CMP 1 -
	.db	"WS?"
	.dw	$-CIN
	.db	3
ISWS:
	.dw	compiledWord
	.dw	NUMBER
	.dw	33
	.dw	CMP
	.dw	NUMBER
	.dw	1
	.dw	PLUS
	.dw	NOT
	.dw	EXIT

	.db	"NOT"
	.dw	$-ISWS
	.db	3
NOT:
	.dw	nativeWord
	pop	hl
	call	chkPS
	ld	a, l
	or	h
	ld	hl, 0
	jr	nz, .skip	; true, keep at 0
	; false, make 1
	inc	hl
.skip:
	push	hl
	jp	next

; ( -- c )
; C< DUP 32 CMP 1 - SKIP? EXIT DROP TOWORD
	.db	"TOWORD"
	.dw	$-NOT
	.db	6
TOWORD:
	.dw	compiledWord
	.dw	CIN
	.dw	DUP
	.dw	ISWS
	.dw	CSKIP
	.dw	EXIT
	.dw	DROP
	.dw	TOWORD
	.dw	EXIT

; Read word from C<, copy to WORDBUF, null-terminate, and return, make
; HL point to WORDBUF.
	.db "WORD"
	.dw $-TOWORD
	.db 4
; STABLE ABI
; Offset: 04f7
.out $
WORD:
	.dw	compiledWord
	.dw	NUMBER		; ( a )
	.dw	WORDBUF
	.dw	TOWORD		; ( a c )
	; branch mark
	.dw	OVER		; ( a c a )
	.dw	STORE		; ( a )
	.dw	NUMBER		; ( a 1 )
	.dw	1
	.dw	PLUS		; ( a+1 )
	.dw	CIN		; ( a c )
	.dw	DUP		; ( a c c )
	.dw	ISWS		; ( a c f )
	.dw	CSKIP		; ( a c )
	.dw	BBR
	.db	20	; here - mark
	; at this point, we have ( a WS )
	.dw	DROP
	.dw	NUMBER
	.dw	0
	.dw	SWAP		; ( 0 a )
	.dw	STORE		; ()
	.dw	NUMBER
	.dw	WORDBUF
	.dw	EXIT

.wcpy:
	.dw	nativeWord
	ld	de, WORDBUF
	push	de		; we already have our result
.loop:
	ld	a, (hl)
	cp	' '+1
	jr	c, .loopend
	ld	(de), a
	inc	hl
	inc	de
	jr	.loop
.loopend:
	; null-terminate the string.
	xor	a
	ld	(de), a
	jp	next


	.db	"(parsed)"
	.dw	$-WORD
	.db	8
PARSED:
	.dw	nativeWord
	pop	hl
	call	chkPS
	call	parseDecimal
	jr	z, .success
	; error
	ld	de, 0
	push	de	; dummy
	push	de	; flag
	jp	next
.success:
	push	de
	ld	de, 1		; flag
	push	de
	jp	next


	.db	"(parse)"
	.dw	$-PARSED
	.db	7
PARSE:
	.dw	compiledWord
	.dw	PARSED
	.dw	CSKIP
	.dw	.error
	; success, stack is already good, we can exit
	.dw	EXIT

.error:
	.dw	compiledWord
	.dw	LIT
	.db	"unknown word", 0
	.dw	PRINT
	.dw	ABORT


; Indirect parse caller. Reads PARSEPTR and calls
PARSEI:
	.dw	compiledWord
	.dw	PARSEPTR_
	.dw	FETCH
	.dw	EXECUTE
	.dw	EXIT


; Spit name (in (HL)) + prev in (HERE) and adjust (HERE) and (CURRENT)
; HL points to new (HERE)
	.db	"(entry)"
	.dw	$-PARSE
	.db	7
ENTRYHEAD:
	.dw	compiledWord
	.dw	WORD
	.dw	.private
	.dw	EXIT

.private:
	.dw	nativeWord
	pop	hl
	ld	de, (HERE)
	call	strcpy
	; DE point to char after null, rewind.
	dec	de
	; B counts the null, adjust
	dec	b
	ld	a, b
	ex	de, hl		; HL points to new HERE
	ld	de, (CURRENT)
	push	hl		; --> lvl 1
	or	a	; clear carry
	sbc	hl, de
	ex	de, hl
	pop	hl		; <-- lvl 1
	call	DEinHL
	; Save size
	ld	(hl), b
	inc	hl
	ld	(CURRENT), hl
	ld	(HERE), hl
	jp	next


; STABLE ABI (every sysvars)
; Offset: 05ca
.out $
	.db "HERE"
	.dw $-ENTRYHEAD
	.db 4
HERE_:	; Caution: conflicts with actual variable name
	.dw sysvarWord
	.dw HERE

	.db "CURRENT"
	.dw $-HERE_
	.db 7
CURRENT_:
	.dw sysvarWord
	.dw CURRENT

	.db "(parse*)"
	.dw $-CURRENT_
	.db 8
PARSEPTR_:
	.dw sysvarWord
	.dw PARSEPTR

	.db	"FLAGS"
	.dw	$-PARSEPTR_
	.db	5
FLAGS_:
	.dw	sysvarWord
	.dw	FLAGS

	.db	"SYSVNXT"
	.dw	$-FLAGS_
	.db	7
SYSVNXT_:
	.dw	sysvarWord
	.dw	SYSVNXT

; ( n a -- )
	.db "!"
	.dw $-SYSVNXT_
	.db 1
; STABLE ABI
; Offset: 0610
.out $
STORE:
	.dw nativeWord
	pop	iy
	pop	hl
	call	chkPS
	ld	(iy), l
	ld	(iy+1), h
	jp	next

; ( a -- n )
	.db "@"
	.dw $-STORE
	.db 1
FETCH:
	.dw nativeWord
	pop	hl
	call	chkPS
	call	intoHL
	push	hl
	jp	next

; ( a -- )
	.db "DROP"
	.dw $-FETCH
	.db 4
DROP:
	.dw nativeWord
	pop	hl
	jp	next

; ( a b -- b a )
	.db "SWAP"
	.dw $-DROP
	.db 4
SWAP:
	.dw nativeWord
	pop	hl
	call	chkPS
	ex	(sp), hl
	push	hl
	jp	next

; ( a -- a a )
	.db "DUP"
	.dw $-SWAP
	.db 3
DUP:
	.dw nativeWord
	pop	hl
	call	chkPS
	push	hl
	push	hl
	jp	next

; ( a b -- a b a )
	.db "OVER"
	.dw $-DUP
	.db 4
OVER:
	.dw nativeWord
	pop	hl	; B
	pop	de	; A
	call	chkPS
	push	de
	push	hl
	push	de
	jp	next

	.db	">R"
	.dw	$-OVER
	.db	2
P2R:
	.dw	nativeWord
	pop	hl
	call	chkPS
	call	pushRS
	jp	next

	.db	"R>"
	.dw	$-P2R
	.db	2
R2P:
	.dw	nativeWord
	call	popRS
	push	hl
	jp	next

; ( a b -- c ) A + B
	.db "+"
	.dw $-R2P
	.db 1
PLUS:
	.dw nativeWord
	pop	hl
	pop	de
	call	chkPS
	add	hl, de
	push	hl
	jp	next

; ( a b -- c ) A - B
	.db "-"
	.dw $-PLUS
	.db 1
MINUS:
	.dw nativeWord
	pop	de		; B
	pop	hl		; A
	call	chkPS
	or	a		; reset carry
	sbc	hl, de
	push	hl
	jp	next

; ( a1 a2 -- b )
	.db "SCMP"
	.dw $-MINUS
	.db 4
SCMP:
	.dw nativeWord
	pop	de
	pop	hl
	call	chkPS
	call	strcmp
	call	flagsToBC
	push	bc
	jp	next

; ( n1 n2 -- f )
	.db "CMP"
	.dw $-SCMP
	.db 3
CMP:
	.dw nativeWord
	pop	hl
	pop	de
	call	chkPS
	or	a	; clear carry
	sbc	hl, de
	call	flagsToBC
	push	bc
	jp	next

; Skip the compword where HL is currently pointing. If it's a regular word,
; it's easy: we inc by 2. If it's a NUMBER, we inc by 4. If it's a LIT, we skip
; to after null-termination.
	.db	"SKIP?"
	.dw	$-CMP
	.db	5
; STABLE ABI
; Offset: 06ee
.out $
CSKIP:
	.dw	nativeWord
	pop	hl
	call	chkPS
	ld	a, h
	or	l
	jp	z, next		; False, do nothing.
	ld	hl, (IP)
	ld	de, NUMBER
	call	.HLPointsDE
	jr	z, .isNum
	ld	de, FBR
	call	.HLPointsDE
	jr	z, .isBranch
	ld	de, BBR
	call	.HLPointsDE
	jr	z, .isBranch
	ld	de, LIT
	call	.HLPointsDE
	jr	nz, .isWord
	; We have a literal
	inc	hl \ inc hl
	call	strskip
	inc	hl		; byte after word termination
	jr	.end
.isNum:
	; skip by 4
	inc	hl
	; continue to isBranch
.isBranch:
	; skip by 3
	inc	hl
	; continue to isWord
.isWord:
	; skip by 2
	inc	hl \ inc hl
.end:
	ld	(IP), hl
	jp	next

; Sets Z if (HL) == E and (HL+1) == D
.HLPointsDE:
	ld	a, (hl)
	cp	e
	ret	nz		; no
	inc	hl
	ld	a, (hl)
	dec	hl
	cp	d		; Z has our answer
	ret

; This word's atom is followed by 1b *relative* offset (to the cell's addr) to
; where to branch to. For example, The branching cell of "IF THEN" would
; contain 3. Add this value to RS.
	.db	"(fbr)"
	.dw	$-CSKIP
	.db	5
; STABLE ABI
; Offset: 073e
.out $
FBR:
	.dw	nativeWord
	push	de
	ld	hl, (IP)
	ld	a, (hl)
	call	addHL
	ld	(IP), hl
	pop	de
	jp	next

	.db	"(bbr)"
	.dw	$-FBR
	.db	5
; STABLE ABI
; Offset: 0757
.out $
BBR:
	.dw	nativeWord
	ld	hl, (IP)
	ld	d, 0
	ld	e, (hl)
	or	a		; clear carry
	sbc	hl, de
	ld	(IP), hl
	jp	next

; To allow dict binaries to "hook themselves up", we always end such binary
; with a dummy, *empty* entry. Therefore, we can have a predictable place for
; getting a prev label.
	.dw	$-BBR
	.db	0