t3x/t3x9r3-extended/t-vm.t

1652 lines
28 KiB
Raku

! T3X9r3 -> Tcode9 compiler
! Nils M Holm, 2017,2020 CC0 license
! https://creativecommons.org/publicdomain/zero/1.0/
const BPW = 4;
const PROG_SIZE = 65536;
const TEXT_SIZE = 65536;
const DATA_SIZE = 65536;
const NRELOC = 10000;
const STACK_SIZE = 100;
const SYMTBL_SIZE = 1000;
const NLIST_SIZE = 10000;
var Stack[STACK_SIZE], Sp;
var Line;
const ENDFILE = %1;
var ntoa_buf::100;
ntoa(x) do var i, k;
if (x = 0) return "0";
i := 0;
k := x<0-> -x: x;
while (k > 0) do
i := i+1;
k := k/10;
end
i := i+1;
if (x < 0) i := i+1;
ntoa_buf::i := 0;
k := x<0-> -x: x;
while (k > 0) do
i := i-1;
ntoa_buf::i := '0' + k mod 10;
k := k/10;
end
if (x < 0) do
i := i-1;
ntoa_buf::i := '-';
end
return @ntoa_buf::i;
end
str_length(s) return t.memscan(s, 0, 32767);
str_copy(sd, ss) t.memcopy(sd, ss, str_length(ss)+1);
str_append(sd, ss) t.memcopy(@sd::str_length(sd), ss, str_length(ss)+1);
str_equal(s1, s2) return t.memcomp(s1, s2, str_length(s1)+1) = 0;
writes(s) t.write(1, s, str_length(s));
log(s) t.write(2, s, str_length(s));
aw(m, s) do
log("t3x9: ");
log(ntoa(Line));
log(": ");
log(m);
if (s \= 0) do
log(": ");
log(s);
end
log("\n");
halt 1;
end
oops(m, s) do
log("t3x9: internal error\n");
aw(m, s);
end
push(x) do
if (Sp >= STACK_SIZE) oops("stack overflow", 0);
Stack[Sp] := x;
Sp := Sp+1;
end
tos() return Stack[Sp-1];
pop() do
if (Sp < 1) oops("stack underflow", 0);
Sp := Sp-1;
return Stack[Sp];
end
swap() do var t;
if (Sp < 2) oops("stack underflow", 0);
t := Stack[Sp-1];
Stack[Sp-1] := Stack[Sp-2];
Stack[Sp-2] := t;
end
numeric(c) return '0' <= c /\ c <= '9';
alphabetic(c) return 'a' <= c /\ c <= 'z' \/
'A' <= c /\ c <= 'Z';
!
! Symbol table
!
struct SYM = SNAME, SFLAGS, SVALUE;
const GLOBF = 1;
const CNST = 2;
const VECT = 4;
const FORW = 8;
const FUNC = 16;
var Syms[SYM*SYMTBL_SIZE];
var Nlist::NLIST_SIZE;
var Yp, Np;
find(s) do var i;
i := Yp-SYM;
while (i >= 0) do
if (str_equal(Syms[i+SNAME], s))
return @Syms[i];
i := i - SYM;
end
return 0;
end
lookup(s, f) do var y;
y := find(s);
if (y = 0) aw("undefined", s);
if (y[SFLAGS] & f \= f)
aw("unexpected type", s);
return y;
end
newname(s) do var k, new;
k := str_length(s)+1;
if (Np+k >= NLIST_SIZE)
aw("too many symbol names", s);
new := @Nlist::Np;
t.memcopy(new, s, k);
Np := Np+k;
return new;
end
add(s, f, v) do var y;
y := find(s);
if (y \= 0) do
ie (y[SFLAGS] & FORW /\ f & FUNC)
return y;
else
aw("redefined", s);
end
if (Yp+SYM >= SYMTBL_SIZE*SYM)
aw("too many symbols", 0);
y := @Syms[Yp];
Yp := Yp+SYM;
y[SNAME] := newname(s);
y[SFLAGS] := f;
y[SVALUE] := v;
return y;
end
!
! Emitter
!
const TEXT_VADDR = 0;
const DATA_VADDR = 0;
const HEADER_SIZE = 36;
const PAGE_SIZE = 4096;
struct RELOC = RADDR, RSEG;
var Rel[RELOC*NRELOC];
var Text_seg::TEXT_SIZE;
var Data_seg::DATA_SIZE;
var Header::HEADER_SIZE;
var Rp, Tp, Dp, Lp, Hp;
var Acc;
var Codetbl;
struct CG = CG_PUSH, CG_CLEAR,
CG_LDVAL, CG_LDADDR, CG_LDLREF, CG_LDGLOB,
CG_LDLOCL,
CG_STGLOB, CG_STLOCL, CG_STINDR, CG_STINDB,
CG_INCGLOB, CG_INCLOCL,
CG_ALLOC, CG_DEALLOC, CG_LOCLVEC, CG_GLOBVEC,
CG_INDEX, CG_DEREF, CG_INDXB, CG_DREFB,
CG_MARK, CG_RESOLV,
CG_CALL, CG_JUMPFWD, CG_JUMPBACK, CG_JMPFALSE,
CG_JMPTRUE, CG_FOR, CG_FORDOWN,
CG_ENTER, CG_EXIT, CG_HALT,
CG_NEG, CG_INV, CG_LOGNOT, CG_ADD, CG_SUB,
CG_MUL, CG_DIV, CG_MOD, CG_AND, CG_OR, CG_XOR,
CG_SHL, CG_SHR, CG_EQ, CG_NEQ, CG_LT, CG_GT,
CG_LE, CG_GE,
CG_WORD;
emit(x) do
if (Tp >= DATA_SIZE)
aw("text segment too big", 0);
Text_seg::Tp := x;
Tp := Tp+1;
end
emitw(x) do
emit(255&x);
emit(255&(x>>8));
emit(255&(x>>16));
emit(255&(x>>24));
end
tag(seg) do
if (Rp+RELOC >= RELOC*NRELOC)
oops("relocation buffer overflow", 0);
Rel[Rp+RADDR] := seg = 't'-> Tp-BPW: Dp-BPW;
Rel[Rp+RSEG] := seg;
Rp := Rp+RELOC;
end
tpatch(a, x) do
Text_seg::a := 255&x;
Text_seg::(a+1) := 255&(x>>8);
Text_seg::(a+2) := 255&(x>>16);
Text_seg::(a+3) := 255&(x>>24);
end
tfetch(a) return Text_seg::a
| (Text_seg::(a+1)<<8)
| (Text_seg::(a+2)<<16)
| (Text_seg::(a+3)<<24);
data(x) do
Data_seg::Dp := x;
Dp := Dp+1;
end
dataw(x) do
if (Dp >= DATA_SIZE)
aw("data segment too big", 0);
data(255&x);
data(255&(x>>8));
data(255&(x>>16));
data(255&(x>>24));
end
dpatch(a, x) do
Data_seg::a := 255&x;
Data_seg::(a+1) := 255&(x>>8);
Data_seg::(a+2) := 255&(x>>16);
Data_seg::(a+3) := 255&(x>>24);
end
dfetch(a) return Data_seg::a
| (Data_seg::(a+1)<<8)
| (Data_seg::(a+2)<<16)
| (Data_seg::(a+3)<<24);
hex(c) ie (numeric(c))
return c-'0';
else
return c-'a'+10;
rgen(s, v) do var x, f, b;
f := %1;
b := 0;
while (s::0) do
ie (s::0 = ',') do
ie (s::1 = 'w') do
ie (b)
emit(v);
else
emitw(v);
end
else ie (s::1 = 'a') do
emitw(v);
tag('t');
end
else ie (s::1 = 'W') do
emitw(v);
end
else ie (s::1 = 'm') do
push(Tp);
end
else ie (s::1 = '>') do
push(Tp);
emitw(0);
end
else ie (s::1 = '<') do
emitw(pop()-Tp-BPW);
end
else ie (s::1 = 'r') do
x := pop();
tpatch(x, Tp-x-BPW);
end
else do
oops("bad code", 0);
end
end
else do
x := hex(s::0)*16+hex(s::1);
if (f /\ %127 <= v /\ v <= 127) do
x := x | 128;
b := 1;
end
emit(x);
end
f := 0;
s := s+2;
end
end
gen(id, v) rgen(Codetbl[id][1], v);
spill() ie (Acc)
gen(CG_PUSH, 0);
else
Acc := 1;
active() return Acc;
clear() Acc := 0;
activate() Acc := 1;
relocate() do var i, a, dist;
dist := Tp;
for (i=0, Rp, RELOC) do
ie (Rel[i+RSEG] = 't') do
a := tfetch(Rel[i+RADDR]);
a := a + dist;
tpatch(Rel[i+RADDR], a);
end
else do
a := dfetch(Rel[i+RADDR]);
a := a + dist;
dpatch(Rel[i+RADDR], a);
end
end
end
builtin(name, arity, code) do
gen(CG_JUMPFWD, 0);
add(name, GLOBF|FUNC | (arity << 8), Tp);
rgen(code, 0);
gen(CG_RESOLV, 0);
end
align(x, a) return (x+a) & ~(a-1);
hdwrite(b) do
if (Hp >= HEADER_SIZE)
oops("Tcode9 header too long", 0);
Header::Hp := b;
Hp := Hp+1;
end
strwrite(b)
while (b::0) do
hdwrite(b::0);
b := b+1;
end
lewrite(x) do
hdwrite(x & 255);
hdwrite(x>>8 & 255);
hdwrite(x>>16 & 255);
hdwrite(x>>24 & 255);
end
tcode_header() do
strwrite("#! /u/bin/tcvm\n");
strwrite("T3X9"); ! magic
lewrite(Tp); ! text segment size
lewrite(Dp); ! data segment size
end
!
! Scanner
!
const META = 256;
const TOKEN_LEN = 128;
var Prog::PROG_SIZE;
var Pp, Psize;
var Tk;
var Str::TOKEN_LEN;
var Val;
var Oid;
var Equal_op, Minus_op, Mul_op, Add_op;
struct OPER = OPREC, OLEN, ONAME, OTOK, OCODE;
var Ops;
struct TOKENS =
SYMBOL, INTEGER, STRING,
ADDROF, ASSIGN, BINOP, BYTEOP, COLON, COMMA, COND,
CONJ, DISJ, LBRACK, LPAREN, RBRACK, RPAREN, SEMI, UNOP,
KCONST, KDECL, KDO, KELSE, KEND, KFOR, KHALT, KIE, KIF,
KLEAVE, KLOOP, KMODULE, KOBJECT, KPACKED, KRETURN,
KSTRUCT, KVAR, KWHILE;
readprog() do
Psize := t.read(0, Prog, PROG_SIZE);
if (Psize >= PROG_SIZE)
aw("program too big", 0);
end
readrc() do var c;
c := Pp >= Psize-> ENDFILE: Prog::Pp;
Pp := Pp+1;
return c;
end
readc() do var c;
c := readrc();
return 'A' <= c /\ c <= 'Z'-> c-'A'+'a': c;
end
readec() do var c;
c := readrc();
if (c \= '\\') return c;
c := readrc();
if (c = 'a') return '\a';
if (c = 'b') return '\b';
if (c = 'e') return '\e';
if (c = 'f') return '\f';
if (c = 'n') return '\n';
if (c = 'q') return '"' | META;
if (c = 'r') return '\r';
if (c = 's') return '\s';
if (c = 't') return '\t';
if (c = 'v') return '\v';
return c;
end
reject() Pp := Pp-1;
skip() do var c;
c := readc();
while (1) do
while (c = ' ' \/ c = '\t' \/ c = '\n' \/ c = '\r') do
if (c = '\n') Line := Line+1;
c := readc();
end
if (c \= '!')
return c;
while (c \= '\n' /\ c \= ENDFILE)
c := readc();
end
end
findkw(s) do
if (s::0 = 'c') do
if (str_equal(s, "const")) return KCONST;
return 0;
end
if (s::0 = 'd') do
if (str_equal(s, "do")) return KDO;
if (str_equal(s, "decl")) return KDECL;
return 0;
end
if (s::0 = 'e') do
if (str_equal(s, "else")) return KELSE;
if (str_equal(s, "end")) return KEND;
return 0;
end
if (s::0 = 'f') do
if (str_equal(s, "for")) return KFOR;
return 0;
end
if (s::0 = 'h') do
if (str_equal(s, "halt")) return KHALT;
return 0;
end
if (s::0 = 'i') do
if (str_equal(s, "if")) return KIF;
if (str_equal(s, "ie")) return KIE;
return 0;
end
if (s::0 = 'l') do
if (str_equal(s, "leave")) return KLEAVE;
if (str_equal(s, "loop")) return KLOOP;
return 0;
end
if (s::0 = 'm') do
if (str_equal(s, "mod")) return BINOP;
if (str_equal(s, "module")) return KMODULE;
return 0;
end
if (s::0 = 'o') do
if (str_equal(s, "object")) return KOBJECT;
return 0;
end
if (s::0 = 'p') do
if (str_equal(s, "packed")) return KPACKED;
return 0;
end
if (s::0 = 'r') do
if (str_equal(s, "return")) return KRETURN;
return 0;
end
if (s::0 = 's') do
if (str_equal(s, "struct")) return KSTRUCT;
return 0;
end
if (s::0 = 'v') do
if (str_equal(s, "var")) return KVAR;
return 0;
end
if (s::0 = 'w') do
if (str_equal(s, "while")) return KWHILE;
return 0;
end
return 0;
end
scanop(c) do var i, j;
i := 0;
j := 0;
Oid := %1;
while (Ops[i][OLEN] > 0) do
ie (Ops[i][OLEN] > j) do
if (Ops[i][ONAME]::j = c) do
Oid := i;
Str::j := c;
c := readc();
j := j+1;
end
end
else do
leave;
end
i := i+1;
end
if (Oid = %1) do
Str::j := c;
j := j+1;
Str::j := 0;
aw("unknown operator", Str);
end
Str::j := 0;
reject();
return Ops[Oid][OTOK];
end
findop(s) do var i;
i := 0;
while (Ops[i][OLEN] > 0) do
if (str_equal(s, Ops[i][ONAME])) do
Oid := i;
return Oid;
end
i := i+1;
end
oops("operator not found", s);
end
symbolic(c) return alphabetic(c) \/ c = '_' \/ c = '.';
scan() do var c, i, k, sgn, base;
c := skip();
if (c = ENDFILE) do
str_copy(Str, "end of file");
return ENDFILE;
end
if (symbolic(c)) do
i := 0;
while (symbolic(c) \/ numeric(c)) do
if (i >= TOKEN_LEN-1) do
Str::i := 0;
aw("symbol too long", Str);
end
Str::i := c;
i := i+1;
c := readc();
end
Str::i := 0;
reject();
k := findkw(Str);
if (k \= 0) do
if (k = BINOP) findop(Str);
return k;
end
return SYMBOL;
end
if (numeric(c) \/ c = '%') do
sgn := 1;
i := 0;
if (c = '%') do
sgn := %1;
c := readc();
Str::i := c;
i := i+1;
if (\numeric(c))
aw("missing digits after '%'", 0);
end
base := 10;
if (c = '0') do
c := readc();
if (c = 'x') do
base := 16;
c := readc();
if (\numeric(c) /\ (c < 'a' \/ c > 'f'))
aw("missing digits after '0x'", 0);
end
end
Val := 0;
while ( numeric(c) \/
base = 16 /\ 'a' <= c /\ c <= 'f'
) do
if (i >= TOKEN_LEN-1) do
Str::i := 0;
aw("integer too long", Str);
end
Str::i := c;
i := i+1;
c := c >= 'a'-> c-'a'+10: c-'0';
Val := Val * base + c;
c := readc();
end
Str::i := 0;
reject();
Val := Val * sgn;
return INTEGER;
end
if (c = '\'') do
Val := readec();
if (readc() \= '\'')
aw("missing ''' in character", 0);
return INTEGER;
end
if (c = '"') do
i := 0;
c := readec();
while (c \= '"' /\ c \= ENDFILE) do
if (i >= TOKEN_LEN-1) do
Str::i := 0;
aw("string too long", Str);
end
Str::i := c & (META-1);
i := i+1;
c := readec();
end
Str::i := 0;
return STRING;
end
return scanop(c);
end
!
! Parser
!
const MAXTBL = 128;
const MAXLOOP = 100;
var Fun;
var Loop0;
var Leaves[MAXLOOP], Lvp;
var Loops[MAXLOOP], Llp;
expect(tok, s) do var b::100;
if (tok = Tk) return;
str_copy(b, s);
str_append(b, " expected");
aw(b, Str);
end
xeqsign() do
if (Tk \= BINOP \/ Oid \= Equal_op)
expect(BINOP, "'='");
Tk := scan();
end
xsemi() do
expect(SEMI, "';'");
Tk := scan();
end
xlparen() do
expect(LPAREN, "'('");
Tk := scan();
end
xrparen() do
expect(RPAREN, "')'");
Tk := scan();
end
xsymbol() expect(SYMBOL, "symbol");
constfac() do var v, y;
if (Tk = INTEGER) do
v := Val;
Tk := scan();
return v;
end
if (Tk = SYMBOL) do
y := lookup(Str, CNST);
Tk := scan();
return y[SVALUE];
end
aw("constant value expected", Str);
end
constval() do var v;
v := constfac();
ie (Tk = BINOP /\ Oid = Mul_op) do
Tk := scan();
v := v * constfac();
end
else if (Tk = BINOP /\ Oid = Add_op) do
Tk := scan();
v := v + constfac();
end
return v;
end
vardecl(glob) do var y, size;
Tk := scan();
while (1) do
xsymbol();
ie (glob & GLOBF)
y := add(Str, glob, Dp);
else
y := add(Str, 0, Lp);
Tk := scan();
size := 1;
ie (Tk = LBRACK) do
Tk := scan();
size := constval();
if (size < 1)
aw("invalid size", 0);
y[SFLAGS] := y[SFLAGS] | VECT;
expect(RBRACK, "']'");
Tk := scan();
end
else if (Tk = BYTEOP) do
Tk := scan();
size := constval();
if (size < 1)
aw("invalid size", 0);
size := (size + BPW-1) / BPW;
y[SFLAGS] := y[SFLAGS] | VECT;
end
ie (glob & GLOBF) do
if (y[SFLAGS] & VECT) do
gen(CG_ALLOC, size*BPW);
gen(CG_GLOBVEC, Dp);
end
dataw(0);
end
else do
gen(CG_ALLOC, size*BPW);
Lp := Lp - size*BPW;
if (y[SFLAGS] & VECT) do
gen(CG_LOCLVEC, 0);
Lp := Lp - BPW;
end
y[SVALUE] := Lp;
end
if (Tk \= COMMA) leave;
Tk := scan();
end
xsemi();
end
constdecl(glob) do var y;
Tk := scan();
while (1) do
xsymbol();
y := add(Str, glob|CNST, 0);
Tk := scan();
xeqsign();
y[SVALUE] := constval();
if (Tk \= COMMA) leave;
Tk := scan();
end
xsemi();
end
stcdecl(glob) do var y, i;
Tk := scan();
xsymbol();
y := add(Str, glob|CNST, 0);
Tk := scan();
xeqsign();
i := 0;
while (1) do
xsymbol();
add(Str, glob|CNST, i);
i := i+1;
Tk := scan();
if (Tk \= COMMA) leave;
Tk := scan();
end
y[SVALUE] := i;
xsemi();
end
fwddecl() do var y, n;
Tk := scan();
while (1) do
xsymbol();
y := add(Str, GLOBF|FORW, 0);
Tk := scan();
xlparen();
n := constval();
if (n < 0) aw("invalid arity", 0);
y[SFLAGS] := y[SFLAGS] | (n << 8);
xrparen();
if (Tk \= COMMA) leave;
Tk := scan();
end
xsemi();
end
resolve_fwd(loc, fn) do var nloc;
while (loc \= 0) do
nloc := tfetch(loc);
tpatch(loc, fn-loc-BPW);
loc := nloc;
end
end
decl compound(0), stmt(0);
fundecl() do
var l_base, l_addr;
var i, na, oyp, onp;
var y;
l_addr := 2*BPW;
na := 0;
gen(CG_JUMPFWD, 0);
y := add(Str, GLOBF|FUNC, Tp);
Tk := scan();
xlparen();
oyp := Yp;
onp := Np;
l_base := Yp;
while (Tk = SYMBOL) do
add(Str, 0, l_addr);
l_addr := l_addr + BPW;
na := na+1;
Tk := scan();
if (Tk \= COMMA) leave;
Tk := scan();
end
for (i = l_base, Yp, SYM) do
Syms[i+SVALUE] := 12+na*BPW - Syms[i+SVALUE];
end
if (y[SFLAGS] & FORW) do
resolve_fwd(y[SVALUE], Tp);
if (na \= y[SFLAGS] >> 8)
aw("function does not match DECL", y[SNAME]);
y[SFLAGS] := y[SFLAGS] & ~FORW;
y[SFLAGS] := y[SFLAGS] | FUNC;
y[SVALUE] := Tp;
end
xrparen();
y[SFLAGS] := y[SFLAGS] | (na << 8);
gen(CG_ENTER, 0);
Fun := 1;
stmt();
Fun := 0;
gen(CG_CLEAR, 0);
gen(CG_EXIT, 0);
gen(CG_RESOLV, 0);
Yp := oyp;
Np := onp;
Lp := 0;
end
declaration(glob)
ie (Tk = KVAR)
vardecl(glob);
else ie (Tk = KCONST)
constdecl(glob);
else ie (Tk = KSTRUCT)
stcdecl(glob);
else ie (Tk = KDECL)
fwddecl();
else
fundecl();
decl expr(1);
fncall(fn) do var i;
Tk := scan();
if (fn = 0) aw("call of non-function", 0);
if (fn[SFLAGS] & (FUNC|FORW) = 0)
aw("call of non-function", fn[SNAME]);
i := 0;
while (Tk \= RPAREN) do
expr(0);
i := i+1;
if (Tk \= COMMA) leave;
Tk := scan();
if (Tk = RPAREN)
aw("syntax error", Str);
end
if (i \= fn[SFLAGS] >> 8)
aw("wrong number of arguments", fn[SNAME]);
expect(RPAREN, "')'");
Tk := scan();
if (active())
spill();
ie (fn[SFLAGS] & FORW) do
gen(CG_CALL, fn[SVALUE]);
fn[SVALUE] := Tp-BPW;
end
else do
gen(CG_CALL, fn[SVALUE]-Tp-5); ! TP-BPW+1
end
if (i \= 0) gen(CG_DEALLOC, i*BPW);
activate();
end
mkstring(s) do var i, a, k;
a := Dp;
k := str_length(s);
for (i=0, k+1)
data(s::i);
while (Dp mod BPW \= 0)
data(0);
return a;
end
mkbytevec() do var a, k;
Tk := scan();
expect(LBRACK, "'['");
Tk := scan();
a := Dp;
k := 0;
while (1) do
expect(INTEGER, "cvalue");
if (Val > 255 \/ Val < 0)
aw("byte vector member out of range", Str);
data(Val);
Tk := scan();
if (Tk \= COMMA) leave;
Tk := scan();
end
expect(RBRACK, "']'");
Tk := scan();
while (Dp mod BPW \= 0)
data(0);
return a;
end
mktable() do
var n, i, a;
var tbl[MAXTBL], af[MAXTBL];
var dynamic;
Tk := scan();
dynamic := 0;
n := 0;
while (Tk \= RBRACK) do
if (n >= MAXTBL)
aw("table too big", 0);
ie (Tk = LPAREN /\ \dynamic) do
Tk := scan();
dynamic := 1;
loop;
end
else ie (dynamic) do
expr(1);
gen(CG_STGLOB, 0);
tbl[n] := 0;
af[n] := Tp-BPW;
n := n+1;
if (Tk = RPAREN) do
Tk := scan();
dynamic := 0;
end
end
else ie (Tk = INTEGER \/ Tk = SYMBOL) do
tbl[n] := constval();
af[n] := 0;
n := n+1;
end
else ie (Tk = STRING) do
tbl[n] := mkstring(Str);
af[n] := 1;
n := n+1;
Tk := scan();
end
else ie (Tk = LBRACK) do
tbl[n] := mktable();
af[n] := 1;
n := n+1;
end
else ie (Tk = KPACKED) do
tbl[n] := mkbytevec();
af[n] := 1;
n := n+1;
end
else do
aw("invalid table element", Str);
end
if (Tk \= COMMA) leave;
Tk := scan();
if (Tk = RBRACK)
aw("syntax error", Str);
end
if (dynamic)
aw("missing ')' in dynamic table", 0);
expect(RBRACK, "']'");
if (n = 0) aw("empty table", 0);
Tk := scan();
a := Dp;
for (i=0, n) do
dataw(tbl[i]);
ie (af[i] = 1) do
tag('d');
end
else if (af[i] > 1) do
tpatch(af[i], Dp-4);
end
end
return a;
end
load(y) ie (y[SFLAGS] & GLOBF)
gen(CG_LDGLOB, y[SVALUE]);
else
gen(CG_LDLOCL, y[SVALUE]);
store(y)
ie (y[SFLAGS] & GLOBF)
gen(CG_STGLOB, y[SVALUE]);
else
gen(CG_STLOCL, y[SVALUE]);
decl factor(0);
address(lv, bp) do var y;
y := lookup(Str, 0);
Tk := scan();
ie (y[SFLAGS] & CNST) do
if (lv > 0) aw("invalid location", y[SNAME]);
spill();
gen(CG_LDVAL, y[SVALUE]);
end
else ie (y[SFLAGS] & (FUNC|FORW)) do
if (lv = 2) aw("invalid location", y[SNAME]);
end
else if (lv = 0 \/ Tk = LBRACK \/ Tk = BYTEOP) do
spill();
load(y);
end
if (Tk = LBRACK \/ Tk = BYTEOP)
if (y[SFLAGS] & (FUNC|FORW|CNST))
aw("bad subscript", y[SNAME]);
while (Tk = LBRACK) do
Tk := scan();
bp[0] := 0;
expr(0);
expect(RBRACK, "']'");
Tk := scan();
y := 0;
gen(CG_INDEX, 0);
if (lv = 0 \/ Tk = LBRACK \/ Tk = BYTEOP)
gen(CG_DEREF, 0);
end
if (Tk = BYTEOP) do
Tk := scan();
bp[0] := 1;
factor();
y := 0;
gen(CG_INDXB, 0);
if (lv = 0) gen(CG_DREFB, 0);
end
return y;
end
factor() do var y, op, b;
ie (Tk = INTEGER) do
spill();
gen(CG_LDVAL, Val);
Tk := scan();
end
else ie (Tk = SYMBOL) do
y := address(0, @b);
if (Tk = LPAREN) fncall(y);
end
else ie (Tk = STRING) do
spill();
gen(CG_LDADDR, mkstring(Str));
Tk := scan();
end
else ie (Tk = LBRACK) do
spill();
gen(CG_LDADDR, mktable());
end
else ie (Tk = KPACKED) do
spill();
gen(CG_LDADDR, mkbytevec());
end
else ie (Tk = ADDROF) do
Tk := scan();
y := address(2, @b);
ie (y = 0) do
;
end
else ie (y[SFLAGS] & GLOBF) do
spill();
gen(CG_LDADDR, y[SVALUE]);
end
else do
spill();
gen(CG_LDLREF, y[SVALUE]);
end
end
else ie (Tk = BINOP) do
if (Oid \= Minus_op)
aw("syntax error", Str);
Tk := scan();
factor();
gen(CG_NEG, 0);
end
else ie (Tk = UNOP) do
op := Oid;
Tk := scan();
factor();
gen(Ops[op][OCODE], 0);
end
else ie (Tk = LPAREN) do
Tk := scan();
expr(0);
xrparen();
end
else do
aw("syntax error", Str);
end
end
emitop(stk, p) do
gen(Ops[stk[p-1]][OCODE], 0);
return p-1;
end
arith() do var stk[10], p;
factor();
p := 0;
while (Tk = BINOP) do
while (p /\ Ops[Oid][OPREC] <= Ops[stk[p-1]][OPREC])
p := emitop(stk, p);
stk[p] := Oid;
p := p+1;
Tk := scan();
factor();
end
while (p > 0)
p := emitop(stk, p);
end
conjn() do var n;
arith();
n := 0;
while (Tk = CONJ) do
Tk := scan();
gen(CG_JMPFALSE, 0);
clear();
arith();
n := n+1;
end
while (n > 0) do
gen(CG_RESOLV, 0);
n := n-1;
end
end
disjn() do var n;
conjn();
n := 0;
while (Tk = DISJ) do
Tk := scan();
gen(CG_JMPTRUE, 0);
clear();
conjn();
n := n+1;
end
while (n > 0) do
gen(CG_RESOLV, 0);
n := n-1;
end
end
expr(clr) do
if (clr) clear();
disjn();
if (Tk = COND) do
Tk := scan();
gen(CG_JMPFALSE, 0);
expr(1);
expect(COLON, "':'");
Tk := scan();
gen(CG_JUMPFWD, 0);
swap();
gen(CG_RESOLV, 0);
expr(1);
gen(CG_RESOLV, 0);
end
end
halt_stmt() do
Tk := scan();
gen(CG_HALT, constval());
xsemi();
end
return_stmt() do
Tk := scan();
if (Fun = 0)
aw("can't return from main body", 0);
ie (Tk = SEMI)
gen(CG_CLEAR, 0);
else
expr(1);
if (Lp \= 0) do
gen(CG_DEALLOC, -Lp);
end
gen(CG_EXIT, 0);
xsemi();
end
if_stmt(alt) do
Tk := scan();
xlparen();
expr(1);
gen(CG_JMPFALSE, 0);
xrparen();
stmt();
if (alt) do
gen(CG_JUMPFWD, 0);
swap();
gen(CG_RESOLV, 0);
expect(KELSE, "ELSE");
Tk := scan();
stmt();
end
gen(CG_RESOLV, 0);
end
while_stmt() do var olp, olv;
Tk := scan();
olp := Loop0;
olv := Lvp;
gen(CG_MARK, 0);
Loop0 := tos();
xlparen();
expr(1);
xrparen();
gen(CG_JMPFALSE, 0);
stmt();
swap();
gen(CG_JUMPBACK, 0);
gen(CG_RESOLV, 0);
while (Lvp > olv) do
push(Leaves[Lvp-1]);
gen(CG_RESOLV, 0);
Lvp := Lvp-1;
end
Loop0 := olp;
end
for_stmt() do
var y;
var step;
var oll, olp, olv;
var test;
Tk := scan();
oll := Llp;
olv := Lvp;
olp := Loop0;
Loop0 := 0;
xlparen();
xsymbol();
y := lookup(Str, 0);
if (y[SFLAGS] & (CNST|FUNC|FORW))
aw("unexpected type", y[SNAME]);
Tk := scan();
xeqsign();
expr(1);
store(y);
expect(COMMA, "','");
Tk := scan();
gen(CG_MARK, 0);
test := tos();
load(y);
expr(0);
ie (Tk = COMMA) do
Tk := scan();
step := constval();
end
else do
step := 1;
end
gen(step<0-> CG_FORDOWN: CG_FOR, 0);
xrparen();
stmt();
while (Llp > oll) do
push(Loops[Llp-1]);
gen(CG_RESOLV, 0);
Llp := Llp-1;
end
ie (y[SFLAGS] & GLOBF)
gen(CG_INCGLOB, y[SVALUE]);
else
gen(CG_INCLOCL, y[SVALUE]);
gen(CG_WORD, step);
swap();
gen(CG_JUMPBACK, 0);
gen(CG_RESOLV, 0);
while (Lvp > olv) do
push(Leaves[Lvp-1]);
gen(CG_RESOLV, 0);
Lvp := Lvp-1;
end
Loop0 := olp;
end
leave_stmt() do
Tk := scan();
if (Loop0 < 0)
aw("LEAVE not in loop context", 0);
xsemi();
if (Lvp >= MAXLOOP)
aw("too many LEAVEs", 0);
gen(CG_JUMPFWD, 0);
Leaves[Lvp] := pop();
Lvp := Lvp+1;
end
loop_stmt() do
Tk := scan();
if (Loop0 < 0)
aw("LOOP not in loop context", 0);
xsemi();
ie (Loop0 > 0) do
push(Loop0);
gen(CG_JUMPBACK, 0);
end
else do
if (Llp >= MAXLOOP)
aw("too many LOOPs", 0);
gen(CG_JUMPFWD, 0);
Loops[Llp] := pop();
Llp := Llp+1;
end
end
asg_or_call() do var y, b;
clear();
y := address(1, @b);
ie (Tk = LPAREN) do
fncall(y);
end
else ie (Tk = ASSIGN) do
Tk := scan();
expr(0);
ie (y = 0)
gen(b-> CG_STINDB: CG_STINDR, 0);
else ie (y[SFLAGS] & (FUNC|FORW|CNST|VECT))
aw("bad location", y[SNAME]);
else
store(y);
end
else do
aw("syntax error", Str);
end
xsemi();
end
stmt() ie (Tk = KFOR)
for_stmt();
else ie (Tk = KHALT)
halt_stmt();
else ie (Tk = KIE)
if_stmt(1);
else ie (Tk = KIF)
if_stmt(0);
else ie (Tk = KELSE)
aw("ELSE without IE", 0);
else ie (Tk = KLEAVE)
leave_stmt();
else ie (Tk = KLOOP)
loop_stmt();
else ie (Tk = KRETURN)
return_stmt();
else ie (Tk = KWHILE)
while_stmt();
else ie (Tk = KDO)
compound();
else ie (Tk = SYMBOL)
asg_or_call();
else ie (Tk = SEMI)
Tk := scan();
else
expect(%1, "statement");
compound() do var oyp, olp, onp;
Tk := scan();
oyp := Yp;
onp := Np;
olp := Lp;
while (Tk = KVAR \/ Tk = KCONST \/ Tk = KSTRUCT)
declaration(0);
while (Tk \= KEND)
stmt();
Tk := scan();
if (olp-Lp \= 0)
gen(CG_DEALLOC, olp-Lp);
Yp := oyp;
Np := onp;
Lp := olp;
end
checkclass()
if (\str_equal(Str, "t3x"))
aw("class name must be T3X", Str);
module_decl() do
Tk := scan();
xsymbol();
Tk := scan();
xlparen();
xsymbol();
checkclass();
Tk := scan();
xrparen();
xsemi();
end
object_decl() do
Tk := scan();
xsymbol();
if (\str_equal(Str, "t"))
aw("object name must be T", Str);
Tk := scan();
expect(LBRACK, "'['");
Tk := scan();
expect(SYMBOL, "symbol");
checkclass();
Tk := scan();
expect(RBRACK, "']'");
Tk := scan();
xsemi();
end
program() do var i;
Tk := scan();
if (Tk = KMODULE) module_decl();
if (Tk = KOBJECT) object_decl();
while ( Tk = KVAR \/ Tk = KCONST \/ Tk = SYMBOL \/
Tk = KDECL \/ Tk = KSTRUCT
)
declaration(GLOBF);
if (Tk \= KDO)
aw("DO or declaration expected", 0);
gen(CG_ENTER, 0);
compound();
if (Tk \= ENDFILE)
aw("trailing characters", Str);
gen(CG_HALT, 0);
for (i=0, Yp, SYM)
if (Syms[i+SFLAGS] & FORW /\ Syms[i+SVALUE])
aw("undefined function", Syms[i+SNAME]);
end
!
! Main
!
init() do
var i;
var tcomp, tcopy, tfill, tscan;
var tcreate, topen, tclose, tread, twrite;
var trename, tremove;
Rp := 0;
Tp := 0;
Dp := 0;
Lp := 0;
Sp := 0;
Yp := 0;
Np := 0;
Pp := 0;
Hp := 0;
Line := 1;
Acc := 0;
Fun := 0;
Loop0 := %1;
Lvp := 0;
Llp := 0;
Codetbl := [
[ CG_PUSH, "00" ],
[ CG_CLEAR, "01" ],
[ CG_LDVAL, "02,w" ],
[ CG_LDADDR, "03,a" ],
[ CG_LDLREF, "04,w" ],
[ CG_LDGLOB, "05,a" ],
[ CG_LDLOCL, "06,w" ],
[ CG_STGLOB, "07,a" ],
[ CG_STLOCL, "08,w" ],
[ CG_STINDR, "09" ],
[ CG_STINDB, "0a" ],
[ CG_INCGLOB, "0b,a" ],
[ CG_INCLOCL, "0c,w" ],
[ CG_ALLOC, "0d,w" ],
[ CG_DEALLOC, "0e,w" ],
[ CG_LOCLVEC, "0f" ],
[ CG_GLOBVEC, "10,a" ],
[ CG_INDEX, "11" ],
[ CG_DEREF, "12" ],
[ CG_INDXB, "13" ],
[ CG_DREFB, "14" ],
[ CG_MARK, ",m" ],
[ CG_RESOLV, ",r" ],
[ CG_CALL, "17,W" ],
[ CG_JUMPFWD, "18,>" ],
[ CG_JUMPBACK, "19,<" ],
[ CG_JMPFALSE, "1a,>" ],
[ CG_JMPTRUE, "1b,>" ],
[ CG_FOR, "1c,>" ],
[ CG_FORDOWN, "1d,>" ],
[ CG_ENTER, "1e" ],
[ CG_EXIT, "1f" ],
[ CG_HALT, "20,w" ],
[ CG_NEG, "21" ],
[ CG_INV, "22" ],
[ CG_LOGNOT, "23" ],
[ CG_ADD, "24" ],
[ CG_SUB, "25" ],
[ CG_MUL, "26" ],
[ CG_DIV, "27" ],
[ CG_MOD, "28" ],
[ CG_AND, "29" ],
[ CG_OR, "2a" ],
[ CG_XOR, "2b" ],
[ CG_SHL, "2c" ],
[ CG_SHR, "2d" ],
[ CG_EQ, "2e" ],
[ CG_NEQ, "2f" ],
[ CG_LT, "30" ],
[ CG_GT, "31" ],
[ CG_LE, "32" ],
[ CG_GE, "33" ],
[ CG_WORD, ",W" ],
[ %1, "" ] ];
tcomp := "3500";
tcopy := "3501";
tfill := "3502";
tscan := "3503";
tcreate := "3504";
topen := "3505";
tclose := "3506";
tread := "3507";
twrite := "3508";
trename := "3509";
tremove := "350a";
Ops := [[ 7, 3, "mod", BINOP, CG_MOD ],
[ 6, 1, "+", BINOP, CG_ADD ],
[ 7, 1, "*", BINOP, CG_MUL ],
[ 0, 1, ";", SEMI, 0 ],
[ 0, 1, ",", COMMA, 0 ],
[ 0, 1, "(", LPAREN, 0 ],
[ 0, 1, ")", RPAREN, 0 ],
[ 0, 1, "[", LBRACK, 0 ],
[ 0, 1, "]", RBRACK, 0 ],
[ 3, 1, "=", BINOP, CG_EQ ],