forth: add words "CREATE", "@", "!", "HERE", "QUIT"

apps/forth/dict.asm

@@ -2,14 +2,14 @@
 ; - 8b name (zero-padded)
 ; - 2b prev pointer
 ; - 2b code pointer
-; - Parameter field area (PFA)
+; - Parameter field (PF)
 ;
 ; The code pointer point to "word routines". These routines expect to be called
-; with IY pointing to the PFA. They themselves are expected to end by jumping
+; with IY pointing to the PF. They themselves are expected to end by jumping
 ; to the address at the top of the Return Stack. They will usually do so with
 ; "jp exit".
 
-; Execute a word containing native code at its PFA
+; Execute a word containing native code at its PF address (PFA)
 nativeWord:
 	jp	(iy)
 
@@ -30,6 +30,18 @@ compiledWord:
 	; IY points to code link
 	jp	executeCodeLink
 
+; Pushes the PFA directly
+cellWord:
+	push	iy
+	jp	exit
+
+; Pushes the address in the first word of the PF
+sysvarWord:
+	ld	l, (iy)
+	ld	h, (iy+1)
+	push	hl
+	jp	exit
+
 ; ( R:I -- )
 EXIT:
 	.db "EXIT", 0, 0, 0, 0
@@ -45,10 +57,20 @@ exit:
 	push	hl \ pop iy
 	jp	compiledWord
 
+; ( R:I -- )
+QUIT:
+	.db "QUIT", 0, 0, 0, 0
+	.dw EXIT
+	.dw nativeWord
+quit:
+	ld	hl, FLAGS
+	set	FLAG_QUITTING, (hl)
+	jp	exit
+
 BYE:
 	.db "BYE"
 	.fill 5
-	.dw EXIT
+	.dw QUIT
 	.dw nativeWord
 	ld	hl, FLAGS
 	set	FLAG_ENDPGM, (hl)
@@ -83,7 +105,8 @@ executeCodeLink:
 
 ; ( -- c )
 KEY:
-	.db "KEY", 0, 0, 0, 0, 0
+	.db "KEY"
+	.fill 5
 	.dw EXECUTE
 	.dw nativeWord
 	call	stdioGetC
@@ -97,36 +120,86 @@ INTERPRET:
 	.dw KEY
 	.dw nativeWord
 interpret:
-	call	pad
-	push	hl \ pop iy
-	call	stdioReadLine
-	ld	(INPUTPOS), hl
-.loop:
 	call	readword
-	jp	nz, .loopend
+	jp	nz, quit
+	ld	iy, COMPBUF
 	call	compile
-	jr	nz, .notfound
+	jp	nz, .notfound
-	jr	.loop
+	ld	hl, EXIT+CODELINK_OFFSET
-.loopend:
+	ld	(iy), l
-	call	compileExit
+	ld	(iy+1), h
-	call	pad
+	ld	iy, COMPBUF
-	push	hl \ pop iy
 	jp	compiledWord
 .notfound:
 	ld	hl, .msg
 	call	printstr
-	jp	exit
+	jp	quit
 .msg:
 	.db	"not found", 0
 
+CREATE:
+	.db "CREATE", 0, 0
+	.dw INTERPRET
+	.dw nativeWord
+	call	readword
+	jp	nz, exit
+	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
+	ld	(hl), d
+	inc	hl
+	ld	(HERE), hl
+	jp	exit
+
+HERE_:	; Caution: conflicts with actual variable name
+	.db "HERE"
+	.fill 4
+	.dw CREATE
+	.dw sysvarWord
+	.dw HERE
+
 ; ( n -- )
 DOT:
 	.db "."
 	.fill 7
-	.dw INTERPRET
+	.dw HERE_
 	.dw nativeWord
 	pop	de
 	call	pad
 	call	fmtDecimalS
 	call	printstr
 	jp	exit
+
+; ( n a -- )
+STORE:
+	.db "!"
+	.fill 7
+	.dw DOT
+	.dw nativeWord
+	pop	iy
+	pop	hl
+	ld	(iy), l
+	ld	(iy+1), h
+	jp	exit
+
+; ( a -- n )
+FETCH:
+	.db "@"
+	.fill 7
+	.dw STORE
+	.dw nativeWord
+	pop	hl
+	call	intoHL
+	push	hl
+	jp	exit

apps/forth/dictionary.txt

@@ -2,9 +2,15 @@ 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.
 
