apps/forth/core.fth

@@ -1,9 +0,0 @@
-: ? @ . ;
-: +! 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,39 +51,68 @@ doesWord:
 	push	hl \ pop iy
 	jr	compiledWord
 
-; This word is followed by 1b *relative* offset (to the cell's addr) to where to
+; The IF word checks the stack for zero. If it's non-zero, it does nothing and
-; branch to. For example, The branching cell of "IF THEN" would contain 3. Add
+; allow compiledWord to continue.
-; this value to RS.
+; If it's zero, it tracksback RS, advance it until it finds a ELSE, a THEN, or
-branchWord:
+; an EXIT (not supposed to happen unless the IF is misconstructed). Whether
-	push	de
+; it's a ELSE or THEN, the same thing happens: we resume execution after the
-	ld	l, (ix)
+; ELSE/THEN. If it's a EXIT, we simply execute it.
-	ld	h, (ix+1)
+ifWord:
-	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
-	jr	z, branchWord
+	jp	nz, exit	; non-zero, continue
-	; skip next byte in RS
+	; Zero, seek ELSE, THEN or EXIT. Continue to elseWord
-	ld	l, (ix)
-	ld	h, (ix+1)
-	inc	hl
-	ld	(ix), l
-	ld	(ix+1), h
-	jp	exit
 
-CBRANCH:
+; If a ELSE word is executed, it means that the preceding IF had a non-zero
-	.dw	cbranchWord
+; 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:
+	jp	exit
 
 ; 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
@@ -92,14 +121,12 @@ CBRANCH:
 ; it to the Parameter stack and then push an increase Interpreter Pointer back
 ; to RS.
 numberWord:
-	ld	l, (ix)
+	call	popRS
-	ld	h, (ix+1)
 	ld	e, (hl)
 	inc	hl
 	ld	d, (hl)
 	inc	hl
-	ld	(ix), l
+	call	pushRS
-	ld	(ix+1), h
 	push	de
 	jp	exit
 NUMBER:
@@ -159,8 +186,6 @@ abort:
 	; Reinitialize PS (RS is reinitialized in forthInterpret
 	ld	sp, (INITIAL_SP)
 	jp	forthRdLine
-ABORTREF:
-	.dw ABORT
 
 	.db "BYE"
 	.fill 5
@@ -242,35 +267,71 @@ 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	HLPointsEXIT
+	call	HLPointsNUMBER
-	jr	z, .loopend
+	jr	nz, .notNUMBER
-	call	compSkip
+	; is number
-	jr	.loop
+	ld	bc, 4
-.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)	; recall dest
-	; copy!
 	ldir
+	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
-	ld	(HERE), de
+	; 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
+	ld	l, (ix)
+	ld	h, (ix+1)
+	ld	de, (HERE)
+	; continue!
+	jr	.loop
 
 	.db "DOES>"
 	.fill 3
@@ -313,12 +374,18 @@ IMMEDIATE:
 	.dw IMMEDIATE
 LITERAL:
 	.dw nativeWord
-	ld	hl, (CMPDST)
+	ld	hl, (HERE)
 	ld	de, NUMBER
-	call	DEinHL
+	ld	(hl), e
+	inc	hl
+	ld	(hl), d
+	inc	hl
 	pop	de		; number from stack
-	call	DEinHL
+	ld	(hl), e
-	ld	(CMPDST), hl
+	inc	hl
+	ld	(hl), d
+	inc	hl
+	ld	(HERE), hl
 	jp	exit
 
 ; ( -- c )
@@ -333,9 +400,27 @@ 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 KEY
+	.dw INTERPRET
 CREATE:
 	.dw nativeWord
 	call	entryhead
@@ -389,21 +474,10 @@ 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 CSTORE
+	.dw STORE
 FETCH:
 	.dw nativeWord
 	pop	hl
@@ -411,22 +485,10 @@ 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 CFETCH
+	.dw FETCH
 LITFETCH:
 	.dw nativeWord
 	call	readLITTOS
@@ -444,26 +506,10 @@ 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 SWAP2
+	.dw SWAP
 DUP:
 	.dw nativeWord
 	pop	hl
@@ -471,24 +517,10 @@ 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 DUP2
+	.dw DUP
 OVER:
 	.dw nativeWord
 	pop	hl	; B
@@ -498,28 +530,10 @@ 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 OVER2
+	.dw OVER
 PLUS:
 	.dw nativeWord
 	pop	hl
@@ -593,63 +607,22 @@ CMP:
 	jp	exit
 
 	.db "IF"
-	.fill 5
+	.fill 6
-	.db 1		; IMMEDIATE
 	.dw CMP
 IF:
-	.dw nativeWord
+	.dw ifWord
-	; 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 3
+	.fill 4
-	.db 1		; IMMEDIATE
 	.dw IF
 ELSE:
-	.dw nativeWord
+	.dw elseWord
-	; 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 3
+	.fill 4
-	.db 1		; IMMEDIATE
 	.dw ELSE
 THEN:
-	.dw nativeWord
+	.dw thenWord
-	; 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
@@ -663,5 +636,124 @@ RECURSE:
 	push	hl \ pop iy
 	jp	compiledWord
 
-LATEST:
+; 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
+
+;

apps/forth/dictionary.txt

@@ -51,17 +51,12 @@ 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,39 +12,11 @@
 .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:
@@ -55,86 +27,19 @@ 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, HERE_INITIAL
+	ld	hl, FORTH_RAMEND
 	ld	(HERE), hl
 forthRdLine:
 	ld	hl, msgOk
 	call	printstr
 	call	printcrlf
 	call	stdioReadLine
-	ld	ix, RS_ADDR-2		; -2 because we inc-before-push
 	ld	(INPUTPOS), hl
-	ld	hl, COMPBUF
-	ld	(CMPDST), hl
 forthInterpret:
-	call	readword
+	ld	ix, RS_ADDR-2		; -2 because we inc-before-push
-	jr	nz, .execute
+	ld	iy, INTERPRET
-	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,17 +25,6 @@ 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,28 +69,14 @@ HLPointsLIT:
 	pop	de
 	ret
 
-HLPointsBRANCH:
+HLPointsEXITQUIT:
-	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
-	pop	de
+	jr	z, .end
-	ret
-
-HLPointsQUIT:
-	push	de
 	ld	de, QUIT
 	call	HLPointsDE
+.end:
 	pop	de
 	ret
 
@@ -100,8 +86,6 @@ HLPointsQUIT:
 compSkip:
 	call	HLPointsNUMBER
 	jr	z, .isNum
-	call	HLPointsBRANCH
-	jr	z, .isBranch
 	call	HLPointsLIT
 	jr	nz, .isWord
 	; We have a literal
@@ -111,11 +95,7 @@ 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
@@ -180,11 +160,7 @@ readLIT:
 	; it's a word.
 	call	HLPointsNUMBER
 	jr	z, .notWord
-	call	HLPointsBRANCH
+	call	HLPointsEXITQUIT
-	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
@@ -281,6 +257,42 @@ 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:
@@ -303,8 +315,10 @@ entryhead:
 	xor	a		; set Z
 	ret
 
-; Sets Z if wordref at HL is of the IMMEDIATE type
+; Sets Z if wordref at (HL) is of the IMMEDIATE type
-HLisIMMED:
+HLPointsIMMED:
+	push	hl
+	call	intoHL
 	dec	hl
 	dec	hl
 	dec	hl
@@ -315,13 +329,6 @@ HLisIMMED:
 	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
 
@@ -336,10 +343,3 @@ 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,5 +1,4 @@
 /shell/shell
-/forth/stage1
 /forth/forth
 /zasm/zasm
 /zasm/avra

emul/Makefile

@@ -24,25 +24,13 @@ shell/shell-bin.h: shell/shell.bin
 shell/shell: shell/shell.c $(SHELLOBJS) shell/shell-bin.h 
 	$(CC) shell/shell.c $(SHELLOBJS) -o $@
 
-forth/forth0.bin: forth/glue0.asm $(ZASMBIN)
+forth/forth.bin: forth/glue.asm $(ZASMBIN)
-	$(ZASMBIN) $(KERNEL) $(APPS) < forth/glue0.asm | tee $@ > /dev/null
+	$(ZASMBIN) $(KERNEL) $(APPS) < forth/glue.asm | tee $@ > /dev/null
 
-forth/forth0-bin.h: forth/forth0.bin
+forth/forth-bin.h: forth/forth.bin
-	./bin2c.sh KERNEL < forth/forth0.bin | tee $@ > /dev/null
+	./bin2c.sh KERNEL < forth/forth.bin | tee $@ > /dev/null
 
-forth/stage1: forth/stage1.c $(OBJS) forth/forth0-bin.h 
+forth/forth: forth/forth.c $(OBJS) forth/forth-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,18 +3,17 @@
 #include <unistd.h>
 #include <termios.h>
 #include "../emul.h"
-#include "forth1-bin.h"
+#include "forth-bin.h"
 
 // in sync with glue.asm
-#define RAMSTART 0x900
+#define RAMSTART 0x2000
 #define STDIO_PORT 0x00
 
 static int running;
-static FILE *fp;
 
 static uint8_t iord_stdio()
 {
-    int c = getc(fp);
+    int c = getchar();
     if (c == EOF) {
         running = 0;
     }
@@ -32,31 +31,19 @@ static void iowr_stdio(uint8_t val)
 
 int main(int argc, char *argv[])
 {
-    bool tty = false;
+    bool tty = isatty(fileno(stdin));
     struct termios termInfo;
-    if (argc == 2) {
+    if (tty) {
-        fp = fopen(argv[1], "r");
+        // Turn echo off: the shell takes care of its own echoing.
-        if (fp == NULL) {
+        if (tcgetattr(0, &termInfo) == -1) {
-            fprintf(stderr, "Can't open %s\n", argv[1]);
+            printf("Can't setup terminal.\n");
             return 1;
         }
-    } else if (argc == 1) {
+        termInfo.c_lflag &= ~ECHO;
-        fp = stdin;
+        termInfo.c_lflag &= ~ICANON;
-        tty = isatty(fileno(stdin));
+        tcsetattr(0, TCSAFLUSH, &termInfo);
-        if (tty) {
-            // Turn echo off: the shell takes care of its own echoing.
-            if (tcgetattr(0, &termInfo) == -1) {
-                printf("Can't setup terminal.\n");
-                return 1;
-            }
-            termInfo.c_lflag &= ~ECHO;
-            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;
@@ -71,12 +58,11 @@ int main(int argc, char *argv[])
     while (running && emul_step());
 
     if (tty) {
-        printf("\nDone!\n");
+        printf("Done!\n");
         termInfo.c_lflag |= ECHO;
         termInfo.c_lflag |= ICANON;
         tcsetattr(0, TCSAFLUSH, &termInfo);
         emul_printdebug();
     }
-    fclose(fp);
     return 0;
 }

emul/forth/glue.asm

@@ -1,7 +1,5 @@
-; 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
@@ -24,7 +22,6 @@
 .inc "forth/stack.asm"
 .inc "forth/dict.asm"
 
-
 init:
 	di
 	; setup stack
@@ -41,10 +38,3 @@ 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/glue0.asm

@@ -1,56 +0,0 @@
-; 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/stage1.c

@@ -1,87 +0,0 @@
-#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;
-}
-