emul: add forth target

apps/forth/dict.asm

@@ -243,34 +243,75 @@ DEFINE:
 	; been compiled by INTERPRET*. All those bytes will be copied as-is.
 	; All we need to do is to know how many bytes to copy. To do so, we
 	; skip compwords until EXIT is reached.
-	ld	(HERE), hl	; where we write compwords.
+	ex	de, hl		; DE is our dest
 	ld	l, (ix)
 	ld	h, (ix+1)
 .loop:
-	call	HLPointsEXIT
+	call	HLPointsNUMBER
-	jr	z, .loopend
+	jr	nz, .notNUMBER
-	call	compSkip
+	; is number
+	ld	bc, 4
+	ldir
 	jr	.loop
-.loopend:
+.notNUMBER:
-	; At this point, HL points to EXIT compword. We'll copy it too.
+	call	HLPointsLIT
-	; We'll use LDIR. BC will be RSTOP-OLDRSTOP+2
+	jr	nz, .notLIT
-	ld	e, (ix)
+	; is lit
-	ld	d, (ix+1)
+	ldi
-	inc	hl \ inc hl	; our +2
+	ldi
-	or	a		; clear carry
+	inc	hl \ inc hl
-	sbc	hl, de
+	call	strcpyM
-	ld	b, h
+	inc	hl		; byte after word termination
-	ld	c, l
+	jr	.loop
-	; BC has proper count
+.notLIT:
-	ex	de, hl		; HL is our source (old RS' TOS)
+	; it's a word
-	ld	de, (HERE)	; and DE is our dest
+	call	HLPointsIMMED
-	ldir			; go!
+	jr	nz, .notIMMED
+	; Immediate word, we'll have to call it.
+	; Before we make our call, let's save our current HL/DE position
+	ld	(HERE), de
+	ld	e, (hl)
+	inc	hl
+	ld	d, (hl)
+	inc	hl			; point to next word
+	push	de \ pop iy		; prepare for executeCodeLink
+	ld	(ix), l
+	ld	(ix+1), h
+	; Push return address
+	ld	hl, .retList
+	call	pushRS
+	; Ready!
+	jp	executeCodeLink
+.notIMMED:
+	; a good old regular word. We have 2 bytes to copy. But before we do,
+	; let's check whether it's an EXIT. LDI doesn't affect Z, so we can
+	; make our jump later.
+	call	HLPointsEXIT
+	ldi
+	ldi
+	jr	nz, .loop
 	; HL has our new RS' TOS
 	ld	(ix), l
 	ld	(ix+1), h
 	ld	(HERE), de	; update HERE
 	jp	exit
 
+; This label is pushed to RS when an IMMED word is called. When that word calls
+; exit, this is where it returns. When we return, RS will need to be popped so
+; that we stay on the proper RS level.
+.retList:
+	.dw	.retWord
+.retWord:
+	.dw	.retEntry
+.retEntry:
+	call	popRS		; unwind stack
+	; recall old HL / DE values
+	ld	l, (ix)
+	ld	h, (ix+1)
+	ld	de, (HERE)
+	; continue!
+	jr	.loop
+
 	.db "DOES>"
 	.fill 3
 	.dw DEFINE
@@ -293,10 +334,43 @@ DOES:
 	ld	(HERE), iy
 	jp	exit
 
+
+	.db "IMMEDIA"
+	.db 0
+	.dw DOES
+IMMEDIATE:
+	.dw nativeWord
+	ld	hl, (CURRENT)
+	dec	hl
+	dec	hl
+	dec	hl
+	inc	(hl)
+	jp	exit
+
+; ( n -- )
+	.db "LITERAL"
+	.db 1		; IMMEDIATE
+	.dw IMMEDIATE
+LITERAL:
+	.dw nativeWord
+	ld	hl, (HERE)
+	ld	de, NUMBER
+	ld	(hl), e
+	inc	hl
+	ld	(hl), d
+	inc	hl
+	pop	de		; number from stack
+	ld	(hl), e
+	inc	hl
+	ld	(hl), d
+	inc	hl
+	ld	(HERE), hl
+	jp	exit
+
 ; ( -- c )
 	.db "KEY"
 	.fill 5
-	.dw DOES
+	.dw LITERAL
 KEY:
 	.dw nativeWord
 	call	stdioGetC

apps/forth/dictionary.txt

@@ -25,39 +25,49 @@ Atom: A word of the type compiledWord contains, in its PF, a list of what we
 call "atoms". Those atoms are most of the time word references, but they can
 also be references to NUMBER and LIT.
 
-*** Native Words ***
+*** Defining words ***
-
 : x ...     --              Define a new word
 ;           R:I --          Exit a colon definition
-.           n --            Print n in its decimal form
+ALLOT       n --            Move HERE by n bytes
+CREATE x    --              Create cell named x. Doesn't allocate a PF.
+CONSTANT x  n --            Creates cell x that when called pushes its value
+DOES>       --              See description at top of file
+IMMEDIATE   --              Flag the latest defined word as immediate.
+LITERAL     n --            Inserts number from TOS as a literal
+VARIABLE c  --              Creates cell x with 2 bytes allocation.
+
+*** Flow ***
+ELSE        --              Branch to THEN
+EXECUTE     a --            Execute wordref at addr a
+IF          n --            Branch to ELSE or THEN if n is zero
+INTERPRET   --              Get a line from stdin, compile it in tmp memory,
+                            then execute the compiled contents.
+QUIT        R:drop --       Return to interpreter promp immediately
+THEN        --              Does nothing. Serves as a branching merker for IF
+                            and ELSE.
+
+*** Stack ***
+DUP         a -- a a
+OVER        a b -- a b a
+SWAP        a b -- b a
+
+*** Memory ***
 @           a -- n          Set n to value at address a
 !           n a --          Store n in address a
+?           a --            Print value of addr a
++!          n a --          Increase value of addr a by n
+CURRENT     -- n            Set n to wordref of last added entry.
+HERE        -- a            Push HERE's address
+
+*** Arithmetic ***
+
 +           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.
+
-CURRENT     -- n            Set n to wordref of last added entry.
+*** I/O ***
-DOES>       --              See description at top of file
+.           n --            Print n in its decimal form
-DUP         a -- a a
-ELSE        --              Branch to THEN
 EMIT        c --            Spit char c to stdout
-EXECUTE     a --            Execute wordref at addr a
-HERE        -- a            Push HERE's address
-IF          n --            Branch to ELSE or THEN if n is zero
-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
-THEN        --              Does nothing. Serves as a branching merker for IF
-                            and ELSE.
 
-*** 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/util.asm

@@ -274,3 +274,20 @@ entryhead:
 	ld	(HERE), hl
 	xor	a		; set Z
 	ret
+
+; Sets Z if wordref at (HL) is of the IMMEDIATE type
+HLPointsIMMED:
+	push	hl
+	call	intoHL
+	dec	hl
+	dec	hl
+	dec	hl
+	; We need an invert flag. We want to Z to be set when flag is non-zero.
+	ld	a, 1
+	and	(hl)
+	dec	a	; if A was 1, Z is set. Otherwise, Z is unset
+	inc	hl
+	inc	hl
+	inc	hl
+	pop	hl
+	ret

emul/.gitignore

@@ -1,5 +1,5 @@
 /shell/shell
-/bshell/shell
+/forth/forth
 /zasm/zasm
 /zasm/avra
 /runbin/runbin
@@ -7,6 +7,4 @@
 /*/*.bin
 /cfsin/zasm
 /cfsin/ed
-/cfsin/basic
-/cfsin/forth
 /cfsin/user.h

emul/Makefile

@@ -1,10 +1,10 @@
 CFSPACK_OBJ = ../tools/cfspack/libcfs.o
-TARGETS = shell/shell zasm/zasm runbin/runbin
+TARGETS = shell/shell zasm/zasm runbin/runbin forth/forth
 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
@@ -24,6 +24,15 @@ shell/shell-bin.h: shell/shell.bin
 shell/shell: shell/shell.c $(SHELLOBJS) shell/shell-bin.h 
 	$(CC) shell/shell.c $(SHELLOBJS) -o $@
 
+forth/forth.bin: forth/glue.asm $(ZASMBIN)
+	$(ZASMBIN) $(KERNEL) $(APPS) < forth/glue.asm | tee $@ > /dev/null
+
+forth/forth-bin.h: forth/forth.bin
+	./bin2c.sh KERNEL < forth/forth.bin | tee $@ > /dev/null
+
+forth/forth: forth/forth.c $(OBJS) forth/forth-bin.h 
+	$(CC) forth/forth.c $(OBJS) -o $@
+
 zasm/kernel-bin.h: zasm/kernel.bin
 	./bin2c.sh KERNEL < zasm/kernel.bin | tee $@ > /dev/null
 

emul/forth/forth.c

@@ -0,0 +1,68 @@
+#include <stdint.h>
+#include <stdio.h>
+#include <unistd.h>
+#include <termios.h>
+#include "../emul.h"
+#include "forth-bin.h"
+
+// in sync with glue.asm
+#define RAMSTART 0x2000
+#define STDIO_PORT 0x00
+
+static int running;
+
+static uint8_t iord_stdio()
+{
+    int c = getchar();
+    if (c == EOF) {
+        running = 0;
+    }
+    return (uint8_t)c;
+}
+
+static void iowr_stdio(uint8_t val)
+{
+    if (val == 0x04) { // CTRL+D
+        running = 0;
+    } else {
+        putchar(val);
+    }
+}
+
+int main(int argc, char *argv[])
+{
+    bool tty = isatty(fileno(stdin));
+    struct termios termInfo;
+    if (tty) {
+        // Turn echo off: the shell takes care of its own echoing.
+        if (tcgetattr(0, &termInfo) == -1) {
+            printf("Can't setup terminal.\n");
+            return 1;
+        }
+        termInfo.c_lflag &= ~ECHO;
+        termInfo.c_lflag &= ~ICANON;
+        tcsetattr(0, TCSAFLUSH, &termInfo);
+    }
+
+    Machine *m = emul_init();
+    m->ramstart = RAMSTART;
+    m->iord[STDIO_PORT] = iord_stdio;
+    m->iowr[STDIO_PORT] = iowr_stdio;
+    // initialize memory
+    for (int i=0; i<sizeof(KERNEL); i++) {
+        m->mem[i] = KERNEL[i];
+    }
+    // Run!
+    running = 1;
+
+    while (running && emul_step());
+
+    if (tty) {
+        printf("Done!\n");
+        termInfo.c_lflag |= ECHO;
+        termInfo.c_lflag |= ICANON;
+        tcsetattr(0, TCSAFLUSH, &termInfo);
+        emul_printdebug();
+    }
+    return 0;
+}

emul/forth/glue.asm

@@ -0,0 +1,40 @@
+.inc "ascii.h"
+.equ	RAMSTART	0x2000
+.equ	STDIO_PORT	0x00
+
+	jp	init
+
+.inc "core.asm"
+.inc "str.asm"
+
+.equ	STDIO_RAMSTART	RAMSTART
+.equ	STDIO_GETC	emulGetC
+.equ	STDIO_PUTC	emulPutC
+.inc "stdio.asm"
+
+.inc "lib/util.asm"
+.inc "lib/parse.asm"
+.inc "lib/ari.asm"
+.inc "lib/fmt.asm"
+.equ FORTH_RAMSTART STDIO_RAMEND
+.inc "forth/main.asm"
+.inc "forth/util.asm"
+.inc "forth/stack.asm"
+.inc "forth/dict.asm"
+
+init:
+	di
+	; setup stack
+	ld	sp, 0xffff
+	call	forthMain
+	halt
+
+emulGetC:
+	; Blocks until a char is returned
+	in	a, (STDIO_PORT)
+	cp	a		; ensure Z
+	ret
+
+emulPutC:
+	out	(STDIO_PORT), a
+	ret