+.           n --            Print n in its decimal form
+@           a -- n          Set n to value at address a
+!           n a --          Store n in address a
+CREATE x    --              Create cell named x
 EMIT        c --            Spit char c to stdout
 EXECUTE     a --            Execute word at addr a
 EXIT        R:I --          Exit a colon definition
+HERE        -- a            Push HERE's address
+QUIT        R:drop --       Return to interpreter promp immediately
 KEY         -- c            Get char c from stdin
 INTERPRET   --              Get a line from stdin, compile it in tmp memory,
                             then execute the compiled contents.

apps/forth/glue.asm

@@ -2,6 +2,7 @@
 jp	forthMain
 
 .inc "core.asm"
+.inc "lib/util.asm"
 .inc "lib/ari.asm"
 .inc "lib/fmt.asm"
 .equ FORTH_RAMSTART RAMSTART

apps/forth/main.asm

@@ -3,9 +3,14 @@
 .equ	RS_ADDR		0xf000
 ; 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
 ; Offset of the code link relative to the beginning of the word
 .equ	CODELINK_OFFSET	10
-; When set, the interpret should quit
+; When set, the interpreter should abort parsing of current line and return to
+; prompt.
+.equ	FLAG_QUITTING	0
+; When set, the interpreter should quit
 .equ	FLAG_ENDPGM	1
 
 ; *** Variables ***
@@ -14,7 +19,9 @@
 .equ	HERE		@+2
 .equ	INPUTPOS	@+2
 .equ	FLAGS		@+2
-.equ	FORTH_RAMEND	@+1
+; Buffer where we compile the current input line. Same size as STDIO_BUFSIZE.
+.equ	COMPBUF		@+1
+.equ	FORTH_RAMEND	@+0x40
 
 ; *** Code ***
 MAIN:
@@ -28,22 +35,34 @@ CHKEND:
 	ld	hl, FLAGS
 	bit	FLAG_ENDPGM, (hl)
 	jr	nz, .endpgm
-	; not quitting, loop
+	; not quitting program, are we supposed to continue parsing line?
-	jr	forthLoop
+	ld	hl, FLAGS
+	bit	FLAG_QUITTING, (hl)
+	jr	nz, forthRdLine
+	; Not quitting line either.
+	jr	forthInterpret
 .endpgm:
 	ld	sp, (INITIAL_SP)
 	xor	a
 	ret
 
 forthMain:
-	xor	a
-	ld	(FLAGS), a
 	ld	(INITIAL_SP), sp
-	ld	hl, DOT		; last entry in hardcoded dict
+	ld	hl, FETCH		; last entry in hardcoded dict
 	ld	(CURRENT), hl
 	ld	hl, FORTH_RAMEND
 	ld	(HERE), hl
-forthLoop:
+forthRdLine:
+	xor	a
+	ld	(FLAGS), a
+	ld	hl, msgOk
+	call	printstr
+	call	printcrlf
+	call	stdioReadLine
+	ld	(INPUTPOS), hl
+forthInterpret:
 	ld	ix, RS_ADDR
 	ld	iy, MAIN
 	jp	executeCodeLink
+msgOk:
+	.db	" ok", 0

apps/forth/util.asm

@@ -2,8 +2,7 @@
 pad:
 	ld	hl, (HERE)
 	ld	a, PADDING
-	call	addHL
+	jp	addHL
-	ret
 
 ; Read word from (INPUTPOS) and return, in HL, a null-terminated word.
 ; Advance (INPUTPOS) to the character following the whitespace ending the
@@ -48,7 +47,7 @@ readword:
 ; Z is set if DE point to 0 (no entry). NZ if not.
 prev:
 	push	hl		; --> lvl 1
-	ld	hl, 8		; prev field offset
+	ld	hl, NAMELEN	; prev field offset
 	add	hl, de
 	ex	de, hl
 	pop	hl		; <-- lvl 1
@@ -66,7 +65,7 @@ prev:
 find:
 	ld	de, (CURRENT)
 .inner:
-	ld	a, 8
+	ld	a, NAMELEN
 	call	strncmp
 	ret	z		; found
 	call	prev
@@ -75,7 +74,7 @@ find:
 	inc	a
 	ret
 
-; Compile word string at (HL) and write down its compiled version in IY,
+; Compile word at (DE) 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:
@@ -90,12 +89,3 @@ compile:
 	inc	iy
 	xor	a	; set Z
 	ret
-
-compileExit:
-	ld	hl, EXIT+CODELINK_OFFSET
-	ld	(iy), l
-	inc	iy
-	ld	(iy), h
-	inc	iy
-	ret
-