From d60ea4cb30daa0b5ac6b792457e743f6c92646e5 Mon Sep 17 00:00:00 2001
From: Virgil Dupras <hsoft@hardcoded.net>
Date: Fri, 13 Mar 2020 16:40:55 -0400
Subject: [PATCH] forth: Forth-ify RECURSE

This comes with RS-modifying words. Also, this commit separates ";" from "EXIT",
allowing EXIT to be used in definitions (was needed for RECURSE).
---
 apps/forth/core.fth       |   1 +
 apps/forth/dict.asm       | 111 ++++++++++++++++++++++++++++++--------
 apps/forth/dictionary.txt |  16 ++++--
 apps/forth/main.asm       |   4 ++
 apps/forth/stack.asm      |  12 ++++-
 apps/forth/util.asm       |   7 ---
 6 files changed, 115 insertions(+), 36 deletions(-)

diff --git a/apps/forth/core.fth b/apps/forth/core.fth
index 91dc88a..1e2be46 100644
--- a/apps/forth/core.fth
+++ b/apps/forth/core.fth
@@ -14,3 +14,4 @@
 : = CMP NOT ;
 : < CMP 0 1 - = ;
 : > CMP 1 = ;
+: RECURSE R> R> 2 - >R >R EXIT ;
diff --git a/apps/forth/dict.asm b/apps/forth/dict.asm
index 189f994..6ffff1c 100644
--- a/apps/forth/dict.asm
+++ b/apps/forth/dict.asm
@@ -18,7 +18,7 @@
 ; IP, but we also take care of increasing it my 2 before jumping
 next:
 	; Before we continue: are stacks within bounds?
-	call	chkPS
+	call	chkPSRS
 	ld	de, (IP)
 	ld	h, d
 	ld	l, e
@@ -115,9 +115,10 @@ LIT:
 
 ; Pop previous IP from Return stack and execute it.
 ; ( R:I -- )
-	.db ";"
-	.fill 7
-	.dw 0
+	.db	"EXIT"
+	.fill	3
+	.dw	0
+	.db	0
 EXIT:
 	.dw nativeWord
 	call	popRS
@@ -214,9 +215,18 @@ executeCodeLink:
 	; IY points to PFA
 	jp	(hl)	; go!
 
+
+	.db	";"
+	.fill	6
+	.dw	EXECUTE
+	.db	0
+ENDDEF:
+	.dw	nativeWord
+	jp	EXIT+2
+
 	.db ":"
 	.fill 6
-	.dw EXECUTE
+	.dw ENDDEF
 	.db 0
 DEFINE:
 	.dw nativeWord
@@ -232,7 +242,10 @@ DEFINE:
 	ld	(HERE), de	; update HERE
 	ld	hl, (IP)
 .loop:
-	call	HLPointsEXIT
+	push	de		; --> lvl 1
+	ld	de, ENDDEF
+	call	HLPointsDE
+	pop	de		; <-- lvl 1
 	jr	z, .loopend
 	call	compSkip
 	jr	.loop
@@ -358,9 +371,20 @@ KEY:
 	push	hl
 	jp	next
 
+	.db "WORD"
+	.fill 3
+	.dw KEY
+	.db 0
+WORD:
+	.dw nativeWord
+	call	readword
+	jp	nz, abort
+	push	hl
+	jp	next
+
 	.db "CREATE"
 	.fill 1
-	.dw KEY
+	.dw WORD
 	.db 0
 CREATE:
 	.dw nativeWord
@@ -398,7 +422,7 @@ DOT:
 	pop	de
 	; We check PS explicitly because it doesn't look nice to spew gibberish
 	; before aborting the stack underflow.
-	call	chkPS
+	call	chkPSRS
 	call	pad
 	call	fmtDecimalS
 	call	printstr
@@ -454,7 +478,6 @@ CFETCH:
 	push	hl
 	jp	next
 
-; ( -- a )
 	.db "LIT@"
 	.fill 3
 	.dw CFETCH
@@ -554,10 +577,63 @@ OVER2:
 	push	bc	; B
 	jp	next
 
+	.db	">R"
+	.fill	5
+	.dw	OVER2
+	.db	0
+P2R:
+	.dw	nativeWord
+	pop	hl
+	call	pushRS
+	jp	next
+
+	.db	"R>"
+	.fill	5
+	.dw	P2R
+	.db	0
+R2P:
+	.dw	nativeWord
+	call	popRS
+	push	hl
+	jp	next
+
+	.db	"I"
+	.fill	6
+	.dw	R2P
+	.db	0
+I:
+	.dw	nativeWord
+	ld	l, (ix)
+	ld	h, (ix+1)
+	push	hl
+	jp	next
+
+	.db	"I'"
+	.fill	5
+	.dw	I
+	.db	0
+IPRIME:
+	.dw	nativeWord
+	ld	l, (ix-2)
+	ld	h, (ix-1)
+	push	hl
+	jp	next
+
+	.db	"J"
+	.fill	6
+	.dw	IPRIME
+	.db	0
+J:
+	.dw	nativeWord
+	ld	l, (ix-4)
+	ld	h, (ix-3)
+	push	hl
+	jp	next
+
 ; ( a b -- c ) A + B
 	.db "+"
 	.fill 6
