commit d6d3dc1f15c9f52c01fe19d37e61138512032ce2
parent a3e95d2d208c8ed76c9774dcfbeb2a5d4e4fa168
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Wed, 1 Jun 2022 13:51:41 -0400
Seriously, I'm really getting there...
Diffstat:
| M | Makefile | | | 4 | ++-- |
| D | asm.py | | | 244 | ------------------------------------------------------------------------------- |
| M | boot2.fs | | | 2 | +- |
| M | dusk.asm | | | 9 | ++++++--- |
| D | dusk.c | | | 205 | ------------------------------------------------------------------------------- |
| D | ops.txt | | | 6 | ------ |
| M | xcomp.txt | | | 90 | ++++++++++++++------------------------------------------------------------------ |
| D | xcomp2.txt | | | 90 | ------------------------------------------------------------------------------- |
8 files changed, 24 insertions(+), 626 deletions(-)
diff --git a/Makefile b/Makefile
@@ -1,10 +1,10 @@
TARGETS = dusk
all: $(TARGETS)
-xcomp.asm: dusk.asm xcomp2.txt f2asm.py aliases.txt
+xcomp.asm: dusk.asm xcomp.txt f2asm.py aliases.txt
echo "; This file is autogenerated" > $@
cat dusk.asm >> $@
- ./f2asm.py xcomp2.txt >> $@
+ ./f2asm.py xcomp.txt >> $@
dusk: xcomp.asm boot2.fs
nasm -f elf32 xcomp.asm -o dusk.o
diff --git a/asm.py b/asm.py
@@ -1,244 +0,0 @@
-#!/usr/bin/env python3
-# ad hoc assembler for forth.bin
-# temporary crutch until we're self-hosting.
-import sys
-import struct
-
-ops = open('ops.txt', 'rb').read().split(b',')
-ops = [s.strip() for s in ops]
-ops = {name:i for i, name in enumerate(ops)}
-fp = open(sys.argv[1], 'rb')
-outbuf = bytearray()
-prevword = 0
-words = {} # name:pc
-labels = {} # name:pc
-fwlabels = [] # (name, pc) label forward references
-ps = [] # PS for immediate words
-
-aliases = [
- ('p2r', '>r'),
- ('r2p', 'r>'),
- ('rget', 'r@'),
- ('rdrop', 'r~'),
- ('a2r', 'A>r'),
- ('r2a', 'r>A'),
-]
-for a, b in aliases:
- opcode = ops[a.encode()]
- del ops[a.encode()]
- ops[b.encode()] = opcode
-
-def out(fmt, *args):
- outbuf.extend(struct.pack(fmt, *args))
-
-def opwr(name):
- if isinstance(name, str):
- name = name.encode()
- out('<b', ops[name])
-
-def intwr(n):
- out('<i', n)
-
-def intset(offset, n):
- outbuf[offset:offset+4] = struct.pack('<i', n)
-
-def litwr(n):
- opwr('_i_')
- intwr(n)
-
-def callwr(addr):
- opwr('_call_')
- intwr(addr)
-
-def pc():
- return len(outbuf)
-
-def litparse(s):
- 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():
- r = bytearray()
- c = fp.read(1)
- while c and c[0] <= 0x20:
- c = fp.read(1)
- while c and c[0] > 0x20:
- r.append(c[0])
- c = fp.read(1)
- return bytes(r)
-
-def labelwr(t):
- if t.endswith(b':'):
- t = t[:-1]
- for name, off in fwlabels:
- if name == t:
- intset(off, pc())
- labels[t] = pc()
- else:
- if t in labels:
- intwr(labels[t])
- else:
- fwlabels.append((t, pc()))
- intwr(0)
-
-def newword(name=None):
- global prevword
- if not name:
- name = nextt()
- count = len(name)
- out(f'<{count}sib', name, prevword, count)
- prevword = pc()
- words[name] = prevword
-
-def _comment_():
- c = fp.read(1)
- 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())
- intwr(0)
-
-def _then_():
- intset(ps.pop(), pc())
-
-def _else_():
- x = ps.pop()
- opwr('_br_')
- ps.append(pc())
- intwr(0)
- intset(x, pc())
-
-def _begin_():
- ps.append(pc())
-
-def _again_():
- opwr('_br_')
- intwr(ps.pop())
-
-def _until_():
- opwr('_cbr_')
- intwr(ps.pop())
-
-def _next_():
- opwr('_next_')
- intwr(ps.pop())
-
-def exitwr():
- opwr('exit')
-
-def strwr():
- s = bytearray()
- c = fp.read(1)
- while c and c != b'"':
- s.append(c[0])
- c = fp.read(1)
- outbuf.extend(s)
- return s
-
-def slitwr():
- opwr('_br_')
- ps.append(pc())
- intwr(0)
- spc = pc()
- s = strwr()
- _then_()
- litwr(spc)
- litwr(len(s))
-
-def _create_():
- newword()
- callwr(labels[b'lblcell'])
-
-def _value_():
- newword()
- callwr(labels[b'lblval'])
- n = litparse(nextt())
- intwr(n)
-
-def _alias_():
- newword()
- callwr(labels[b'lblalias'])
- off = words[nextt()]
- intwr(off)
-
-def _immediate_():
- outbuf[prevword-1] |= 0x80 # immediate
-
-def _opwriter_():
- newword()
- _immediate_()
- opcode = ops[nextt()]
- litwr(opcode)
- callwr(words[b'c,'])
- exitwr()
-
-def _callop_():
- intwr(ops[b'_call_'])
-
-def _pspushop_():
- intwr(ops[b'_i_'])
-
-def _exitop_():
- intwr(ops[b'exit'])
-
-special = {
- b':': newword,
- b'(': _comment_,
- b'\\': _lcomment_,
- b';': exitwr,
- b',"': strwr,
- b'S"': slitwr,
- b'if': _if_,
- b'then': _then_,
- b'else': _else_,
- b'begin': _begin_,
- b'again': _again_,
- b'until': _until_,
- b'next': _next_,
- b'create': _create_,
- b'value': _value_,
- b'alias': _alias_,
- b'opwriter': _opwriter_,
- b'callop': _callop_,
- b'pspushop': _pspushop_,
- b'exitop': _exitop_,
- b'immediate': _immediate_,
-}
-
-t = nextt()
-while t:
- if t in special:
- special[t]()
- elif t in words:
- callwr(words[t])
- elif t in ops:
- opwr(t)
- elif t.startswith(b'lbl'):
- labelwr(t)
- else:
- n = litparse(t)
- if n is None:
- t = t.decode()
- print(f"invalid token {t}", file=sys.stderr)
- sys.exit(1)
- else:
- litwr(n)
- t = nextt()
-
-fp.close()
-sys.stdout.buffer.write(outbuf)
diff --git a/boot2.fs b/boot2.fs
@@ -1 +1 @@
-'X' emit bye
+: foo 'X' emit ; foo bye
diff --git a/dusk.asm b/dusk.asm
@@ -381,20 +381,23 @@ litncode:
litncode_end:
defword 'litn', 4, word_litn, word_shrc
pspush litncode ; src
- pspush litncode_end-litncode ; len
+ pspush litncode_end-litncode-4 ; len_of_code-len-of-imm
call word_movewrite
call word_write
ret
defword 'call,', 5, word_callwrite, word_litn
- pspop eax ; absolute addr
+ mov eax, [ebp] ; absolute addr
sub eax, [here] ; displacement
- add eax, 5 ; ... from *after* call op
+ sub eax, 5 ; ... from *after* call op
+ mov [ebp], eax
pspush 0xe8 ; call opcode
call word_cwrite
call word_write
+ ret
defword 'exit,', 5, word_exitwrite, word_callwrite
word_asmlast:
pspush 0xc3 ; ret opcode
call word_cwrite
+ ret
diff --git a/dusk.c b/dusk.c
@@ -1,205 +0,0 @@
-#include <unistd.h>
-#include <inttypes.h>
-#include <stdio.h>
-#include <termios.h>
-
-#define CELLSIZE 4
-#define MEMSIZE 0x10000
-#define STACKSIZE 0x100
-
-typedef uint32_t cell;
-typedef uint8_t byte;
-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 = stack_peek(s);
- s->ptr++;
- return n;
-}
-static void stack_push(struct stack *s, cell x) {
- s->ptr--;
- s->data[s->ptr&(STACKSIZE-1)] = x;
-}
-
-byte mem[MEMSIZE];
-struct stack ps, rs;
-cell pc;
-byte running;
-byte toflag;
-cell areg;
-
-/* 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 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; }
-
-/* Native words */
-/* stack */
-static void _i_() { push(pc32()); }
-static void _drop() { pop(); }
-static void _dup() { push(peek()); }
-static void cdup() { if (peek()) push(peek()); }
-static void _swap() { cell a = pop(); cell b = pop(); push(a); push(b); }
-static void _over() { cell a = pop(); cell b = peek(); push(a); push(b); }
-static void _rot() {
- cell c = pop(); cell b = pop(); cell a = pop();
- 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_() {
- cell n = popRS()-1;
- if (n) { pushRS(n); _br_(); }
- else { pc+=CELLSIZE; }
-}
-static void _call_() { pushRS(pc+CELLSIZE); _br_(); }
-static void exit() { pc = popRS(); }
-static void execute() { pushRS(pc); pc = pop(); }
-static void _bye() { running = 0; }
-
-/* memory */
-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; }
-static void isto() { push(toflag); toflag = 0; }
-
-/* arithmetic */
-static void inc() { push(pop()+1); }
-static void dec() { push(pop()-1); }
-static void shl() { cell n = pop(); push(n<<1); push(n>>31); }
-static void shr() { cell n = pop(); push(n>>1); push(n&1); }
-static void _and() { cell b = pop(); cell a = pop(); push(a&b); }
-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); }
-
-/* A register */
-static void a2p() { push(areg); }
-static void p2a() { areg = pop(); }
-static void a2r() { pushRS(areg); }
-static void r2a() { areg = popRS(); }
-static void ainc() { areg++; }
-static void adec() { areg--; }
-static void acfetch() { checka(&areg); push(mem[areg]); }
-static void acstore() { checka(&areg); mem[areg] = pop(); }
-
-/* I/O */
-static void _emit() { putchar(pop()); }
-static void _key() { push(getchar()); }
-
-static void (*ops[50])() = {
-#include "ops.txt"
-};
-
-static void opexec(byte op) {
- if (op < sizeof(ops)/sizeof(void*)) {
- ops[op]();
- } else {
- fprintf(stderr, "Out of bounds op %02x. PC: %08x\n", op, pc);
- running = 0;
- }
-}
-
-byte step() {
- if (!running) {
- 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");
- if (!fp) {
- fprintf(stderr, "Can't open forth bin\n");
- return 1;
- }
- int i = 0;
- int c = getc(fp);
- while (c != EOF) {
- mem[i++] = c;
- c = getc(fp);
- }
- fclose(fp);
- ps.ptr = rs.ptr = STACKSIZE;
- pc = toflag = 0;
- running = 1;
- if (isatty(STDIN_FILENO)) {
- tcgetattr(STDIN_FILENO, &tio);
- bkptio = tio;
- tio.c_lflag &=(~ICANON & ~ECHO); /* no echo, unbuffered */
- tcsetattr(STDIN_FILENO, TCSANOW, &tio);
- }
- while (step());
- if (isatty(STDIN_FILENO)) {
- tcsetattr(STDIN_FILENO, TCSANOW, &bkptio);
- }
- printdbg();
- memdump();
- return 0;
-}
diff --git a/ops.txt b/ops.txt
@@ -1,6 +0,0 @@
-_i_, _drop, _dup, cdup, _swap, _over, _rot, p2r, r2p, rget, rdrop, _scnt, _rcnt,
-_rs0, _ps0, _br_, _cbr_, _next_, _call_, exit, execute, _bye,
-cfetch, cstore, fetch, store, _to, isto,
-inc, dec, shl, shr, _and, _or, _xor, add, sub, mul, lt, _not,
-a2p, p2a, a2r, r2a, ainc, adec, acfetch, acstore,
-_emit, _key
diff --git a/xcomp.txt b/xcomp.txt
@@ -1,57 +1,10 @@
-_br_ lblmain
-\ native words
-: drop _drop ;
-: dup _dup ;
-: ?dup cdup ;
-: swap _swap ;
-: over _over ;
-: rot _rot ;
-: scnt _scnt ;
-: rcnt _rcnt ;
-: bye _bye ;
-: c@ cfetch ;
-: c! cstore ;
-: @ fetch ;
-: ! store ;
-: to _to ;
-: to? isto ;
-: 1+ inc ;
-: 1- dec ;
-: <<c shl ;
-: >>c shr ;
-: and _and ;
-: or _or ;
-: xor _xor ;
-: + add ;
-: - sub ;
-: * mul ;
-: < lt ;
-: not _not ;
-: A> a2p ;
-: >A p2a ;
-: A+ ainc ;
-: A- adec ;
-: Ac@ acfetch ;
-: Ac! acstore ;
-: emit _emit ;
-: key _key ;
+sysval current
+sysval here
+sysval compiling
+const SPC $20 const CR $0d const LF $0a const BS $08
+sysval in>
+syscell 'curword curword
-\ core labels
-lblcell: r> ;
-lblval: r> to? if ! else @ then ;
-lblalias: r> to? if ! else @ >r then ;
-
-\ variables
-: current _call_ lblval lblcurrent
-: here _call_ lblval lblhere
-value compiling 0
-value SPC $20 value CR $0d value LF $0a value BS $08
-value in> 6144 \ where boot.fs starts
-create 'curword ," xxxxxx"
-
-\ words
-: quit _rs0 _br_ lblmain
-: abort _ps0 quit
: 2drop drop drop ;
: 2dup over over ;
: nip swap drop ;
@@ -109,43 +62,30 @@ create tbl-0-f ," 0123456789abcdef"
?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 ;
+: wordlen ( w -- len ) 1- c@ $7f and ;
+: wordname ( w -- sa sl ) dup wordlen swap 5 - over - swap ;
+: prevword ( w -- w ) dup if 5 - @ then ;
+: immediate? ( w -- f ) 1- c@ $80 and ;
: 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 )
+ dup wordlen r@ = if ( w )
+ A> over wordname ( 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 ) ;
+ prevword ?dup not until r~ 0 r>A ( not found ) ;
: (wnf) curword stype S" word not found" stype abort ;
: ' word find not if (wnf) then ;
-: litn ( n -- ) _i_ pspushop c, , ;
-: call, ( n -- ) _i_ callop c, , ;
: entry word tuck move, ( len )
current , c, here to current ;
: xtcomp 1 to compiling begin
word parse if litn else curword find if
- dup 1- c@ $80 and ( imm? ) if execute else call, then
+ dup immediate? if execute else call, then
else (wnf) then then
compiling not until
exit, ;
:imm ; 0 to compiling ;
: : entry xtcomp ;
-: create entry _i_ lblcell call, ;
-: value entry _i_ lblval call, , ;
: stack? scnt 0< if S" stack underflow" stype abort then ;
: run1 ( -- ) \ interpret next word
word parse not if
curword find not if (wnf) then execute stack? then ;
-opwriter r> r>
-opwriter >r >r
-opwriter r@ r@
-opwriter r~ r~
-opwriter A>r A>r
-opwriter r>A r>A
-opwriter exit exit
-opwriter execute execute
-opwriter (br) _br_
-opwriter (?br) _cbr_
-opwriter (next) _next_
-lblmain: 0 'curword 5 + c! begin run1 again
-: _ lblcurrent: ;
-lblhere:
+: mainloop 0 'curword 5 + c! begin run1 again ;
diff --git a/xcomp2.txt b/xcomp2.txt
@@ -1,90 +0,0 @@
-sysval current
-sysval here
-sysval compiling
-const SPC $20 const CR $0d const LF $0a const BS $08
-sysval in>
-syscell 'curword curword
-
-: 2drop drop drop ;
-: 2dup over over ;
-: nip swap drop ;
-: tuck swap over ;
-: rot> rot rot ;
-: leave r> r~ 1 >r >r ;
-: Ac@+ Ac@ A+ ;
-: Ac!+ Ac! A+ ;
-: c@+ dup 1+ swap c@ ;
-: c!+ tuck c! 1+ ;
-: allot here + to here ;
-: , here ! 4 allot ;
-: c, here c! 1 allot ;
-: = - not ;
-: > swap < ;
-: 0< <<c nip ; : 0>= 0< not ; : >= < not ; : <= > not ;
-: -^ swap - ;
-: << <<c drop ;
-: >> >>c drop ;
-: move ( src dst u -- ) ?dup if
- >r >A begin ( src ) c@+ Ac!+ next drop then ;
-: move, ( a u -- ) here over allot swap move ;
-: stype >r begin c@+ emit next drop ;
-: ws? SPC <= ;
-: boot< in> c@+ swap to in> ;
-alias in<? boot<
-alias in< boot<
-: toword ( -- ) begin in< ws? not until ;
-: curword ( -- sa sl ) 'curword 1+ @ 'curword c@ ;
-: _ ( f sa sl -- ) 'curword c!+ tuck ! 4 + c! ;
-: word ( -- sa sl )
- 'curword 5 + c@ if curword else
- toword in> 1- 0 ( sa sl ) begin 1+ in<? ws? until then
- ( sa sl ) 2dup 0 rot> _ ;
-: word! 1 rot> _ ;
-: [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 ;
-create tbl-0-f ," 0123456789abcdef"
-: 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 tbl-0-f $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 ;
-: wordlen ( w -- len ) 1- c@ $7f and ;
-: wordname ( w -- sa sl ) dup wordlen swap 5 - over - swap ;
-: prevword ( w -- w ) dup if 5 - @ then ;
-: find ( sa sl -- w? f ) \ Guards A
- A>r >r >A current begin ( w R:sl )
- dup wordlen r@ = if ( w )
- A> over wordname ( w a1 a2 u )
- []= if ( w ) r~ 1 r>A exit then then
- prevword ?dup not until r~ 0 r>A ( not found ) ;
-: (wnf) curword stype S" word not found" stype abort ;
-: ' word find not if (wnf) then ;
-: entry word tuck move, ( len )
- current , c, here to current ;
-: xtcomp 1 to compiling begin
- word parse if litn else curword find if
- dup 1- c@ $80 and ( imm? ) if execute else call, then
- else (wnf) then then
- compiling not until
- exit, ;
-:imm ; 0 to compiling ;
-: : entry xtcomp ;
-: stack? scnt 0< if S" stack underflow" stype abort then ;
-: run1 ( -- ) \ interpret next word
- word parse not if
- curword find not if (wnf) then execute stack? then ;
-: mainloop 0 'curword 5 + c! begin run1 again ;
