forth: add "VARIABLE"

And make interpret action looping until BYE.

apps/forth/README.md

@@ -0,0 +1,7 @@
+# Forth
+
+**WIP** A Forth interpreter. Far from complete, but you can do stuff like
+
+    KEY EMIT KEY EMIT
+
+See dictionary.txt for a word reference.

apps/forth/dict.asm

@@ -0,0 +1,457 @@
+; A dictionary entry has this structure:
+; - 8b name (zero-padded)
+; - 2b prev pointer
+; - 2b code pointer
+; - Parameter field (PF)
+;
+; The code pointer point to "word routines". These routines expect to be called
+; 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 PF address (PFA)
+nativeWord:
+	jp	(iy)
+
+; Execute a compiled word containing a list of references to other words,
+; usually ended by a reference to EXIT.
+; A reference to a word in a compiledWord section is *not* a direct reference,
+; but a word+CODELINK_OFFSET reference. Therefore, for a code link "link",
+; (link) is the routine to call.
+compiledWord:
+	push	iy \ pop hl
+	inc	hl
+	inc	hl
+	; HL points to next Interpreter pointer.
+	call	pushRS
+	ld	l, (iy)
+	ld	h, (iy+1)
+	push	hl \ pop iy
+	; 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
+
+; 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
+; that number is to play with the Return stack: We pop it, read the number, push
+; it to the Parameter stack and then push an increase Interpreter Pointer back
+; to RS.
+numberWord:
+	call	popRS
+	ld	e, (hl)
+	inc	hl
+	ld	d, (hl)
+	inc	hl
+	call	pushRS
+	push	de
+	jp	exit
+NUMBER:
+	.dw	numberWord
+
+
+; ( R:I -- )
+EXIT:
+	.db "EXIT", 0, 0, 0, 0
+	.dw 0
+	.dw nativeWord
+; When we call the EXIT word, we have to do a "double exit" because our current
+; Interpreter pointer is pointing to the word *next* to our EXIT reference when,
+; in fact, we want to continue processing the one above it.
+	call	popRS
+exit:
+	; Before we continue: is SP within bounds?
+	call	chkPS
+	; we're good
+	call	popRS
+	; We have a pointer to a word
+	push	hl \ pop iy
+	jr	compiledWord
+
+; ( R:I -- )
+QUIT:
+	.db "QUIT", 0, 0, 0, 0
+	.dw EXIT
+	.dw nativeWord
+quit:
+	ld	hl, FLAGS
+	set	FLAG_QUITTING, (hl)
+	jr	exit
+
+ABORT:
+	.db "ABORT", 0, 0, 0
+	.dw QUIT
+	.dw nativeWord
+abort:
+	ld	sp, (INITIAL_SP)
+	ld	hl, .msg
+	call	printstr
+	call	printcrlf
+	jr	quit
+.msg:
+	.db " err", 0
+
+BYE:
+	.db "BYE"
+	.fill 5
+	.dw ABORT
+	.dw nativeWord
+	ld	hl, FLAGS
+	set	FLAG_ENDPGM, (hl)
+	jp	exit
+
+; ( c -- )
+EMIT:
+	.db "EMIT", 0, 0, 0, 0
+	.dw BYE
+	.dw nativeWord
+	pop	hl
+	ld	a, l
+	call	stdioPutC
+	jp	exit
+
+; ( addr -- )
+EXECUTE:
+	.db "EXECUTE", 0
+	.dw EMIT
+	.dw nativeWord
+	pop	iy	; Points to word_offset
+	ld	de, CODELINK_OFFSET
+	add	iy, de
+executeCodeLink:
+	ld	l, (iy)
+	ld	h, (iy+1)
+	; HL points to code pointer
+	inc	iy
+	inc	iy
+	; 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
+	jp	nz, quit
+	jr	.loop
+.end:
+	; end chain with EXIT
+	ld	hl, EXIT+CODELINK_OFFSET
+	call	wrCompHL
+	ld	(HERE), iy
+	jp	exit
+.issemicol:
+	ld	a, (hl)
+	cp	';'
+	ret	nz
+	inc	hl
+	ld	a, (hl)
+	dec	hl
+	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 DOES
+	.dw nativeWord
+	call	stdioGetC
+	ld	h, 0
+	ld	l, a
+	push	hl
+	jp	exit
+
+INTERPRET:
+	.db "INTERPRE"
+	.dw KEY
+	.dw nativeWord
+interpret:
+	call	readword
+	jp	nz, quit
+	ld	iy, COMPBUF
+	call	compile
+	jp	nz, .notfound
+	ld	hl, EXIT+CODELINK_OFFSET
+	ld	(iy), l
+	ld	(iy+1), h
+	ld	iy, COMPBUF
+	jp	compiledWord
+.notfound:
+	ld	hl, .msg
+	call	printstr
+	jp	quit
+.msg:
+	.db	"not found", 0
+
+CREATE:
+	.db "CREATE", 0, 0
+	.dw INTERPRET
+	.dw nativeWord
+	call	entryhead
+	jp	nz, quit
+	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
+
+CURRENT_:
+	.db "CURRENT", 0
+	.dw HERE_
+	.dw sysvarWord
+	.dw CURRENT
+
+; ( n -- )
+DOT:
+	.db "."
+	.fill 7
+	.dw CURRENT_
+	.dw nativeWord
+	pop	de
+	; We check PS explicitly because it doesn't look nice to spew gibberish
+	; before aborting the stack underflow.
+	call	chkPS
+	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
+
+; ( a b -- b a )
+SWAP:
+	.db "SWAP"
+	.fill 4
+	.dw FETCH
+	.dw nativeWord
+	pop	hl
+	ex	(sp), hl
+	push	hl
+	jp	exit
+
+; ( a -- a a )
+DUP:
+	.db "DUP"
+	.fill 5
+	.dw SWAP
+	.dw nativeWord
+	pop	hl
+	push	hl
+	push	hl
+	jp	exit
+
+; ( a b -- a b a )
+OVER:
+	.db "OVER"
+	.fill 4
+	.dw DUP
+	.dw nativeWord
+	pop	hl	; B
+	pop	de	; A
+	push	de
+	push	hl
+	push	de
+	jp	exit
+
+; ( a b -- c ) A + B
+PLUS:
+	.db "+"
+	.fill 7
+	.dw OVER
+	.dw nativeWord
+	pop	hl
+	pop	de
+	add	hl, de
+	push	hl
+	jp	exit
+
+; ( a b -- c ) A - B
+MINUS:
+	.db "-"
+	.fill 7
+	.dw PLUS
+	.dw nativeWord
+	pop	de		; B
+	pop	hl		; A
+	or	a		; reset carry
+	sbc	hl, de
+	push	hl
+	jp	exit
+
+; ( a b -- c ) A * B
+MULT:
+	.db "*"
+	.fill 7
+	.dw MINUS
+	.dw nativeWord
+	pop	de
+	pop	bc
+	call	multDEBC
+	push	hl
+	jp	exit
+
+; ( a b -- c ) A / B
+DIV:
+	.db "/"
+	.fill 7
+	.dw MULT
+	.dw nativeWord
+	pop	de
+	pop	hl
+	call	divide
+	push	bc
+	jp	exit
+
+; End of native words
+
+; ( a -- )
+; @ .
+FETCHDOT:
+	.db "?"
+	.fill 7
+	.dw DIV
+	.dw compiledWord
+	.dw FETCH+CODELINK_OFFSET
+	.dw DOT+CODELINK_OFFSET
+	.dw EXIT+CODELINK_OFFSET
+
+; ( n a -- )
+; SWAP OVER @ + SWAP !
+STOREINC:
+	.db "+!"
+	.fill 6
+	.dw FETCHDOT
+	.dw compiledWord
+	.dw SWAP+CODELINK_OFFSET
+	.dw OVER+CODELINK_OFFSET
+	.dw FETCH+CODELINK_OFFSET
+	.dw PLUS+CODELINK_OFFSET
+	.dw SWAP+CODELINK_OFFSET
+	.dw STORE+CODELINK_OFFSET
+	.dw EXIT+CODELINK_OFFSET
+
+; ( n -- )
+; HERE +!
+ALLOT:
+	.db "ALLOT", 0, 0, 0
+	.dw STOREINC
+	.dw compiledWord
+	.dw HERE_+CODELINK_OFFSET
+	.dw STOREINC+CODELINK_OFFSET
+	.dw EXIT+CODELINK_OFFSET
+
+; CREATE 2 ALLOT
+VARIABLE:
+	.db "VARIABLE"
+	.dw ALLOT
+	.dw compiledWord
+	.dw CREATE+CODELINK_OFFSET
+	.dw NUMBER
+	.dw 2
+	.dw ALLOT+CODELINK_OFFSET
+	.dw EXIT+CODELINK_OFFSET
+
+; ( n -- )
+; CREATE HERE @ ! DOES> @
+CONSTANT:
+	.db "CONSTANT"
+	.dw VARIABLE
+	.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