-	.dw OVER2
+	.dw J
 	.db 0
 PLUS:
 	.dw nativeWord
@@ -670,17 +746,6 @@ FBRC:
 	ld	(IP), hl
 	jp	next
 
-
-	.db "RECURSE"
-	.dw FBRC
-	.db 0
-RECURSE:
-	.dw nativeWord
-	call	popRS
-	dec	hl \ dec hl
-	ld	(IP), hl
-	push	hl \ pop iy
-	jp	compiledWord
-
 LATEST:
-	.dw RECURSE
+	.dw FBRC
+
diff --git a/apps/forth/dictionary.txt b/apps/forth/dictionary.txt
index e877579..68a4a53 100644
--- a/apps/forth/dictionary.txt
+++ b/apps/forth/dictionary.txt
@@ -60,7 +60,7 @@ QUIT        R:drop --       Return to interpreter promp immediately
 RECURSE     R:I -- R:I-2    Run the current word again.
 THEN        I:a --          *I* Set branching cell at a.
 
-*** Stack ***
+*** Parameter Stack ***
 DUP         a -- a a
 OVER        a b -- a b a
 SWAP        a b -- b a
@@ -68,6 +68,13 @@ SWAP        a b -- b a
 2OVER       a b c d -- a b c d a b
 2SWAP       a b c d -- c d a b
 
+*** Return Stack ***
+>R          n -- R:n        Pops PS and push to RS
+R>          R:n -- n        Pops RS and push to PS
+I           -- n            Copy RS TOS to PS
+I'          -- n            Copy RS second item to PS
+J           -- n            Copy RS third item to PS
+
 *** Memory ***
 @           a -- n          Set n to value at address a
 !           n a --          Store n in address a
@@ -75,7 +82,7 @@ SWAP        a b -- b 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.
+CURRENT     -- a            Set a to wordref of last added entry.
 HERE        -- a            Push HERE's address
 H           -- a            HERE @
 
@@ -96,8 +103,8 @@ CMP         n1 n2 -- n      Compare n1 and n2 and set n to -1, 0, or 1.
 NOT         f -- f          Push the logical opposite of f
 
 *** Strings ***
-LIT@ x      -- a            Read folloing LIT and push its addr to a
-S=          a1 a2 -- n      Compare strings a1 and a2. See CMP
+LIT@ x      -- a            Read following LIT and push its addr to a
+SCMP        a1 a2 -- n      Compare strings a1 and a2. See CMP
 
 *** I/O ***
 .           n --            Print n in its decimal form
@@ -105,4 +112,5 @@ EMIT        c --            Spit char c to stdout
 KEY         -- c            Get char c from stdin
 PC!         c a --          Spit c to port a
 PC@         a -- c          Fetch c from port a
+WORD        -- a            Read one word from stdin and push its addr
 
diff --git a/apps/forth/main.asm b/apps/forth/main.asm
index 3c758e9..b0e3bc8 100644
--- a/apps/forth/main.asm
+++ b/apps/forth/main.asm
@@ -17,8 +17,12 @@
 
 ; *** Variables ***
 .equ	INITIAL_SP	FORTH_RAMSTART
+; wordref of the last entry of the dict.
 .equ	CURRENT		@+2
+; Pointer to the next free byte in dict. During compilation of input text, this
+; temporarily points to the next free byte in COMPBUF.
 .equ	HERE		@+2
+; Used to hold HERE while we temporarily point it to COMPBUF
 .equ	OLDHERE		@+2
 ; Interpreter pointer. See Execution model comment below.
 .equ	IP		@+2
diff --git a/apps/forth/stack.asm b/apps/forth/stack.asm
index 2ab221c..f7a63df 100644
--- a/apps/forth/stack.asm
+++ b/apps/forth/stack.asm
@@ -36,8 +36,15 @@ skipRS:
 	pop	hl
 	ret
 
-; Verifies that SP is within bounds. If it's not, call ABORT
-chkPS:
+; Verifies that SP and RS are within bounds. If it's not, call ABORT
+chkPSRS:
+	push	ix \ pop hl
+	push	de		; --> lvl 1
+	ld	de, RS_ADDR
+	or	a		; clear carry
+	sbc	hl, de
+	pop	de		; <-- lvl 1
+	jr	c, .underflow
 	ld	hl, (INITIAL_SP)
 	; We have the return address for this very call on the stack. Let's
 	; compensate
@@ -45,6 +52,7 @@ chkPS:
 	or	a		; clear carry
 	sbc	hl, sp
 	ret	nc		; (INITIAL_SP) >= SP? good
+.underflow:
 	; underflow
 	ld	hl, .msg
 	call	printstr
diff --git a/apps/forth/util.asm b/apps/forth/util.asm
index 0455141..4dec153 100644
--- a/apps/forth/util.asm
+++ b/apps/forth/util.asm
@@ -80,13 +80,6 @@ HLPointsBR:
 	pop	de
 	ret
 
-HLPointsEXIT:
-	push	de
-	ld	de, EXIT
-	call	HLPointsDE
-	pop	de
-	ret
-
 ; 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.