forth: add "DOES>" and "CONSTANT"

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
+

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

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

apps/forth/stack.asm

@@ -36,6 +36,6 @@ chkPS:
 	; underflow
 	ld	hl, .msg
 	call	printstr
-	jr	abort
+	jp	abort
 .msg:
 	.db "stack underflow", 0