@@ -0,0 +1,48 @@
+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
+.           n --            Print n in its decimal form
+@           a -- n          Set n to value at address a
+!           n a --          Store n in address a
++           a b -- c        a + b -> c
+-           a b -- c        a - b -> c
+*           a b -- c        a * b -> c
+/           a b -- c        a / b -> c
+CREATE x    --              Create cell named x. Doesn't allocate a PF.
+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
+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.
+OVER        a b -- a b a
+SWAP        a b -- b a
+
+*** Core-but-Forth Words ***
+
+?           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
+VARIABLE c  --              Creates cell x with 2 bytes allocation.

apps/forth/glue.asm

@@ -0,0 +1,14 @@
+.inc "user.h"
+jp	forthMain
+
+.inc "core.asm"
+.inc "lib/util.asm"
+.inc "lib/parse.asm"
+.inc "lib/ari.asm"
+.inc "lib/fmt.asm"
+.equ FORTH_RAMSTART RAMSTART
+.inc "forth/main.asm"
+.inc "forth/util.asm"
+.inc "forth/stack.asm"
+.inc "forth/dict.asm"
+RAMSTART:

apps/forth/main.asm

@@ -0,0 +1,77 @@
+; *** Const ***
+; Base of the Return Stack
+.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 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 ***
+.equ	INITIAL_SP	FORTH_RAMSTART
+.equ	CURRENT		@+2
+.equ	HERE		@+2
+.equ	INPUTPOS	@+2
+.equ	FLAGS		@+2
+; Buffer where we compile the current input line. Same size as STDIO_BUFSIZE.
+.equ	COMPBUF		@+1
+.equ	FORTH_RAMEND	@+0x40
+
+; *** Code ***
+MAIN:
+	.dw compiledWord
+	.dw INTERPRET+CODELINK_OFFSET
+	.dw CHKEND
+
+; If FLAG_ENDPGM is set, stop the program, else, tweak the RS so that we loop.
+CHKEND:
+	.dw nativeWord
+	ld	hl, FLAGS
+	bit	FLAG_ENDPGM, (hl)
+	jr	nz, .endpgm
+	; not quitting program, are we supposed to continue parsing line?
+	ld	hl, FLAGS
+	bit	FLAG_QUITTING, (hl)
+	jr	nz, forthRdLine
+	; Not quitting line either.
+	jr	forthInterpret
+.endpgm:
+	ld	sp, (INITIAL_SP)
+	; restore stack
+	pop	af \ pop af \ pop af
+	xor	a
+	ret
+
+forthMain:
+	; STACK OVERFLOW PROTECTION:
+	; To avoid having to check for stack underflow after each pop operation
+	; (which can end up being prohibitive in terms of costs), we give
+	; ourselves a nice 6 bytes buffer. 6 bytes because we seldom have words
+	; requiring more than 3 items from the stack. Then, at each "exit" call
+	; we check for stack underflow.
+	push	af \ push af \ push af
+	ld	(INITIAL_SP), sp
+	ld	hl, CONSTANT		; last entry in hardcoded dict
+	ld	(CURRENT), hl
+	ld	hl, FORTH_RAMEND
+	ld	(HERE), hl
+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/stack.asm

