forth: make readCompWord read from RS' BOS instead of TOS

Previous approach was broken with regards to defined word using CREATE. Also, reduce name length by one to make space for a new flags field for "immediate" (which isn't used yet).
2024-11-27 14:28:06 +11:00 · 2020-03-09 19:50:51 -04:00 · 2020-03-09 19:50:51 -04:00 · 03bd9ee39b
commit 03bd9ee39b
parent 0e8af3cea4
3 changed files with 86 additions and 67 deletions
--- a/apps/forth/dict.asm
+++ b/apps/forth/dict.asm
@ -1,5 +1,6 @@
 ; A dictionary entry has this structure:
-; - 8b name (zero-padded)
+; - 7b name (zero-padded)
+; - 1b flags (bit 0: IMMEDIATE)
 ; - 2b prev pointer
 ; - 2b code pointer
 ; - Parameter field (PF)
@ -168,14 +169,16 @@ exit:
 	jp	compiledWord

 ; ( R:I -- )
-	.db "QUIT", 0, 0, 0, 0
+	.db "QUIT"
+	.fill 4
 	.dw EXIT
 QUIT:
 	.dw nativeWord
 quit:
 	jp	forthRdLine

-	.db "ABORT", 0, 0, 0
+	.db "ABORT"
+	.fill 3
 	.dw QUIT
 ABORT:
 	.dw nativeWord
@ -198,7 +201,8 @@ BYE:
 	ret

 ; ( c -- )
-	.db "EMIT", 0, 0, 0, 0
+	.db "EMIT"
+	.fill 4
 	.dw BYE
 EMIT:
 	.dw nativeWord
@ -208,7 +212,8 @@ EMIT:
 	jp	exit

 ; ( addr -- )
-	.db "EXECUTE", 0
+	.db "EXECUTE"
+	.db 0
 	.dw EMIT
 EXECUTE:
 	.dw nativeWord
@ -239,19 +244,18 @@ DEFINE:
 	; All we need to do is to know how many bytes to copy. To do so, we
 	; skip compwords until EXIT is reached.
 	ld	(HERE), hl	; where we write compwords.
-	; Let's save old RS TOS
-	ld	e, (ix)
-	ld	d, (ix+1)
+	ld	l, (ix)
+	ld	h, (ix+1)
 .loop:
-	call	RSIsEXIT
+	call	HLPointsEXIT
 	jr	z, .loopend
 	call	compSkip
 	jr	.loop
 .loopend:
-	; At this point, RS' TOS points to EXIT compword. We'll copy it too.
+	; At this point, HL points to EXIT compword. We'll copy it too.
 	; We'll use LDIR. BC will be RSTOP-OLDRSTOP+2
-	ld	l, (ix)
-	ld	h, (ix+1)
+	ld	e, (ix)
+	ld	d, (ix+1)
 	inc	hl \ inc hl	; our +2
 	or	a		; clear carry
 	sbc	hl, de
@ -267,7 +271,8 @@ DEFINE:
 	ld	(HERE), de	; update HERE
 	jp	exit

-	.db "DOES>", 0, 0, 0
+	.db "DOES>"
+	.fill 3
 	.dw DEFINE
 DOES:
 	.dw nativeWord
@ -300,7 +305,8 @@ KEY:
 	push	hl
 	jp	exit

-	.db "INTERPRE"
+	.db "INTERPR"
+	.db 0
 	.dw KEY
 INTERPRET:
 	.dw nativeWord
@ -317,7 +323,8 @@ interpret:
 	ld	iy, COMPBUF
 	jp	compiledWord

-	.db "CREATE", 0, 0
+	.db "CREATE"
+	.fill 2
 	.dw INTERPRET
 CREATE:
 	.dw nativeWord
@ -338,7 +345,8 @@ HERE_:	; Caution: conflicts with actual variable name
 	.dw sysvarWord
 	.dw HERE

-	.db "CURRENT", 0
+	.db "CURRENT"
+	.db 0
 	.dw HERE_
 CURRENT_:
 	.dw sysvarWord
@ -514,7 +522,8 @@ STOREINC:

 ; ( n -- )
 ; HERE +!
-	.db "ALLOT", 0, 0, 0
+	.db "ALLOT"
+	.fill 3
 	.dw STOREINC
 ALLOT:
 	.dw compiledWord
@ -523,7 +532,8 @@ ALLOT:
 	.dw EXIT

 ; CREATE 2 ALLOT
-	.db "VARIABLE"
+	.db "VARIABL"
+	.db 0
 	.dw ALLOT
 VARIABLE:
 	.dw compiledWord
@ -535,7 +545,8 @@ VARIABLE:

 ; ( n -- )
 ; CREATE HERE @ ! DOES> @
-	.db "CONSTANT"
+	.db "CONSTAN"
+	.db 0
 	.dw VARIABLE
 CONSTANT:
 	.dw compiledWord
--- a/apps/forth/main.asm
+++ b/apps/forth/main.asm
@ -4,9 +4,9 @@
 ; Number of bytes we keep as a padding between HERE and the scratchpad
 .equ	PADDING		0x20
 ; Max length of dict entry names
-.equ	NAMELEN		8
+.equ	NAMELEN		7
 ; Offset of the code link relative to the beginning of the word
-.equ	CODELINK_OFFSET	NAMELEN+2
+.equ	CODELINK_OFFSET	NAMELEN+3

 ; *** Variables ***
 .equ	INITIAL_SP	FORTH_RAMSTART
--- a/apps/forth/util.asm
+++ b/apps/forth/util.asm
@ -43,78 +43,78 @@ readword:
 	inc	a	; unset Z
 	ret

-RSIsDE:
-	push	hl
-	ld	l, (ix)
-	ld	h, (ix+1)
+; Sets Z if (HL) == E and (HL+1) == D
+HLPointsDE:
 	ld	a, (hl)
 	cp	e
-	jr	nz, .end	; no
+	ret	nz		; no
 	inc	hl
 	ld	a, (hl)
+	dec	hl
 	cp	d		; Z has our answer
-.end:
-	pop	hl
 	ret


-; Is RS' TOS pointing to a NUMBER word?
-; Z if yes, NZ if no.
-RSIsNUMBER:
+HLPointsNUMBER:
 	push	de
 	ld	de, NUMBER
-	call	RSIsDE
+	call	HLPointsDE
 	pop	de
 	ret

-; Is RS' TOS pointing to a LIT word?
-; Z if yes, NZ if no.
-RSIsLIT:
+HLPointsLIT:
 	push	de
 	ld	de, LIT
-	call	RSIsDE
+	call	HLPointsDE
 	pop	de
 	ret

-; Is RS' TOS pointing to EXIT?
-; Z if yes, NZ if no.
-RSIsEXIT:
+HLPointsEXIT:
 	push	de
 	ld	de, EXIT
-	call	RSIsDE
+	call	HLPointsDE
 	pop	de
 	ret

-; Skip the compword where RS' TOS is currently pointing. If it's a regular word,
+; 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.
 compSkip:
-	push	hl
-	ld	l, (ix)
-	ld	h, (ix+1)
-	; At the minimum, we skip by 2
-	inc	hl \ inc hl
-	call	RSIsNUMBER
+	call	HLPointsNUMBER
 	jr	z, .isNum
-	call	RSIsLIT
-	jr	nz, .end	; A word
+	call	HLPointsLIT
+	jr	nz, .isWord
 	; We have a literal
+	inc	hl \ inc hl
 	call	strskip
 	inc	hl		; byte after word termination
-	jr	.end
+	ret
 .isNum:
 	; skip by 4
 	inc	hl \ inc hl
-.end:
-	; HL is good, write it to RS
-	ld	(ix), l
-	ld	(ix+1), h
-	pop	hl
+	; continue to isWord
+.isWord:
+	; skip by 2
+	inc	hl \ inc hl
 	ret

-; Checks RS' TOS and, if it points to a string literal (LIT), makes HL point
-; to it and advance IP to byte following null-termination.
-; If it doesn't, things get interesting: If it's a word reference, then it's
+; The goal of this routine is to read a string literal following the currently
+; executed words. For example, CREATE and DEFINE need this. Things are a little
+; twisted, so bear with me while I explain how it works.
+;
+; When we call this routine, everything has been compiled. We're on an atom and
+; we're executing it. Now, we're looking for a string literal or a word-with-a
+; name that follows our readCompWord caller. We could think that this word is
+; right there on RS' TOS, but no! You have to account for words wrapping the
+; caller. For example, "VARIABLE" calls "CREATE". If you call "VARIABLE foo",
+; if CREATE looks at what follows in RS' TOS, it will only find the "2" in
+; "CREATE 2 ALLOT".
+;
+; Therefore, we actually need to check in RS' *bottom of stack* for our answer.
+; If that atom is a LIT, we're good. We make HL point to it and advance IP to
+; byte following null-termination.
+;
+; If it isn't, things get interesting: If it's a word reference, then it's
 ; not an invalid literal. For example, one could want to redefine an existing
 ; word. So in that case, we'll copy the word's name on the pad (it might not be
 ; null-terminated) and set HL to point to it.
@ -124,18 +124,22 @@ compSkip:
 ; word. Yeah, it means that ";" can't be overridden...
 ; If name can't be read, we abort
 readCompWord:
-	; In all cases, we want RS' TOS in HL. Let's get it now.
-	ld	l, (ix)
-	ld	h, (ix+1)
-	call	RSIsLIT
+	; In all cases, we want RS' BOS in HL. Let's get it now.
+	ld	hl, (RS_ADDR)
+	call	HLPointsLIT
 	jr	nz, .notLIT
-	; RS TOS is a LIT, make HL point to string, then skip this RS compword.
+	; RS BOS is a LIT, make HL point to string, then skip this RS compword.
 	inc	hl \ inc hl	; HL now points to string itself
-	jr	compSkip
+	push	hl		; --> lvl 1, our result
+	call	strskip
+	inc	hl		; byte after word termination
+	ld	(RS_ADDR), hl
+	pop	hl		; <-- lvl 1, our result
+	ret
 .notLIT:
 	; Alright, not a literal, but is it a word? If it's not a number, then
 	; it's a word.
-	call	RSIsNUMBER
+	call	HLPointsNUMBER
 	jr	z, .notWord
 	; Not a number, then it's a word. Copy word to pad and point to it.
 	call	intoHL
@ -153,7 +157,9 @@ readCompWord:
 	; null-terminate
 	xor	a
 	ld	(de), a
-	call	compSkip
+	; Advance RS' BOS by 2
+	ld	hl, RS_ADDR
+	inc	(hl) \ inc (hl)
 	pop	hl		; <-- lvl 1
 	ret
 .notWord:
@ -251,13 +257,15 @@ compile:
 ; HL points to new (HERE)
 entryhead:
 	call	readCompWord
-	call	printstr
 	ld	de, (HERE)
 	call	strcpy
 	ex	de, hl		; (HERE) now in HL
 	ld	de, (CURRENT)
 	ld	a, NAMELEN
 	call	addHL
+	xor	a		; IMMED
+	ld	(hl), a
+	inc	hl
 	ld	(hl), e
 	inc	hl
 	ld	(hl), d