forth: add word ":"

apps/forth/dict.asm

@@ -103,11 +103,51 @@ executeCodeLink:
 	; IY points to PFA
 	jp	(hl)	; go!
 
+DEFINE:
+	.db ":"
+	.fill 7
+	.dw EXECUTE
+	.dw nativeWord
+	call	entryhead
+	jp	nz, quit
+	ld	de, compiledWord
+	ld	(hl), e
+	inc	hl
+	ld	(hl), d
+	inc	hl
+	push	hl \ pop iy
+.loop:
+	call	readword
+	jr	nz, .end
+	call	.issemicol
+	jr	z, .end
+	call	compile
+	jr	nz, quit
+	jr	.loop
+.end:
+	; end chain with EXIT
+	ld	hl, EXIT+CODELINK_OFFSET
+	ld	(iy), l
+	inc	iy
+	ld	(iy), h
+	inc	iy
+	ld	(HERE), iy
+	jp	exit
+.issemicol:
+	ld	a, (hl)
+	cp	';'
+	ret	nz
+	inc	hl
+	ld	a, (hl)
+	dec	hl
+	or	a
+	ret
+
 ; ( -- c )
 KEY:
 	.db "KEY"
 	.fill 5
-	.dw EXECUTE
+	.dw DEFINE
 	.dw nativeWord
 	call	stdioGetC
 	ld	h, 0
@@ -141,19 +181,8 @@ CREATE:
 	.db "CREATE", 0, 0
 	.dw INTERPRET
 	.dw nativeWord
-	call	readword
+	call	entryhead
-	jp	nz, exit
+	jp	nz, quit
-	ld	de, (HERE)
-	call	strcpy
-	ex	de, hl		; (HERE) now in HL
-	ld	de, (CURRENT)
-	ld	(CURRENT), hl
-	ld	a, NAMELEN
-	call	addHL
-	ld	(hl), e
-	inc	hl
-	ld	(hl), d
-	inc	hl
 	ld	de, cellWord
 	ld	(hl), e
 	inc	hl

apps/forth/dictionary.txt

@@ -2,6 +2,7 @@ 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.
 
+: x ... ;   --              Define a new word
 .           n --            Print n in its decimal form
 @           a -- n          Set n to value at address a
 !           n a --          Store n in address a

apps/forth/util.asm

@@ -74,7 +74,7 @@ find:
 	inc	a
 	ret
 
-; Compile word at (DE) and write down its compiled version in IY,
+; Compile word string at (HL) and write down its compiled version in IY,
 ; advancing IY to the byte next to the last written byte.
 ; Set Z on success, unset on failure.
 compile:
@@ -89,3 +89,24 @@ compile:
 	inc	iy
 	xor	a	; set Z
 	ret
+
+; Spit name + prev in (HERE) and adjust (HERE) and (CURRENT)
+; HL points to new (HERE)
+; Set Z if name could be read, NZ if not
+entryhead:
+	call	readword
+	ret	nz
+	ld	de, (HERE)
+	call	strcpy
+	ex	de, hl		; (HERE) now in HL
+	ld	de, (CURRENT)
+	ld	(CURRENT), hl
+	ld	a, NAMELEN
+	call	addHL
+	ld	(hl), e
+	inc	hl
+	ld	(hl), d
+	inc	hl
+	ld	(HERE), hl
+	xor	a		; set Z
+	ret