forth: add bin dict compilation stage!

Big one.

This allows us to write higher order words directly in Forth, which is much
more convenient than writing post-immediate (see "NOT" structure in diff if
you want to see what I mean) structures in ASM.

These structures can then be written to ROM (rather than loaded in RAM for
definitions loaded at run-time).

That's quite a bit of tooling that was added, 2 compilations stages, but I
think it's well worth it.

apps/forth/core.fth

@@ -0,0 +1,9 @@
+: ? @ . ;
+: +! SWAP OVER @ + SWAP ! ;
+: ALLOT HERE +! ;
+: VARIABLE CREATE 2 ALLOT ;
+: CONSTANT CREATE HERE @ ! DOES> @ ;
+: NOT IF 0 ELSE 1 THEN ;
+: = CMP NOT ;
+: < CMP 0 1 - = ;
+: > CMP 1 = ;

apps/forth/dict.asm

@@ -51,69 +51,40 @@ doesWord:
 	push	hl \ pop iy
 	jr	compiledWord
 
-; The IF word checks the stack for zero. If it's non-zero, it does nothing and
-; allow compiledWord to continue.
-; If it's zero, it tracksback RS, advance it until it finds a ELSE, a THEN, or
-; an EXIT (not supposed to happen unless the IF is misconstructed). Whether
-; it's a ELSE or THEN, the same thing happens: we resume execution after the
-; ELSE/THEN. If it's a EXIT, we simply execute it.
-ifWord:
+; This word 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.
+branchWord:
+	push	de
+	ld	l, (ix)
+	ld	h, (ix+1)
+	ld	a, (hl)
+	call	addHL
+	ld	(ix), l
+	ld	(ix+1), h
+	pop	de
+	jp	exit
+
+BRANCH:
+	.dw	branchWord
+
+; Conditional branch, only branch if TOS is zero
+cbranchWord:
 	pop	hl
 	ld	a, h
 	or	l
-	jp	nz, exit	; non-zero, continue
-	; Zero, seek ELSE, THEN or EXIT. Continue to elseWord
-
-; If a ELSE word is executed, it means that the preceding IF had a non-zero
-; condition and continued execution. This means that upon encountering an ELSE,
-; we must search for a THEN or an EXIT.
-; To simplify implementation and share code with ifWord, we also match ELSE,
-; which is only possible in malformed construct. Therefore "IF ELSE ELSE" is
-; valid and interpreted as "IF ELSE THEN".
-elseWord:
-	; to save processing, we test EXIT, ELSE and THEN in the order they
-	; appear, address-wise. This way, we don't need to push/pop HL: we can
-	; SUB the difference between the words and check for zeroes.
-	call	popRS
-	; We need to save that IP somewhere. Let it be BC
-	ld	b, h
-	ld	c, l
-.loop:
-	; Whether there's a match or not, we will resume the operation at IP+2,
-	; which means that we have to increase BC anyways. Let's do it now.
-	inc	bc \ inc bc
-	call	intoHL
-	or	a		; clear carry
-	ld	de, EXIT
-	sbc	hl, de
-	jp	z, exit
-	; Not EXIT, let's continue with ELSE. No carry possible because EXIT
-	; is first word. No need to clear.
-	ld	de, ELSE-EXIT
-	sbc	hl, de
-	jr	c, .nomatch	; A word between EXIT and ELSE. No match.
-	jr	z, .match	; We have a ELSE
-	; Let's try with THEN. Again, no carry possible, C cond was handled.
-	ld	de, THEN-ELSE
-	sbc	hl, de
-	jr	z, .match	; We have a THEN
-.nomatch:
-	; Nothing matched, which means that we need to continue looking.
-	; BC is already IP+2
-	ld	h, b
-	ld	l, c
-	jr	.loop
-.match:
-	; Matched a ELSE or a THEN, which means we need to continue executing
-	; word from IP+2, which is already in BC.
-	push	bc \ pop iy
-	jp	compiledWord
-
-; This word does nothing. It's never going to be executed unless the wordlist
-; is misconstructed.
-thenWord:
+	jr	z, branchWord
+	; skip next byte in RS
+	ld	l, (ix)
+	ld	h, (ix+1)
+	inc	hl
+	ld	(ix), l
+	ld	(ix+1), h
 	jp	exit
 
+CBRANCH:
+	.dw	cbranchWord
+
 ; 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
@@ -121,12 +92,14 @@ thenWord:
 ; it to the Parameter stack and then push an increase Interpreter Pointer back
 ; to RS.
 numberWord:
-	call	popRS
+	ld	l, (ix)
+	ld	h, (ix+1)
 	ld	e, (hl)
 	inc	hl
 	ld	d, (hl)
 	inc	hl