@@ -0,0 +1,41 @@
+; The Parameter stack (PS) is maintained by SP and the Return stack (RS) is
+; maintained by IX. This allows us to generally use push and pop freely because
+; PS is the most frequently used. However, this causes a problem with routine
+; calls: because in Forth, the stack isn't balanced within each call, our return
+; offset, when placed by a CALL, messes everything up. This is one of the
+; reasons why we need stack management routines below.
+;
+; This return stack contain "Interpreter pointers", that is a pointer to the
+; address of a word, as seen in a compiled list of words.
+
+; Push value HL to RS
+pushRS:
+	ld	(ix), l
+	inc	ix
+	ld	(ix), h
+	inc	ix
+	ret
+
+; Pop RS' TOS to HL
+popRS:
+	dec ix
+	ld	h, (ix)
+	dec ix
+	ld	l, (ix)
+	ret
+
+; Verifies that SP is within bounds. If it's not, call ABORT
+chkPS:
+	ld	hl, (INITIAL_SP)
+	; We have the return address for this very call on the stack. Let's
+	; compensate
+	dec	hl \ dec hl
+	or	a		; clear carry
+	sbc	hl, sp
+	ret	nc		; (INITIAL_SP) >= SP? good
+	; underflow
+	ld	hl, .msg
+	call	printstr
+	jp	abort
+.msg:
+	.db "stack underflow", 0

