apps/forth/README.md

@@ -1,7 +0,0 @@
-# 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

@@ -1,457 +0,0 @@
-; 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

@@ -1,48 +0,0 @@
-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

@@ -1,14 +0,0 @@
-.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

@@ -1,77 +0,0 @@
-; *** 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

@@ -1,41 +0,0 @@
-; 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

@@ -1,132 +0,0 @@
-; 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,5 +8,4 @@
 /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 forth
+SHELLAPPS = zasm ed
 SHELLTGTS = ${SHELLAPPS:%=cfsin/%}
 CFSIN_CONTENTS = $(SHELLTGTS) cfsin/user.h
 OBJS = emul.o libz80/libz80.o