commit a0a6d826465bca24969ef4c96c14cddaebd2682e
parent 55ebc81881d8c59734bc00412cbbafade5ec6436
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Wed, 1 Jun 2022 13:51:40 -0400
Add interpret loop
Diffstat:
| M | asm.py | | | 44 | ++++++++++++++++++++++++++++++++++---------- |
| M | dusk.c | | | 63 | +++++++++++++++++++++++++++++++++++++++++++++++++++++---------- |
| M | forth.txt | | | 62 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++------ |
| M | ops.txt | | | 6 | +++--- |
4 files changed, 146 insertions(+), 29 deletions(-)
diff --git a/asm.py b/asm.py
@@ -20,7 +20,9 @@ aliases = [
('cdup', '?dup'),
('p2r', '>r'),
('r2p', 'r>'),
- ('exit', ';'),
+ ('rget', 'r@'),
+ ('rdrop', 'r~'),
+ ('ret', ';'),
('cfetch', 'c@'),
('cstore', 'c!'),
('fetch', '@'),
@@ -32,10 +34,13 @@ aliases = [
('shr', '>>c'),
('add', '+'),
('sub', '-'),
+ ('mul', '*'),
('lt', '<'),
]
for a, b in aliases:
- ops[b.encode()] = ops[a.encode()]
+ opcode = ops[a.encode()]
+ del ops[a.encode()]
+ ops[b.encode()] = opcode
def out(fmt, *args):
outbuf.extend(struct.pack(fmt, *args))
@@ -59,12 +64,15 @@ def pc():
return len(outbuf)
def litparse(s):
- if len(s) == 3 and s[0] == ord("'") and s[2] == ord("'"):
- return s[1]
- elif s.isdigit():
- return int(s)
- elif s.startswith(b'$'):
- return int(s[1:], 16)
+ try:
+ if len(s) == 3 and s[0] == ord("'") and s[2] == ord("'"):
+ return s[1]
+ elif s.startswith(b'$'):
+ return int(s[1:], 16)
+ else:
+ return int(s)
+ except ValueError:
+ pass
return None
def nextt():
@@ -91,9 +99,10 @@ def labelwr(t):
fwlabels.append((t, pc()))
intwr(0)
-def newword():
+def newword(name=None):
global prevword
- name = nextt()
+ if not name:
+ name = nextt()
count = len(name)
out(f'<{count}sib', name, prevword, count)
prevword = pc()
@@ -104,6 +113,11 @@ def _comment_():
while c and c != b')':
c = fp.read(1)
+def _lcomment_():
+ c = fp.read(1)
+ while c and c != b'\n':
+ c = fp.read(1)
+
def _if_():
opwr('_cbr_')
ps.append(pc())
@@ -165,9 +179,18 @@ def _value_():
n = litparse(nextt())
intwr(n)
+def spitnativewords():
+ for name in ops:
+ if name.startswith(b'_') or name == b';':
+ continue
+ newword(name)
+ opwr(name)
+ opwr(';')
+
special = {
b':': newword,
b'(': _comment_,
+ b'\\': _lcomment_,
b',"': strwr,
b'S"': slitwr,
b'if': _if_,
@@ -179,6 +202,7 @@ special = {
b'next': _next_,
b'create': _create_,
b'value': _value_,
+ b'spitnativewords': spitnativewords,
}
t = nextt()
diff --git a/dusk.c b/dusk.c
@@ -13,15 +13,17 @@ struct stack {
cell data[STACKSIZE];
cell ptr;
};
+static cell stack_peek(struct stack *s) {
+ return s->data[s->ptr&(STACKSIZE-1)];
+}
static cell stack_pop(struct stack *s) {
- cell n = s->data[s->ptr];
+ cell n = stack_peek(s);
s->ptr++;
- if (s->ptr == STACKSIZE) s->ptr = 0;
return n;
}
static void stack_push(struct stack *s, cell x) {
- if (s->ptr) s->ptr--; else s->ptr = STACKSIZE-1;
- s->data[s->ptr] = x;
+ s->ptr--;
+ s->data[s->ptr&(STACKSIZE-1)] = x;
}
byte mem[MEMSIZE];
@@ -31,18 +33,28 @@ byte running;
byte toflag;
/* Utilities */
+static void checka(cell *addr) {
+ if (*addr >= MEMSIZE) {
+ fprintf(stderr, "Illegal mem addr %08x at PC %08x. Halting.\n", addr, pc);
+ running = 0;
+ *addr = 0;
+ }
+}
static cell gc(cell addr) {
+ checka(&addr);
return mem[addr+3] << 24 | mem[addr+2] << 16 | mem[addr+1] << 8 | mem[addr];
}
static void sc(cell addr, cell val) {
+ checka(&addr);
mem[addr] = val;
mem[addr+1] = val >> 8;
mem[addr+2] = val >> 16;
mem[addr+3] = val >> 24;
}
-static cell peek() { return ps.data[ps.ptr]; }
+static cell peek() { return stack_peek(&ps); }
static cell pop() { return stack_pop(&ps); }
static void push(cell x) { stack_push(&ps, x); }
+static cell peekRS() { return stack_peek(&rs); }
static cell popRS() { return stack_pop(&rs); }
static void pushRS(cell x) { stack_push(&rs, x); }
static cell pc32() { cell n = gc(pc); pc+=CELLSIZE; return n; }
@@ -60,8 +72,14 @@ static void rot() {
push(b); push(c); push(a); }
static void p2r() { pushRS(pop()); }
static void r2p() { push(popRS()); }
+static void rget() { push(peekRS()); }
+static void rdrop() { popRS(); }
+static void scnt() { push(STACKSIZE-ps.ptr); }
+static void rcnt() { push(STACKSIZE-rs.ptr); }
/* flow */
+static void _rs0() { rs.ptr = STACKSIZE; }
+static void _ps0() { ps.ptr = STACKSIZE; }
static void _br_() { pc = gc(pc); }
static void _cbr_() { if (pop()) { pc+=CELLSIZE; } else { _br_(); } }
static void _next_() {
@@ -70,12 +88,13 @@ static void _next_() {
else { pc+=CELLSIZE; }
}
static void _call_() { pushRS(pc+CELLSIZE); _br_(); }
-static void exit() { pc = popRS(); }
+static void ret() { pc = popRS(); }
+static void execute() { pc = pop(); }
static void bye() { running = 0; }
/* memory */
-static void cfetch() { cell a = pop(); push(mem[a]); }
-static void cstore() { cell a = pop(); mem[a] = pop(); }
+static void cfetch() { cell a = pop(); checka(&a); push(mem[a]); }
+static void cstore() { cell a = pop(); checka(&a); mem[a] = pop(); }
static void fetch() { cell a = pop(); push(gc(a)); }
static void store() { cell a = pop(); sc(a, pop()); }
static void to() { toflag = 1; }
@@ -91,6 +110,7 @@ static void or() { cell b = pop(); cell a = pop(); push(a|b); }
static void xor() { cell b = pop(); cell a = pop(); push(a^b); }
static void add() { cell b = pop(); cell a = pop(); push(a+b); }
static void sub() { cell b = pop(); cell a = pop(); push(a-b); }
+static void mul() { cell b = pop(); cell a = pop(); push(a*b); }
static void lt() { cell b = pop(); cell a = pop(); push(a<b); }
static void not() { push(pop() ? 0 : 1); }
@@ -98,7 +118,7 @@ static void not() { push(pop() ? 0 : 1); }
static void emit() { putchar(pop()); }
static void key() { push(getchar()); }
-static void (*ops[34])() = {
+static void (*ops[42])() = {
#include "ops.txt"
};
@@ -116,10 +136,31 @@ byte step() {
fprintf(stderr, "machine halted!\n");
return 0;
}
+ checka(&pc);
opexec(mem[pc++]);
return running;
}
+static void memdump() {
+ fprintf(stderr, "Dumping memory to memdump. PC %08x\n", pc);
+ FILE *fp = fopen("memdump", "w");
+ fwrite(mem, MEMSIZE, 1, fp);
+ fclose(fp);
+}
+
+static void printstack(struct stack *s) {
+ for (cell i=s->ptr; i<STACKSIZE; i++) {
+ fprintf(stderr, "%08x ", s->data[i]);
+ }
+ putc('\n', stderr);
+}
+static void printdbg() {
+ fprintf(stderr, "PC %08x PS %04x:\n", pc, STACKSIZE-ps.ptr);
+ printstack(&ps);
+ fprintf(stderr, "RS %04x:\n", STACKSIZE-rs.ptr);
+ printstack(&rs);
+}
+
int main() {
struct termios bkptio, tio;
FILE *fp = fopen("forth.bin", "r");
@@ -134,7 +175,8 @@ int main() {
c = getc(fp);
}
fclose(fp);
- ps.ptr = rs.ptr = pc = toflag = 0;
+ ps.ptr = rs.ptr = STACKSIZE;
+ pc = toflag = 0;
running = 1;
if (isatty(STDIN_FILENO)) {
tcgetattr(STDIN_FILENO, &tio);
@@ -146,5 +188,6 @@ int main() {
if (isatty(STDIN_FILENO)) {
tcsetattr(STDIN_FILENO, TCSANOW, &bkptio);
}
+ printdbg();
return 0;
}
diff --git a/forth.txt b/forth.txt
@@ -1,6 +1,8 @@
_br_ lblboot
lblcell: r> ;
lblval: r> to? if ! else @ then ;
+spitnativewords
+: current _call_ lblval lblcurrent
create A ," xxxx"
value SPC $20 value CR $0d value LF $0a value BS $08
create in(
@@ -8,11 +10,15 @@ create in(
value LNSZ 64
value in> 0
create 'curword ," xxxxxx"
+: quit _rs0 _br_ lblmain
+: abort _ps0 quit
+: exit r~ ;
: 2drop drop drop ;
: 2dup over over ;
: nip swap drop ;
: tuck swap over ;
: rot> rot rot ;
+: leave r> r~ 1 >r >r ;
: A> A @ ; : >A A ! ;
: A>r r> A> >r >r ; : r>A r> r> >A >r ;
: A+ A> 1+ >A ; : A- A> 1- >A ;
@@ -23,20 +29,25 @@ create 'curword ," xxxxxx"
: = - not ;
: > swap < ;
: 0< <<c nip ; : 0>= 0< not ; : >= < not ; : <= > not ;
+: <> ( n n -- l h ) 2dup > if swap then ;
+: min <> drop ; : max <> nip ; : -^ swap - ;
: << <<c drop ;
: >> >>c drop ;
: fill ( a u b -- *A* ) rot> >r >A begin dup Ac!+ next drop ;
lblhex: ," 0123456789abcdef"
: .h $f and _i_ lblhex + c@ emit ;
: .x dup >> >> >> >> .h .h ;
-: nl> CR emit LF emit ;
-: stype >r begin c@+ emit next ;
+: nl> CR emit LF emit ; : spc> SPC emit ;
+: stype >r begin c@+ emit next drop ;
: in) in( 64 + ;
: bs? BS over = swap $7f = or ;
: ws? SPC <= ;
: lntype ( ptr c -- ptr+1 f )
- dup SPC < if drop dup in) over - 0 fill 1 else
- tuck emit c!+ dup in) = then ;
+ dup bs? if ( ptr c )
+ drop dup in( > if 1- BS emit then spc> BS emit 0
+ else ( ptr c ) \ non-BS
+ dup SPC < if drop dup in) over - 0 fill 1 else
+ tuck emit c!+ dup in) = then then ;
: rdln S" ok" stype nl> in( begin key lntype until drop nl> ;
: in<? ( -- c-or-0 )
in> in) < if in> c@+ swap to in> else 0 then ;
@@ -51,5 +62,44 @@ lblhex: ," 0123456789abcdef"
toword in> 1- 0 ( sa sl ) begin 1+ in<? ws? until then
( sa sl ) 2dup 0 rot> _ ;
: word! 1 rot> _ ;
-: prompt S" Dusk OS" stype ;
-: BOOT lblboot: in$ prompt word stype bye
+: [c]? ( c a u -- i ) \ Guards A
+ ?dup not if 2drop -1 exit then A>r over >r >r >A ( c )
+ begin dup Ac@+ = if leave then next ( c )
+ A- Ac@ = if A> r> - ( i ) else r~ -1 then r>A ;
+: _ ( sl -- n? f ) \ parse unsigned decimal
+ >r 0 begin ( r )
+ 10 * Ac@+ ( r c ) '0' - dup 9 > if
+ 2drop r~ 0 exit then + next ( r ) 1 ;
+: parse ( sa sl -- n? f ) \ *A*
+ over c@ ''' = if ( sa sl )
+ 3 = if 1+ dup 1+ c@ ''' = if c@ 1 exit then then
+ drop 0 exit then ( sa sl )
+ over c@ '$' = if ( sa sl ) 1- >r 1+ >A 0 begin ( r )
+ 16 * Ac@+ ( r c ) $20 or _i_ lblhex $10 [c]?
+ dup 0< if 2drop r~ 0 exit then + next ( r ) 1 exit then
+ swap >A dup 1 > Ac@ '-' = and if ( sl )
+ A+ 1- _ if 0 -^ 1 else 0 then else _ then ;
+: []= ( a1 a2 u -- f ) \ Guards A
+ ?dup not if 2drop 1 exit then A>r >r >A ( a1 )
+ begin Ac@+ over c@ = not if r~ r>A drop 0 exit then 1+ next
+ drop r>A 1 ;
+: find ( sa sl -- w? f ) \ Guards A
+ A>r >r >A current begin ( w R:sl )
+ dup 1- c@ $7f and ( wlen ) r@ = if ( w )
+ dup r@ - 5 - A> r@ ( w a1 a2 u )
+ []= if ( w ) r~ 1 r>A exit then then
+ 5 - ( prev field ) @ ?dup not until r~ 0 r>A ( not found ) ;
+: (wnf) curword stype S" word not found" stype abort ;
+: stack? scnt 0< if S" stack underflow" stype abort then ;
+: psdump scnt not if exit then
+ scnt >A begin dup .x spc> >r scnt not until
+ begin r> scnt A> = until ;
+: .S ( -- )
+ S" SP " stype scnt .x spc> S" RS " stype rcnt .x spc>
+ S" -- " stype stack? psdump ;
+: run1 ( -- ) \ interpret next word
+ word parse not if
+ curword find not if (wnf) then execute stack? then ;
+: interpret begin run1 again ;
+lblmain: in$ interpret bye
+: boot lblboot: lblcurrent: S" Dusk OS" stype abort
diff --git a/ops.txt b/ops.txt
@@ -1,5 +1,5 @@
-_i_, drop, _dup, cdup, swap, over, rot, p2r, r2p,
-_br_, _cbr_, _next_, _call_, exit, bye,
+_i_, drop, _dup, cdup, swap, over, rot, p2r, r2p, rget, rdrop, scnt, rcnt,
+_rs0, _ps0, _br_, _cbr_, _next_, _call_, ret, execute, bye,
cfetch, cstore, fetch, store, to, isto,
-inc, dec, shl, shr, and, or, xor, add, sub, lt, not,
+inc, dec, shl, shr, and, or, xor, add, sub, mul, lt, not,
emit, key