-	call	pushRS
+	ld	(ix), l
+	ld	(ix+1), h
 	push	de
 	jp	exit
 NUMBER:
@@ -186,6 +159,8 @@ abort:
 	; Reinitialize PS (RS is reinitialized in forthInterpret
 	ld	sp, (INITIAL_SP)
 	jp	forthRdLine
+ABORTREF:
+	.dw ABORT
 
 	.db "BYE"
 	.fill 5
@@ -267,71 +242,35 @@ DEFINE:
 	; All we need to do is to know how many bytes to copy. To do so, we
 	; skip compwords until EXIT is reached.
 	ex	de, hl		; DE is our dest
+	ld	(HERE), de	; update HERE
 	ld	l, (ix)
 	ld	h, (ix+1)
 .loop:
-	call	HLPointsNUMBER
-	jr	nz, .notNUMBER
-	; is number
-	ld	bc, 4
-	ldir
+	call	HLPointsEXIT
+	jr	z, .loopend
+	call	compSkip
 	jr	.loop
-.notNUMBER:
-	call	HLPointsLIT
-	jr	nz, .notLIT
-	; is lit
-	ldi
-	ldi
-	call	strcpyM
-	jr	.loop
-.notLIT:
-	; it's a word
-	call	HLPointsIMMED
-	jr	nz, .notIMMED
-	; Immediate word, we'll have to call it.
-	; Before we make our call, let's save our current HL/DE position
-	ld	(HERE), de
-	ld	e, (hl)
-	inc	hl
-	ld	d, (hl)
-	inc	hl			; point to next word
-	push	de \ pop iy		; prepare for executeCodeLink
-	ld	(ix), l
-	ld	(ix+1), h
-	; Push return address
-	ld	hl, .retList
-	call	pushRS
-	; Ready!
-	jp	executeCodeLink
-.notIMMED:
-	; a good old regular word. We have 2 bytes to copy. But before we do,
-	; let's check whether it's an EXIT. LDI doesn't affect Z, so we can
-	; make our jump later.
-	call	HLPointsEXITQUIT
-	ldi
-	ldi
-	jr	nz, .loop
-	; HL has our new RS' TOS
-	ld	(ix), l
-	ld	(ix+1), h
-	ld	(HERE), de	; update HERE
-	jp	exit
-
-; This label is pushed to RS when an IMMED word is called. When that word calls
-; exit, this is where it returns. When we return, RS will need to be popped so
-; that we stay on the proper RS level.
-.retList:
-	.dw	.retWord
-.retWord:
-	.dw	.retEntry
-.retEntry:
-	call	popRS		; unwind stack
-	; recall old HL / DE values
+.loopend:
+	; skip EXIT
+	inc	hl \ inc hl
+	; We have out end offset. Let's get our offset
+	ld	e, (ix)
+	ld	d, (ix+1)
+	or	a		; clear carry
+	sbc	hl, de
+	; HL is our copy count.
+	ld	b, h
+	ld	c, l
 	ld	l, (ix)
 	ld	h, (ix+1)
-	ld	de, (HERE)
-	; continue!
-	jr	.loop
+	ld	de, (HERE)	; recall dest
+	; copy!
+	ldir
+	ld	(ix), l
+	ld	(ix+1), h
+	ld	(HERE), de
+	jp	exit
+
 
 	.db "DOES>"
 	.fill 3
@@ -374,18 +313,12 @@ IMMEDIATE:
 	.dw IMMEDIATE
 LITERAL:
 	.dw nativeWord
-	ld	hl, (HERE)
+	ld	hl, (CMPDST)
 	ld	de, NUMBER
-	ld	(hl), e
-	inc	hl
-	ld	(hl), d
-	inc	hl
+	call	DEinHL
 	pop	de		; number from stack
-	ld	(hl), e
-	inc	hl
-	ld	(hl), d
-	inc	hl
-	ld	(HERE), hl
+	call	DEinHL
+	ld	(CMPDST), hl
 	jp	exit
 
 ; ( -- c )
@@ -400,27 +333,9 @@ KEY:
 	push	hl
 	jp	exit
 
-	.db "INTERPR"
-	.db 0
-	.dw KEY
-INTERPRET:
-	.dw nativeWord
-interpret:
-	ld	iy, COMPBUF
-.loop:
-	call	readword
-	jr	nz, .end
-	call	compile
-	jr	.loop
-.end:
-	ld	hl, QUIT
-	call	wrCompHL
-	ld	iy, COMPBUF
-	jp	compiledWord
-
 	.db "CREATE"
 	.fill 2
-	.dw INTERPRET
+	.dw KEY
 CREATE:
 	.dw nativeWord
 	call	entryhead
@@ -474,10 +389,21 @@ STORE:
 	ld	(iy+1), h
 	jp	exit
 
+; ( n a -- )
+	.db "C!"
+	.fill 6
+	.dw STORE
+CSTORE:
+	.dw nativeWord
+	pop	hl
+	pop	de
+	ld	(hl), e
+	jp	exit
+
 ; ( a -- n )
 	.db "@"
 	.fill 7
-	.dw STORE
+	.dw CSTORE
 FETCH:
 	.dw nativeWord
 	pop	hl
@@ -485,10 +411,22 @@ FETCH:
 	push	hl
 	jp	exit
 
+; ( a -- c )
+	.db "C@"
+	.fill 6
+	.dw FETCH
+CFETCH:
+	.dw nativeWord
+	pop	hl
+	ld	l, (hl)
+	ld	h, 0
+	push	hl
+	jp	exit
+
 ; ( -- a )
 	.db "LIT@"
 	.fill 4
-	.dw FETCH
+	.dw CFETCH
 LITFETCH:
 	.dw nativeWord
 	call	readLITTOS
@@ -506,10 +444,26 @@ SWAP:
 	push	hl
 	jp	exit
 
+; ( a b c d -- c d a b )
+	.db "2SWAP"
+	.fill 3
+	.dw SWAP
+SWAP2:
+	.dw nativeWord
+	pop	de		; D
+	pop	hl		; C
+	pop	bc		; B
+
+	ex	(sp), hl	; A in HL
+	push	de		; D
+	push	hl		; A
+	push	bc		; B
+	jp	exit
+
 ; ( a -- a a )
 	.db "DUP"
 	.fill 5
-	.dw SWAP
+	.dw SWAP2
 DUP:
 	.dw nativeWord
 	pop	hl
@@ -517,10 +471,24 @@ DUP:
 	push	hl
 	jp	exit
 
+; ( a b -- a b a b )
+	.db "2DUP"
+	.fill 4
+	.dw DUP
+DUP2:
+	.dw nativeWord
+	pop	hl	; B
+	pop	de	; A
+	push	de
+	push	hl
+	push	de
+	push	hl
+	jp	exit
+
 ; ( a b -- a b a )
 	.db "OVER"
 	.fill 4
-	.dw DUP
+	.dw DUP2
 OVER:
 	.dw nativeWord
 	pop	hl	; B
@@ -530,10 +498,28 @@ OVER:
 	push	de
 	jp	exit
 
+; ( a b c d -- a b c d a b )
+	.db "2OVER"
+	.fill 3
+	.dw OVER
+OVER2:
+	.dw nativeWord
+	pop	hl	; D
+	pop	de	; C
+	pop	bc	; B
+	pop	iy	; A
+	push	iy	; A
+	push	bc	; B
+	push	de	; C
+	push	hl	; D
+	push	iy	; A
+	push	bc	; B
+	jp	exit
+
 ; ( a b -- c ) A + B
 	.db "+"
 	.fill 7
-	.dw OVER
+	.dw OVER2
 PLUS:
 	.dw nativeWord
 	pop	hl
@@ -607,22 +593,63 @@ CMP:
 	jp	exit
 
 	.db "IF"
-	.fill 6
+	.fill 5
+	.db 1		; IMMEDIATE
 	.dw CMP
 IF:
-	.dw ifWord
+	.dw nativeWord
+	; Spit a conditional branching atom, followed by an empty 1b cell. Then,
+	; push the address of that cell on the PS. ELSE or THEN will pick
+	; them up and set the offset.
+	ld	hl, (CMPDST)
+	ld	de, CBRANCH
+	call	DEinHL
+	push	hl		; address of cell to fill
+	inc	hl		; empty 1b cell
+	ld	(CMPDST), hl
+	jp	exit
 
 	.db "ELSE"
-	.fill 4
+	.fill 3
+	.db 1		; IMMEDIATE
 	.dw IF
 ELSE:
-	.dw elseWord
+	.dw nativeWord
+	; First, let's set IF's branching cell.
+	pop	de		; cell's address
+	ld	hl, (CMPDST)
+	; also skip ELSE word.
+	inc	hl \ inc hl \ inc hl
+	or	a		; clear carry
+	sbc	hl, de		; HL now has relative offset
+	ld	a, l
+	ld	(de), a
+	; Set IF's branching cell to current atom address and spit our own
+	; uncondition branching cell, which will then be picked up by THEN.
+	; First, let's spit our 4 bytes
+	ld	hl, (CMPDST)
+	ld	de, BRANCH
+	call	DEinHL
+	push	hl		; address of cell to fill
+	inc	hl		; empty 1b cell
+	ld	(CMPDST), hl
+	jp	exit
 
 	.db "THEN"
-	.fill 4
+	.fill 3
+	.db 1		; IMMEDIATE
 	.dw ELSE
 THEN:
-	.dw thenWord
+	.dw nativeWord
+	; See comments in IF and ELSE
+	pop	de		; cell's address
+	ld	hl, (CMPDST)
+	; There is nothing to skip because THEN leaves nothing.
+	or	a		; clear carry
+	sbc	hl, de		; HL now has relative offset
+	ld	a, l
+	ld	(de), a
+	jp	exit
 
 	.db "RECURSE"
 	.db 0
@@ -636,124 +663,5 @@ RECURSE:
 	push	hl \ pop iy
 	jp	compiledWord
 
-; End of native words
-
-; ( a -- )
-; @ .
-	.db "?"
-	.fill 7
-	.dw RECURSE
-FETCHDOT:
-	.dw compiledWord
-	.dw FETCH
-	.dw DOT
-	.dw EXIT
-
-; ( n a -- )
-; SWAP OVER @ + SWAP !
-	.db "+!"
-	.fill 6
-	.dw FETCHDOT
-STOREINC:
-	.dw compiledWord
-	.dw SWAP
-	.dw OVER
-	.dw FETCH
-	.dw PLUS
-	.dw SWAP
-	.dw STORE
-	.dw EXIT
-
-; ( n -- )
-; HERE +!
-	.db "ALLOT"
-	.fill 3
-	.dw STOREINC
-ALLOT:
-	.dw compiledWord
-	.dw HERE_
-	.dw STOREINC
-	.dw EXIT
-
-; CREATE 2 ALLOT
-	.db "VARIABL"
-	.db 0
-	.dw ALLOT
-VARIABLE:
-	.dw compiledWord
-	.dw CREATE
-	.dw NUMBER
-	.dw 2
-	.dw ALLOT
-	.dw EXIT
-
-; ( n -- )
-; CREATE HERE @ ! DOES> @
-	.db "CONSTAN"
-	.db 0
-	.dw VARIABLE
-CONSTANT:
-	.dw compiledWord
-	.dw CREATE
-	.dw HERE_
-	.dw FETCH
-	.dw STORE
-	.dw DOES
-	.dw FETCH
-	.dw EXIT
-
-; ( f -- f )
-; IF 0 ELSE 1 THEN
-	.db "NOT"
-	.fill 5
-	.dw CONSTANT
-NOT:
-	.dw compiledWord
-	.dw IF
-	.dw NUMBER
-	.dw 0
-	.dw ELSE
-	.dw NUMBER
-	.dw 1
-	.dw THEN
-	.dw EXIT
-
-; ( n1 n2 -- f )
-; CMP NOT
-	.db "="
-	.fill 7
-	.dw NOT
-EQ:
-	.dw compiledWord
-	.dw CMP
-	.dw NOT
-	.dw EXIT
-
-; ( n1 n2 -- f )
-; CMP -1 =
-	.db "<"
-	.fill 7
-	.dw EQ
-LT:
-	.dw compiledWord
-	.dw CMP
-	.dw NUMBER
-	.dw -1
-	.dw EQ
-	.dw EXIT
-
-; ( n1 n2 -- f )
-; CMP 1 =
-	.db ">"
-	.fill 7
-	.dw LT
-GT:
 LATEST:
-	.dw compiledWord
-	.dw CMP
-	.dw NUMBER
-	.dw 1
-	.dw EQ
-	.dw EXIT
-
-;
+	.dw RECURSE

apps/forth/dictionary.txt

@@ -51,12 +51,17 @@ THEN        --              Does nothing. Serves as a branching merker for IF
 DUP         a -- a a
 OVER        a b -- a b a
 SWAP        a b -- b a
+2DUP        a b -- a b a b
+2OVER       a b c d -- a b c d a b
+2SWAP       a b c d -- c d a b
 
 *** Memory ***
 @           a -- n          Set n to value at address a
 !           n a --          Store n in address a
 ?           a --            Print value of addr a
 +!          n a --          Increase value of addr a by n
+C@          a -- c          Set c to byte at address a
+C!          c a --          Store byte c in address a
 CURRENT     -- n            Set n to wordref of last added entry.
 HERE        -- a            Push HERE's address
 

apps/forth/main.asm

@@ -12,11 +12,39 @@
 .equ	INITIAL_SP	FORTH_RAMSTART
 .equ	CURRENT		@+2
 .equ	HERE		@+2
+; Pointer to where we currently are in the interpretation of the current line.
 .equ	INPUTPOS	@+2
+; Pointer to where compiling words should output. During interpret, it's a
+; moving target in (COMPBUF). During DEFINE, it's (HERE).
+.equ	CMPDST		@+2
 ; Buffer where we compile the current input line. Same size as STDIO_BUFSIZE.
 .equ	COMPBUF		@+2
 .equ	FORTH_RAMEND	@+0x40
 
+; (HERE) usually starts at RAMEND, but in certain situations, such as in stage0,
+; (HERE) will begin at a strategic place.
+.equ	HERE_INITIAL	FORTH_RAMEND
+
+; EXECUTION MODEL
+; After having read a line through stdioReadLine, we want to interpret it. As
+; a general rule, we go like this:
+;
+; 1. read single word from line
+; 2. compile word to atom
+; 3. execute atom
+; 4. goto 1
+;
+; During step 3, it's possible that atom read from input, so INPUTPOS might
+; have moved between 3 and 4.
+;
+; Because the Parameter Stack uses PS, we can't just go around calling routines:
+; This messes with the PS. This is why we almost always jump (unless our call
+; doesn't involve Forth words in any way).
+;
+; This presents a challenge for our interpret loop because step 4, "goto 1"
+; isn't obvious. To be able to do that, we must push a "return routine" to the
+; Return Stack before step 3.
+
 ; *** Code ***
 forthMain:
 	; STACK OVERFLOW PROTECTION:
@@ -27,19 +55,86 @@ forthMain:
 	; we check for stack underflow.
 	push	af \ push af \ push af
 	ld	(INITIAL_SP), sp
+	; LATEST is a *indirect* label to the latest entry of the dict. See
+	; default at the bottom of dict.asm. This indirection allows us to
+	; override latest to a value set in a binary dict compiled separately,
+	; for example by the stage0 bin.
 	ld	hl, LATEST
+	call	intoHL
 	ld	(CURRENT), hl
-	ld	hl, FORTH_RAMEND
+	ld	hl, HERE_INITIAL
 	ld	(HERE), hl
 forthRdLine:
 	ld	hl, msgOk
 	call	printstr
 	call	printcrlf
 	call	stdioReadLine
-	ld	(INPUTPOS), hl
-forthInterpret:
 	ld	ix, RS_ADDR-2		; -2 because we inc-before-push
-	ld	iy, INTERPRET
+	ld	(INPUTPOS), hl
+	ld	hl, COMPBUF
+	ld	(CMPDST), hl
+forthInterpret:
+	call	readword
+	jr	nz, .execute
+	call	find
+	jr	nz, .maybeNum
+	ex	de, hl
+	call	HLisIMMED
+	jr	z, .immed
+	ex	de, hl
+	call	.writeDE
+	jr	forthInterpret
+.maybeNum:
+	push	hl		; --> lvl 1. save string addr
+	call	parseLiteral
+	pop	hl		; <-- lvl 1
+	jr	nz, .undef
+	; a valid number in DE!
+	ex	de, hl
+	ld	de, NUMBER
+	call	.writeDE
+	ex	de, hl		; number in DE
+	call	.writeDE
+	jr	forthInterpret
+.undef:
+	; When encountering an undefined word during compilation, we spit a
+	; reference to litWord, followed by the null-terminated word.
+	; This way, if a preceding word expect a string literal, it will read it
+	; by calling readLIT, and if it doesn't, the routine will be
+	; called, triggering an abort.
+	ld	de, LIT
+	call	.writeDE
+	ld	de, (CMPDST)
+	call	strcpyM
+	ld	(CMPDST), de
+	jr	forthInterpret
+.immed:
+	push	hl		; --> lvl 1
+	ld	hl, .retRef
+	call	pushRS
+	pop	iy		; <-- lvl 1
 	jp	executeCodeLink
+.execute:
+	ld	de, QUIT
+	call	.writeDE
+	ld	iy, COMPBUF
+	jp	compiledWord
+.writeDE:
+	push	hl
+	ld	hl, (CMPDST)
+	ld	(hl), e
+	inc	hl
+	ld	(hl), d
+	inc	hl
+	ld	(CMPDST), hl
+	pop	hl
+	ret
+
+.retRef:
+	.dw $+2
+	.dw $+2
+	call	popRS
+	jr	forthInterpret
+
 msgOk:
 	.db	" ok", 0

apps/forth/stack.asm

@@ -25,6 +25,17 @@ popRS:
 	dec ix
 	ret
 
+; Skip the next two bytes in RS' TOS
+skipRS:
+	push	hl
+	ld	l, (ix)
+	ld	h, (ix+1)
+	inc	hl \ inc hl
+	ld	(ix), l
+	ld	(ix+1), h
+	pop	hl
+	ret
+
 ; Verifies that SP is within bounds. If it's not, call ABORT
 chkPS:
 	ld	hl, (INITIAL_SP)

apps/forth/util.asm

@@ -69,14 +69,28 @@ HLPointsLIT:
 	pop	de
 	ret
 
-HLPointsEXITQUIT:
+HLPointsBRANCH:
+	push	de
+	ld	de, BRANCH
+	call	HLPointsDE
+	jr	z, .end
+	ld	de, CBRANCH
+	call	HLPointsDE
+.end:
+	pop	de
+	ret
+
+HLPointsEXIT:
 	push	de
 	ld	de, EXIT
 	call	HLPointsDE
-	jr	z, .end
+	pop	de
+	ret
+
+HLPointsQUIT:
+	push	de
 	ld	de, QUIT
 	call	HLPointsDE
-.end:
 	pop	de
 	ret
 
@@ -86,6 +100,8 @@ HLPointsEXITQUIT:
 compSkip:
 	call	HLPointsNUMBER
 	jr	z, .isNum
+	call	HLPointsBRANCH
+	jr	z, .isBranch
 	call	HLPointsLIT
 	jr	nz, .isWord
 	; We have a literal
@@ -95,7 +111,11 @@ compSkip:
 	ret
 .isNum:
 	; skip by 4
-	inc	hl \ inc hl
+	inc	hl
+	; continue to isBranch
+.isBranch:
+	; skip by 3
+	inc	hl
 	; continue to isWord
 .isWord:
 	; skip by 2
@@ -160,7 +180,11 @@ readLIT:
 	; it's a word.
 	call	HLPointsNUMBER
 	jr	z, .notWord
-	call	HLPointsEXITQUIT
+	call	HLPointsBRANCH
+	jr	z, .notWord
+	call	HLPointsEXIT
+	jr	z, .notWord
+	call	HLPointsQUIT
 	jr	z, .notWord
 	; Not a number, then it's a word. Copy word to pad and point to it.
 	push	hl		; --> lvl 1. we need it to set DE later
@@ -257,42 +281,6 @@ wrCompHL:
 	inc	iy
 	ret
 
-; Compile word string at (HL) and write down its compiled version in IY,
-; advancing IY to the byte next to the last written byte.
-compile:
-	call	find
-	jr	nz, .maybeNum
-	ex	de, hl
-	jr	wrCompHL
-.maybeNum:
-	push	hl		; --> lvl 1. save string addr
-	call	parseLiteral
-	jr	nz, .undef
-	pop	hl		; <-- lvl 1
-	; a valid number!
-	ld	hl, NUMBER
-	call	wrCompHL
-	ex	de, hl		; number in HL
-	jr	wrCompHL
-.undef:
-	; When encountering an undefined word during compilation, we spit a
-	; reference to litWord, followed by the null-terminated word.
-	; This way, if a preceding word expect a string literal, it will read it
-	; by calling readLIT, and if it doesn't, the routine will be
-	; called, triggering an abort.
-	ld	hl, LIT
-	call	wrCompHL
-	pop	hl		; <-- lvl 1. recall string addr
-.writeLit:
-	ld	a, (hl)
-	ld	(iy), a
-	inc	hl
-	inc	iy
-	or	a
-	jr	nz, .writeLit
-	ret
-
-
 ; Spit name + prev in (HERE) and adjust (HERE) and (CURRENT)
 ; HL points to new (HERE)
 entryhead:
@@ -315,10 +303,8 @@ entryhead:
 	xor	a		; set Z
 	ret
 
-; Sets Z if wordref at (HL) is of the IMMEDIATE type
-HLPointsIMMED:
-	push	hl
-	call	intoHL
+; Sets Z if wordref at HL is of the IMMEDIATE type
+HLisIMMED:
 	dec	hl
 	dec	hl
 	dec	hl
@@ -329,6 +315,13 @@ HLPointsIMMED:
 	inc	hl
 	inc	hl
 	inc	hl
+	ret
+
+; Sets Z if wordref at (HL) is of the IMMEDIATE type
+HLPointsIMMED:
+	push	hl
+	call	intoHL
+	call	HLisIMMED
 	pop	hl
 	ret
 
@@ -343,3 +336,10 @@ flagsToBC:
 	dec	bc
 	ret
 
+; Write DE in (HL), advancing HL by 2.
+DEinHL:
+	ld	(hl), e
+	inc	hl
+	ld	(hl), d
+	inc	hl
+	ret

emul/.gitignore

@@ -1,4 +1,5 @@
 /shell/shell
+/forth/stage1
 /forth/forth
 /zasm/zasm
 /zasm/avra

emul/Makefile

@@ -24,13 +24,25 @@ shell/shell-bin.h: shell/shell.bin
 shell/shell: shell/shell.c $(SHELLOBJS) shell/shell-bin.h 
 	$(CC) shell/shell.c $(SHELLOBJS) -o $@
 
-forth/forth.bin: forth/glue.asm $(ZASMBIN)
-	$(ZASMBIN) $(KERNEL) $(APPS) < forth/glue.asm | tee $@ > /dev/null
+forth/forth0.bin: forth/glue0.asm $(ZASMBIN)
+	$(ZASMBIN) $(KERNEL) $(APPS) < forth/glue0.asm | tee $@ > /dev/null
 
-forth/forth-bin.h: forth/forth.bin
-	./bin2c.sh KERNEL < forth/forth.bin | tee $@ > /dev/null
+forth/forth0-bin.h: forth/forth0.bin
+	./bin2c.sh KERNEL < forth/forth0.bin | tee $@ > /dev/null
 
-forth/forth: forth/forth.c $(OBJS) forth/forth-bin.h 
+forth/stage1: forth/stage1.c $(OBJS) forth/forth0-bin.h 
+	$(CC) forth/stage1.c $(OBJS) -o $@
+
+forth/core.bin: $(APPS)/forth/core.fth forth/stage1
+	./forth/stage1 $(APPS)/forth/core.fth | tee $@ > /dev/null
+
+forth/forth1.bin: forth/glue1.asm forth/core.bin $(ZASMBIN)
+	$(ZASMBIN) $(KERNEL) $(APPS) forth/core.bin < forth/glue1.asm | tee $@ > /dev/null
+
+forth/forth1-bin.h: forth/forth1.bin
+	./bin2c.sh KERNEL < forth/forth1.bin | tee $@ > /dev/null
+
+forth/forth: forth/forth.c $(OBJS) forth/forth1-bin.h 
 	$(CC) forth/forth.c $(OBJS) -o $@
 
 zasm/kernel-bin.h: zasm/kernel.bin

emul/forth/forth.c

@@ -3,17 +3,18 @@
 #include <unistd.h>
 #include <termios.h>
 #include "../emul.h"
-#include "forth-bin.h"
+#include "forth1-bin.h"
 
 // in sync with glue.asm
-#define RAMSTART 0x2000
+#define RAMSTART 0x900
 #define STDIO_PORT 0x00
 
 static int running;
+static FILE *fp;
 
 static uint8_t iord_stdio()
 {
-    int c = getchar();
+    int c = getc(fp);
     if (c == EOF) {
         running = 0;
     }
@@ -31,8 +32,17 @@ static void iowr_stdio(uint8_t val)
 
 int main(int argc, char *argv[])
 {
-    bool tty = isatty(fileno(stdin));
+    bool tty = false;
     struct termios termInfo;
+    if (argc == 2) {
+        fp = fopen(argv[1], "r");
+        if (fp == NULL) {
+            fprintf(stderr, "Can't open %s\n", argv[1]);
+            return 1;
+        }
+    } else if (argc == 1) {
+        fp = stdin;
+        tty = isatty(fileno(stdin));
         if (tty) {
             // Turn echo off: the shell takes care of its own echoing.
             if (tcgetattr(0, &termInfo) == -1) {
@@ -43,7 +53,10 @@ int main(int argc, char *argv[])
             termInfo.c_lflag &= ~ICANON;
             tcsetattr(0, TCSAFLUSH, &termInfo);
         }
-
+    } else {
+        fprintf(stderr, "Usage: ./forth [filename]\n");
+        return 1;
+    }
     Machine *m = emul_init();
     m->ramstart = RAMSTART;
     m->iord[STDIO_PORT] = iord_stdio;
@@ -58,11 +71,12 @@ int main(int argc, char *argv[])
     while (running && emul_step());
 
     if (tty) {
-        printf("Done!\n");
+        printf("\nDone!\n");
         termInfo.c_lflag |= ECHO;
         termInfo.c_lflag |= ICANON;
         tcsetattr(0, TCSAFLUSH, &termInfo);
         emul_printdebug();
     }
+    fclose(fp);
     return 0;
 }

emul/forth/glue0.asm

@@ -0,0 +1,56 @@
+; RAM disposition
+;
+; Because this glue code also serves stage0 which needs HERE to start right
+; after the code, we have a peculiar RAM setup here: it lives at the very end
+; of the address space, just under RS_ADDR at 0xf000
+; Warning: The offsets of native dict entries must be exactly the same between
+;          glue0.asm and glue1.asm
+.equ	RAMSTART	0xe800
+.equ	HERE		0xe700		; override, in sync with stage1.c
+.equ	CURRENT		0xe702		; override, in sync with stage1.c
+.equ	HERE_INITIAL	CODE_END	; override
+
+.inc "ascii.h"
+.equ	STDIO_PORT	0x00
+
+	jp	init
+
+.inc "core.asm"
+.inc "str.asm"
+
+.equ	STDIO_RAMSTART	RAMSTART
+.equ	STDIO_GETC	emulGetC
+.equ	STDIO_PUTC	emulPutC
+.inc "stdio.asm"
+
+.inc "lib/util.asm"
+.inc "lib/parse.asm"
+.inc "lib/ari.asm"
+.inc "lib/fmt.asm"
+.equ FORTH_RAMSTART STDIO_RAMEND
+.inc "forth/main.asm"
+.inc "forth/util.asm"
+.inc "forth/stack.asm"
+.inc "forth/dict.asm"
+
+
+init:
+	di
+	; setup stack
+	ld	sp, 0xffff
+	call	forthMain
+	halt
+
+emulGetC:
+	; Blocks until a char is returned
+	in	a, (STDIO_PORT)
+	cp	a		; ensure Z
+	ret
+
+emulPutC:
+	out	(STDIO_PORT), a
+	ret
+
+.dw	0		; placeholder used in glue1.
+CODE_END:
+.out $		; should be the same as in glue1

emul/forth/glue1.asm

@@ -1,5 +1,7 @@
+; Warning: The offsets of native dict entries must be exactly the same between
+;          glue0.asm and glue1.asm
+.equ	LATEST		CODE_END	; override
 .inc "ascii.h"
-.equ	RAMSTART	0x2000
 .equ	STDIO_PORT	0x00
 
 	jp	init
@@ -22,6 +24,7 @@
 .inc "forth/stack.asm"
 .inc "forth/dict.asm"
 
+
 init:
 	di
 	; setup stack
@@ -38,3 +41,10 @@ emulGetC:
 emulPutC:
 	out	(STDIO_PORT), a
 	ret
+
+.out $		; should be the same as in glue0, minus 2
+; stage0 spits, at the beginning of the binary, the address of the latest word
+; Therefore, we can set the LATEST label to here and we should be good.
+CODE_END:
+.bin "core.bin"
+RAMSTART:

emul/forth/stage1.c

@@ -0,0 +1,87 @@
+#include <stdint.h>
+#include <stdio.h>
+#include <unistd.h>
+#include "../emul.h"
+#include "forth0-bin.h"
+
+/* Stage 1
+
+The role of the stage 1 executable is to start from a bare Forth executable
+(stage 0) that will compile core non-native definitions into binary form and
+append this to existing bootstrap binary to form our final Forth bin.
+
+We could, if we wanted, run only with the bootstrap binary and compile core
+defs at runtime, but that would mean that those defs live in RAM. In may system,
+RAM is much more constrained than ROM, so it's worth it to give ourselves the
+trouble of compiling defs to binary.
+
+This stage 0 executable has to be layed out in a particular manner: HERE must
+directly follow executable's last byte so that we don't waste spce and also
+that wordref offsets correspond.
+*/
+
+// in sync with glue.asm
+#define RAMSTART 0x900
+#define STDIO_PORT 0x00
+// In sync with glue code. This way, we can know where HERE was when we stopped
+// running
+#define HERE 0xe700
+// We also need to know what CURRENT is so we can write our first two bytes
+#define CURRENT 0xe702
+
+static int running;
+static FILE *fp;
+
+static uint8_t iord_stdio()
+{
+    int c = getc(fp);
+    if (c == EOF) {
+        running = 0;
+    }
+    return (uint8_t)c;
+}
+
+static void iowr_stdio(uint8_t val)
+{
+    // we don't output stdout in stage0
+}
+
+int main(int argc, char *argv[])
+{
+    bool tty = false;
+    if (argc == 2) {
+        fp = fopen(argv[1], "r");
+        if (fp == NULL) {
+            fprintf(stderr, "Can't open %s\n", argv[1]);
+            return 1;
+        }
+    } else {
+        fprintf(stderr, "Usage: ./stage0 filename\n");
+        return 1;
+    }
+    Machine *m = emul_init();
+    m->ramstart = RAMSTART;
+    m->iord[STDIO_PORT] = iord_stdio;
+    m->iowr[STDIO_PORT] = iowr_stdio;
+    // initialize memory
+    for (int i=0; i<sizeof(KERNEL); i++) {
+        m->mem[i] = KERNEL[i];
+    }
+    // Run!
+    running = 1;
+
+    while (running && emul_step());
+
+    fclose(fp);
+
+    // We're done, now let's spit dict data
+    // let's start with LATEST spitting.
+    putchar(m->mem[CURRENT]);
+    putchar(m->mem[CURRENT+1]);
+    uint16_t here = m->mem[HERE] + (m->mem[HERE+1] << 8);
+    for (int i=sizeof(KERNEL); i<here; i++) {
+        putchar(m->mem[i]);
+    }
+    return 0;
+}
+