apps/forth/util.asm

@@ -0,0 +1,132 @@
+; Return address of scratchpad in HL
+pad:
+	ld	hl, (HERE)
+	ld	a, PADDING
+	jp	addHL
+
+; Read word from (INPUTPOS) and return, in HL, a null-terminated word.
+; Advance (INPUTPOS) to the character following the whitespace ending the
+; word.
+; Z set of word was read, unset if end of line.
+readword:
+	ld	hl, (INPUTPOS)
+	; skip leading whitespace
+	dec	hl	; offset leading "inc hl"
+.loop1:
+	inc	hl
+	ld	a, (hl)
+	or	a
+	jr	z, .empty
+	cp	' '+1
+	jr	c, .loop1
+	push	hl		; --> lvl 1. that's our result
+.loop2:
+	inc	hl
+	ld	a, (hl)
+	; special case: is A null? If yes, we will *not* inc A so that we don't
+	; go over the bounds of our input string.
+	or	a
+	jr	z, .noinc
+	cp	' '+1
+	jr	nc, .loop2
+	; we've just read a whitespace, HL is pointing to it. Let's transform
+	; it into a null-termination, inc HL, then set (INPUTPOS).
+	xor	a
+	ld	(hl), a
+	inc	hl
+.noinc:
+	ld	(INPUTPOS), hl
+	pop	hl		; <-- lvl 1. our result
+	ret	; Z set from XOR A
+.empty:
+	ld	(hl), a
+	inc	a	; unset Z
+	ret
+
+; For DE pointing to a dict entry, set DE to point to the previous entry.
+; Z is set if DE point to 0 (no entry). NZ if not.
+prev:
+	push	hl		; --> lvl 1
+	ld	hl, NAMELEN	; prev field offset
+	add	hl, de
+	ex	de, hl
+	pop	hl		; <-- lvl 1
+	call	intoDE
+	; DE points to prev. Is it zero?
+	xor	a
+	or	d
+	or	e
+	; Z will be set if DE is zero
+	ret
+
+; Find the entry corresponding to word where (HL) points to and sets DE to
+; point to that entry.
+; Z if found, NZ if not.
+find:
+	ld	de, (CURRENT)
+.inner:
+	ld	a, NAMELEN
+	call	strncmp
+	ret	z		; found
+	call	prev
+	jr	nz, .inner
+	; Z set? end of dict unset Z
+	inc	a
+	ret
+
+; Write compiled data from HL into IY, advancing IY at the same time.
+wrCompHL:
+	ld	(iy), l
+	inc	iy
+	ld	(iy), h
+	inc	iy
+	ret
+
+; 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:
+	call	find
+	jr	nz, .maybeNum
+	ret	nz
+	; DE is a word offset, we need a code link
+	ld	hl, CODELINK_OFFSET
+	add	hl, de
+	xor	a	; set Z
+	jr	wrCompHL
+.maybeNum:
+	call	parseLiteral
+	ret	nz
+	; a valid number!
+	ld	hl, NUMBER
+	call	wrCompHL
+	ex	de, hl		; number in HL
+	jr	wrCompHL
+	ret	z
+	; unknown name
+	ld	hl, .msg
+	call	printstr
+	jp	abort
+.msg:
+	.db "unknown name", 0
+
+; 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

emul/.gitignore

@@ -8,4 +8,5 @@
 /cfsin/zasm
 /cfsin/ed
 /cfsin/basic
+/cfsin/forth
 /cfsin/user.h

emul/Makefile

@@ -4,7 +4,7 @@ KERNEL = ../kernel
 APPS = ../apps
 ZASMBIN = zasm/zasm
 AVRABIN = zasm/avra
-SHELLAPPS = zasm ed
+SHELLAPPS = zasm ed forth
 SHELLTGTS = ${SHELLAPPS:%=cfsin/%}
 CFSIN_CONTENTS = $(SHELLTGTS) cfsin/user.h
 OBJS = emul.o libz80/libz80.o