From 989d8bbabf903ba442a4afd5ca093cab8a79459d Mon Sep 17 00:00:00 2001
From: Virgil Dupras <hsoft@hardcoded.net>
Date: Sat, 7 Mar 2020 22:18:14 -0500
Subject: [PATCH] forth: add "DOES>" and "CONSTANT"

---
 apps/forth/dict.asm       | 59 +++++++++++++++++++++++++++++++++++++--
 apps/forth/dictionary.txt | 15 ++++++++++
 apps/forth/main.asm       |  2 +-
 apps/forth/stack.asm      |  2 +-
 4 files changed, 74 insertions(+), 4 deletions(-)

diff --git a/apps/forth/dict.asm b/apps/forth/dict.asm
index 5cc87e8..911fd4f 100644
--- a/apps/forth/dict.asm
+++ b/apps/forth/dict.asm
@@ -42,6 +42,17 @@ sysvarWord:
 	push	hl
 	jp	exit
 
+; 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
@@ -175,11 +186,34 @@ DEFINE:
 	or	a
 	ret
 
+DOES:
+	.db "DOES>", 0, 0, 0
+	.dw DEFINE
+	.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. Get the Interpreter pointer from the stack and write this down to
+	;    entry PFA+2.
+	; 3. exit. Because we've already popped RS, a regular exit will abort
+	;    colon definition, so we're good.
+	ld	iy, (CURRENT)
+	ld	de, CODELINK_OFFSET
+	add	iy, de
+	ld	hl, doesWord
+	call	wrCompHL
+	inc	iy \ inc iy		; cell variable space
+	call	popRS
+	call	wrCompHL
+	ld	(HERE), iy
+	jp	exit
+
 ; ( -- c )
 KEY:
 	.db "KEY"
 	.fill 5
-	.dw DEFINE
+	.dw DOES
 	.dw nativeWord
 	call	stdioGetC
 	ld	h, 0
@@ -230,11 +264,17 @@ HERE_:	; Caution: conflicts with actual variable name
 	.dw sysvarWord
 	.dw HERE
 
+CURRENT_:
+	.db "CURRENT", 0
+	.dw HERE_
+	.dw sysvarWord
+	.dw CURRENT
+
 ; ( n -- )
 DOT:
 	.db "."
 	.fill 7
-	.dw HERE_
+	.dw CURRENT_
 	.dw nativeWord
 	pop	de
 	; We check PS explicitly because it doesn't look nice to spew gibberish
@@ -389,3 +429,18 @@ ALLOT:
 	.dw HERE_+CODELINK_OFFSET
 	.dw STOREINC+CODELINK_OFFSET
 	.dw EXIT+CODELINK_OFFSET
+
+; ( n -- )
+; CREATE HERE @ ! DOES> @
+CONSTANT:
+	.db "CONSTANT"
+	.dw ALLOT
+	.dw compiledWord
+	.dw CREATE+CODELINK_OFFSET
+	.dw HERE_+CODELINK_OFFSET
+	.dw FETCH+CODELINK_OFFSET
+	.dw STORE+CODELINK_OFFSET
+	.dw DOES+CODELINK_OFFSET
+	.dw FETCH+CODELINK_OFFSET
+	.dw EXIT+CODELINK_OFFSET
+
diff --git a/apps/forth/dictionary.txt b/apps/forth/dictionary.txt
index c677d27..16cb7c5 100644
--- a/apps/forth/dictionary.txt
+++ b/apps/forth/dictionary.txt
@@ -2,6 +2,19 @@ Stack notation: "<stack before> -- <stack after>". Rightmost is top of stack
                 (TOS). For example, in "a b -- c d", b is TOS before, d is TOS
                 after. "R:" means that the Return Stack is modified.
 
+DOES>: Used inside a colon definition that itself uses CREATE, DOES> transforms
+       that newly created word into a "does cell", that is, a regular cell (
+       when called, puts the cell's addr on PS), but right after that, it
+       executes words that appear after the DOES>.
+
+       "does cells" always allocate 4 bytes (2 for the cell, 2 for the DOES>
+       link) and there is no need for ALLOT in colon definition.
+
+       At compile time, colon definition stops processing words when reaching
+       the DOES>.
+
+       Example: ": CONSTANT CREATE HERE @ ! DOES> @ ;"
+
 *** Native Words ***
 
 : x ... ;   --              Define a new word
@@ -13,6 +26,7 @@ Stack notation: "<stack before> -- <stack after>". Rightmost is top of stack
 *           a b -- c        a * b -> c
 /           a b -- c        a / b -> c
 CREATE x    --              Create cell named x
+DOES>       --              See description at top of file
 DUP         a -- a a
 EMIT        c --            Spit char c to stdout
 EXECUTE     a --            Execute word at addr a
@@ -30,3 +44,4 @@ SWAP        a b -- b a
 ?           a --            Print value of addr a
 +!          n a --          Increase value of addr a by n
 ALLOT       n --            Move HERE by n bytes
+CONSTANT x  n --            Creates cell x that when called pushes its value
diff --git a/apps/forth/main.asm b/apps/forth/main.asm
index 2803341..807b38f 100644
--- a/apps/forth/main.asm
+++ b/apps/forth/main.asm
@@ -57,7 +57,7 @@ forthMain:
 	; we check for stack underflow.
 	push	af \ push af \ push af
 	ld	(INITIAL_SP), sp
-	ld	hl, ALLOT		; last entry in hardcoded dict
+	ld	hl, CONSTANT		; last entry in hardcoded dict
 	ld	(CURRENT), hl
 	ld	hl, FORTH_RAMEND
 	ld	(HERE), hl
diff --git a/apps/forth/stack.asm b/apps/forth/stack.asm
index dded5ee..bbebba2 100644
--- a/apps/forth/stack.asm
+++ b/apps/forth/stack.asm
@@ -36,6 +36,6 @@ chkPS:
 	; underflow
 	ld	hl, .msg
 	call	printstr
-	jr	abort
+	jp	abort
 .msg:
 	.db "stack underflow", 0