1
0
mirror of https://github.com/hsoft/collapseos.git synced 2024-11-26 10:38:07 +11:00

Compare commits

...

2 Commits

Author SHA1 Message Date
Virgil Dupras
e95614755b emul: add forth target 2020-03-09 22:26:02 -04:00
Virgil Dupras
0b3f6253e4 forth: add support for IMMEDIATE words 2020-03-09 22:13:11 -04:00
7 changed files with 265 additions and 49 deletions

View File

@ -243,34 +243,75 @@ DEFINE:
; been compiled by INTERPRET*. All those bytes will be copied as-is. ; 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 ; All we need to do is to know how many bytes to copy. To do so, we
; skip compwords until EXIT is reached. ; skip compwords until EXIT is reached.
ld (HERE), hl ; where we write compwords. ex de, hl ; DE is our dest
ld l, (ix) ld l, (ix)
ld h, (ix+1) ld h, (ix+1)
.loop: .loop:
call HLPointsEXIT call HLPointsNUMBER
jr z, .loopend jr nz, .notNUMBER
call compSkip ; is number
ld bc, 4
ldir
jr .loop 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 ; HL has our new RS' TOS
ld (ix), l ld (ix), l
ld (ix+1), h ld (ix+1), h
ld (HERE), de ; update HERE ld (HERE), de ; update HERE
jp exit 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>" .db "DOES>"
.fill 3 .fill 3
.dw DEFINE .dw DEFINE
@ -293,10 +334,43 @@ DOES:
ld (HERE), iy ld (HERE), iy
jp exit 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 ) ; ( -- c )
.db "KEY" .db "KEY"
.fill 5 .fill 5
.dw DOES .dw LITERAL
KEY: KEY:
.dw nativeWord .dw nativeWord
call stdioGetC call stdioGetC

View File

@ -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 call "atoms". Those atoms are most of the time word references, but they can
also be references to NUMBER and LIT. also be references to NUMBER and LIT.
*** Native Words *** *** Defining words ***
: x ... -- Define a new word : x ... -- Define a new word
; R:I -- Exit a colon definition ; 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 @ a -- n Set n to value at address a
! n a -- Store n in 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
* 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 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 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.

View File

@ -274,3 +274,20 @@ entryhead:
ld (HERE), hl ld (HERE), hl
xor a ; set Z xor a ; set Z
ret 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

4
emul/.gitignore vendored
View File

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

View File

@ -1,10 +1,10 @@
CFSPACK_OBJ = ../tools/cfspack/libcfs.o CFSPACK_OBJ = ../tools/cfspack/libcfs.o
TARGETS = shell/shell zasm/zasm runbin/runbin TARGETS = shell/shell zasm/zasm runbin/runbin forth/forth
KERNEL = ../kernel KERNEL = ../kernel
APPS = ../apps APPS = ../apps
ZASMBIN = zasm/zasm ZASMBIN = zasm/zasm
AVRABIN = zasm/avra AVRABIN = zasm/avra
SHELLAPPS = zasm ed forth SHELLAPPS = zasm ed
SHELLTGTS = ${SHELLAPPS:%=cfsin/%} SHELLTGTS = ${SHELLAPPS:%=cfsin/%}
CFSIN_CONTENTS = $(SHELLTGTS) cfsin/user.h CFSIN_CONTENTS = $(SHELLTGTS) cfsin/user.h
OBJS = emul.o libz80/libz80.o 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 shell/shell: shell/shell.c $(SHELLOBJS) shell/shell-bin.h
$(CC) shell/shell.c $(SHELLOBJS) -o $@ $(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 zasm/kernel-bin.h: zasm/kernel.bin
./bin2c.sh KERNEL < zasm/kernel.bin | tee $@ > /dev/null ./bin2c.sh KERNEL < zasm/kernel.bin | tee $@ > /dev/null

68
emul/forth/forth.c Normal file
View File

@ -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;
}

40
emul/forth/glue.asm Normal file
View File

@ -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