The T3X9 Compiler Source Code

This is the source code of the full T3X9 compiler, compiling from T3X version 9 to ELF for FreeBSD-386. See the T3X page for further details or the compiler page for a distribution tarball.

! T3X9 -> ELF-FreeBSD-386 compiler
! Nils M Holm, 2017, CC0 license
! https://creativecommons.org/publicdomain/zero/1.0/
! Patchlevel 2

const	BPW = 4;

const	PROG_SIZE = 65536;

const	TEXT_SIZE = 65536;  ! must be a multiple of PAGE_SIZE !
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(ss, sd, str.length(ss)+1);

str.append(sd, ss) t.memcopy(ss, @sd::str.length(sd), 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(s, new, 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 = 134512640;		! 0x08048000
const	DATA_VADDR = TEXT_VADDR + TEXT_SIZE;

const	HEADER_SIZE = 116;	! 0x74

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_INIT,
		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;
	while (s::0) do
		ie (s::0 = ',') do
			ie (s::1 = 'w') do
				emitw(v);
			end
			else ie (s::1 = 'a') do
				emitw(v);
				tag('t');
			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
			emit(hex(s::0)*16+hex(s::1));
		end
		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 := DATA_VADDR + (HEADER_SIZE + Tp) mod PAGE_SIZE;
	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("ELF header too long", 0);
	Header::Hp := b;
	Hp := Hp+1;
end

hexwrite(b)
	while (b::0) do
		hdwrite(16*hex(b::0)+hex(b::1));
		b := b+2;
	end

lewrite(x) do
	hdwrite(x & 255);
	hdwrite(x>>8 & 255);
	hdwrite(x>>16 & 255);
	hdwrite(x>>24 & 255);
end

elfheader() do
	hexwrite("7f454c46");		! magic
	hexwrite("01");			! 32-bit
	hexwrite("01");			! little endian
	hexwrite("01");			! header version
	hexwrite("09");			! FreeBSD ABI
	hexwrite("0000000000000000");	! padding
	hexwrite("0200");		! executable
	hexwrite("0300");		! 386
	lewrite(1);			! version
	lewrite(TEXT_VADDR+HEADER_SIZE);! initial entry point
	lewrite(52);			! program header offset (0x34)
	lewrite(0);			! no header segments
	lewrite(0);			! flags
	hexwrite("3400");		! header size
	hexwrite("2000");		! program header size
	hexwrite("0200");		! number of program headers
	hexwrite("2800");		! segment header size (unused)
	hexwrite("0000");		! number of segment headers
	hexwrite("0000");		! string index (unused)
	! text segment description
	lewrite(1);			! loadable segment
	lewrite(HEADER_SIZE);		! offset in file
	lewrite(TEXT_VADDR);		! virtual load address
	lewrite(TEXT_VADDR);		! physical load address
	lewrite(Tp);			! size in file
	lewrite(Tp);			! size in memory
	lewrite(5);			! flags := read, execute
	lewrite(PAGE_SIZE);		! alignment (page)
	! data segment description
	lewrite(1);			! loadable segment
	lewrite(HEADER_SIZE+Tp);	! offset in file
	lewrite(DATA_VADDR);		! virtual load address
	lewrite(DATA_VADDR);		! physical load address
	lewrite(Dp);			! size in file
	lewrite(Dp);			! size in memory
	lewrite(6);			! flags := read, write
	lewrite(PAGE_SIZE);		! alignment (page)
end

!
! Scanner
!

const	META	 = 256;

const	TOKEN_LEN = 128;

var	Prog::PROG_SIZE;

var	Pp, Psize;

var	T;
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, 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;
		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;
	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
		Val := 0;
		while (numeric(c)) do
			if (i >= TOKEN_LEN-1) do
				Str::i := 0;
				aw("integer too long", Str);
			end
			Str::i := c;
			i := i+1;
			Val := Val * 10 + c - '0';
			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 = T) return;
	str.copy(b, s);
	str.append(b, " expected");
	aw(b, Str);
end

xeqsign() do
	if (T \= BINOP \/ Oid \= Equal_op)
		expect(BINOP, "'='");
	T := scan();
end

xsemi() do
	expect(SEMI, "';'");
	T := scan();
end

xlparen() do
	expect(LPAREN, "'('");
	T := scan();
end

xrparen() do
	expect(RPAREN, "')'");
	T := scan();
end

xsymbol() expect(SYMBOL, "symbol");

constfac() do var v, y;
	if (T = INTEGER) do
		v := Val;
		T := scan();
		return v;
	end
	if (T = SYMBOL) do
		y := lookup(Str, CNST);
		T := scan();
		return y[SVALUE];
	end
	aw("constant value expected", Str);
end

constval() do var v;
	v := constfac();
	ie (T = BINOP /\ Oid = Mul_op) do
		T := scan();
		v := v * constfac();
	end
	else if (T = BINOP /\ Oid = Add_op) do
		T := scan();
		v := v + constfac();
	end
	return v;
end

vardecl(glob) do var y, size;
	T := scan();
	while (1) do
		xsymbol();
		ie (glob & GLOBF)
			y := add(Str, glob, Dp);
		else
			y := add(Str, 0, Lp);
		T := scan();
		size := 1;
		ie (T = LBRACK) do
			T := scan();
			size := constval();
			if (size < 1)
				aw("invalid size", 0);
			y[SFLAGS] := y[SFLAGS] | VECT;
			expect(RBRACK, "']'");
			T := scan();
		end
		else if (T = BYTEOP) do
			T := 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 (T \= COMMA) leave;
		T := scan();
	end
	xsemi();
end

constdecl(glob) do var y;
	T := scan();
	while (1) do
		xsymbol();
		y := add(Str, glob|CNST, 0);
		T := scan();
		xeqsign();
		y[SVALUE] := constval();
		if (T \= COMMA) leave;
		T := scan();
	end
	xsemi();
end

stcdecl(glob) do var y, i;
	T := scan();
	xsymbol();
	y := add(Str, glob|CNST, 0);
	T := scan();
	xeqsign();
	i := 0;
	while (1) do
		xsymbol();
		add(Str, glob|CNST, i);
		i := i+1;
		T := scan();
		if (T \= COMMA) leave;
		T := scan();
	end
	y[SVALUE] := i;
	xsemi();
end

fwddecl() do var y, n;
	T := scan();
	while (1) do
		xsymbol();
		y := add(Str, GLOBF|FORW, 0);
		T := scan();
		xlparen();
		n := constval();
		if (n < 0) aw("invalid arity", 0);
		y[SFLAGS] := y[SFLAGS] | (n << 8);
		xrparen();
		if (T \= COMMA) leave;
		T := 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);
	T := scan();
	xlparen();
	oyp := Yp;
	onp := Np;
	l_base := Yp;
	while (T = SYMBOL) do
		add(Str, 0, l_addr);
		l_addr := l_addr + BPW;
		na := na+1;
		T := scan();
		if (T \= COMMA) leave;
		T := 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 (T = KVAR)
		vardecl(glob);
	else ie (T = KCONST)
		constdecl(glob);
	else ie (T = KSTRUCT)
		stcdecl(glob);
	else ie (T = KDECL)
		fwddecl();
	else
		fundecl();

decl	expr(1);

fncall(fn) do var i;
	T := 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 (T \= RPAREN) do
		expr(0);
		i := i+1;
		if (T \= COMMA) leave;
		T := scan();
		if (T = RPAREN)
			aw("syntax error", Str);
	end
	if (i \= fn[SFLAGS] >> 8)
		aw("wrong number of arguments", fn[SNAME]);
	expect(RPAREN, "')'");
	T := 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

mktable() do
	var	n, i, a;
	var	tbl[MAXTBL], af[MAXTBL];
	var	dynamic;

	T := scan();
	dynamic := 0;
	n := 0;
	while (T \= RBRACK) do
		if (n >= MAXTBL)
			aw("table too big", 0);
		ie (T = LPAREN /\ \dynamic) do
			T := 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 (T = RPAREN) do
				T := scan();
				dynamic := 0;
			end
		end
		else ie (T = INTEGER \/ T = SYMBOL) do
			tbl[n] := constval();
			af[n] := 0;
			n := n+1;
		end
		else ie (T = STRING) do
			tbl[n] := mkstring(Str);
			af[n] := 1;
			n := n+1;
			T := scan();
		end
		else ie (T = LBRACK) do
			tbl[n] := mktable();
			af[n] := 1;
			n := n+1;
		end
		else do
			aw("invalid table element", Str);
		end
		if (T \= COMMA) leave;
		T := scan();
		if (T = RBRACK)
			aw("syntax error", Str);
	end
	if (dynamic)
		aw("missing ')' in dynamic table", 0);
	expect(RBRACK, "']'");
	if (n = 0) aw("empty table", 0);
	T := 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);
	T := 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 \/ T = LBRACK \/ T = BYTEOP) do
		spill();
		load(y);
	end
	if (T = LBRACK \/ T = BYTEOP)
		if (y[SFLAGS] & (FUNC|FORW|CNST))
			aw("bad subscript", y[SNAME]);
	while (T = LBRACK) do
		T := scan();
		bp[0] := 0;
		expr(0);
		expect(RBRACK, "']'");
		T := scan();
		y := 0;
		gen(CG_INDEX, 0);
		if (lv = 0 \/ T = LBRACK  \/ T = BYTEOP)
			gen(CG_DEREF, 0);
	end
	if (T = BYTEOP) do
		T := 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 (T = INTEGER) do
		spill();
		gen(CG_LDVAL, Val);
		T := scan();
	end
	else ie (T = SYMBOL) do
		y := address(0, @b);
		if (T = LPAREN) fncall(y);
	end
	else ie (T = STRING) do
		spill();
		gen(CG_LDADDR, mkstring(Str));
		T := scan();
	end
	else ie (T = LBRACK) do
		spill();
		gen(CG_LDADDR, mktable());
	end
	else ie (T = ADDROF) do
		T := 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 (T = BINOP) do
		if (Oid \= Minus_op)
			aw("syntax error", Str);
		T := scan();
		factor();
		gen(CG_NEG, 0);
	end
	else ie (T = UNOP) do
		op := Oid;
		T := scan();
		factor();
		gen(Ops[op][OCODE], 0);
	end
	else ie (T = LPAREN) do
		T := 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 (T = BINOP) do
		while (p /\ Ops[Oid][OPREC] <= Ops[stk[p-1]][OPREC])
			p := emitop(stk, p);
		stk[p] := Oid;
		p := p+1;
		T := scan();
		factor();
	end
	while (p > 0)
		p := emitop(stk, p);
end

conjn() do var n;
	arith();
	n := 0;
	while (T = CONJ) do
		T := 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 (T = DISJ) do
		T := 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 (T = COND) do
		T := scan();
		gen(CG_JMPFALSE, 0);
		expr(1);
		expect(COLON, "':'");
		T := scan();
		gen(CG_JUMPFWD, 0);
		swap();
		gen(CG_RESOLV, 0);
		expr(1);
		gen(CG_RESOLV, 0);
	end
end

halt_stmt() do
	T := scan();
	gen(CG_HALT, constval());
	xsemi();
end

return_stmt() do
	T := scan();
	if (Fun = 0)
		aw("can't return from main body", 0);
	ie (T = 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
	T := scan();
	xlparen();
	expr(1);
	gen(CG_JMPFALSE, 0);
	xrparen();
	stmt();
	ie (alt) do
		gen(CG_JUMPFWD, 0);
		swap();
		gen(CG_RESOLV, 0);
		expect(KELSE, "ELSE");
		T := scan();
		stmt();
	end
	gen(CG_RESOLV, 0);
end

while_stmt() do var olp, olv;
	T := 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;

	T := 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]);
	T := scan();
	xeqsign();
	expr(1);
	store(y);
	expect(COMMA, "','");
	T := scan();
	gen(CG_MARK, 0);
	test := tos();
	load(y);
	expr(0);
	ie (T = COMMA) do
		T := 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
	T := 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
	T := 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 (T = LPAREN) do
		fncall(y);
	end
	else ie (T = ASSIGN) do
		T := 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 (T = KFOR)
		for_stmt();
	else ie (T = KHALT)
		halt_stmt();
	else ie (T = KIE)
		if_stmt(1);
	else ie (T = KIF)
		if_stmt(0);
	else ie (T = KELSE)
		aw("ELSE without IE", 0);
	else ie (T = KLEAVE)
		leave_stmt();
	else ie (T = KLOOP)
		loop_stmt();
	else ie (T = KRETURN)
		return_stmt();
	else ie (T = KWHILE)
		while_stmt();
	else ie (T = KDO)
		compound();
	else ie (T = SYMBOL)
		asg_or_call();
	else ie (T = SEMI)
		T := scan();
	else
		expect(%1, "statement");

compound() do var oyp, olp, onp;
	T := scan();
	oyp := Yp;
	onp := Np;
	olp := Lp;
	while (T = KVAR \/ T = KCONST \/ T = KSTRUCT)
		declaration(0);
	while (T \= KEND)
		stmt();
	T := scan();
	if (olp-Lp \= 0)
		gen(CG_DEALLOC, olp-Lp);
	Yp := oyp;
	Np := onp;
	Lp := olp;
end

program() do var i;
	T := scan();
	gen(CG_INIT, 0);
	while (	T = KVAR \/ T = KCONST \/ T = SYMBOL \/
		T = KDECL \/ T = KSTRUCT
	)
		declaration(GLOBF);
	if (T \= KDO)
		aw("DO or declaration expected", 0);
	compound();
	if (T \= 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, tread, twrite, tcomp, tcopy, tfill, tscan;
	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_INIT,	"89e5"			],
		[ CG_PUSH,	"50"			],
		[ CG_CLEAR,	"31c0"			],
		[ CG_LDVAL,	"b8,w"			],
		[ CG_LDADDR,	"b8,a"			],
		[ CG_LDLREF,	"8d85,w"		],
		[ CG_LDGLOB,	"a1,a"			],
		[ CG_LDLOCL,	"8b85,w"		],
		[ CG_STGLOB,	"a3,a"			],
		[ CG_STLOCL,	"8985,w"		],
		[ CG_STINDR,	"5b8903"		],
		[ CG_STINDB,	"5b8803"		],
		[ CG_INCGLOB,	"8105,a"		],
		[ CG_INCLOCL,	"8185,w"		],
		[ CG_ALLOC,	"81ec,w"		],
		[ CG_DEALLOC,	"81c4,w"		],
		[ CG_LOCLVEC,	"89e050"		],
		[ CG_GLOBVEC,	"8925,a"		],
		[ CG_INDEX,	"c1e0025b01d8"		],
		[ CG_DEREF,	"8b00"			],
		[ CG_INDXB,	"5b01d8"		],
		[ CG_DREFB,	"89c331c08a03"		],
		[ CG_MARK,	",m"			],
		[ CG_RESOLV,	",r"			],
		[ CG_CALL,	"e8,w"			],
		[ CG_JUMPFWD,	"e9,>"			],
		[ CG_JUMPBACK,	"e9,<"			],
		[ CG_JMPFALSE,	"09c00f84,>"		],
		[ CG_JMPTRUE,	"09c00f85,>"		],
		[ CG_FOR,	"5b39c30f8d,>"		],
		[ CG_FORDOWN,	"5b39c30f8e,>"		],
		[ CG_ENTER,	"5589e5"		],
		[ CG_EXIT,	"5dc3"			],
		[ CG_HALT,	"68,w5031c040cd80"	],
		[ CG_NEG,	"f7d8"			],
		[ CG_INV,	"f7d0"			],
		[ CG_LOGNOT,	"f7d819c0f7d0"		],
		[ CG_ADD,	"5b01d8"		],
		[ CG_SUB,	"89c35829d8"		],
		[ CG_MUL,	"5bf7eb"		],
		[ CG_DIV,	"89c35899f7fb"		],
		[ CG_MOD,	"89c35899f7fb89d0"	],
		[ CG_AND,	"5b21d8"		],
		[ CG_OR,	"5b09d8"		],
		[ CG_XOR,	"5b31d8"		],
		[ CG_SHL,	"89c158d3e0"		],
		[ CG_SHR,	"89c158d3e8"		],
		[ CG_EQ,	"5b39c30f95c20fb6c248"	],
		[ CG_NEQ,	"5b39c30f94c20fb6c248"	],
		[ CG_LT,	"5b39c30f9dc20fb6c248"	],
		[ CG_GT,	"5b39c30f9ec20fb6c248"	],
		[ CG_LE,	"5b39c30f9fc20fb6c248"	],
		[ CG_GE,	"5b39c30f9cc20fb6c248"	],
		[ CG_WORD,	",w"			],
		[ %1,		""			] ];
	tread := "8b4424048744240c89442404b803000000cd800f830300000031c048c3";
	twrite := "8b4424048744240c89442404b804000000cd800f830300000031c048c3";
	tcomp :=
  "8b74240c8b7c24088b4c240441fcf3a609c90f850300000031c0c38a46ff2a47ff669898c3";
	tcopy := "8b74240c8b7c24088b4c2404fcf3a431c0c3";
	tfill := "8b7c240c8b4424088b4c2404fcf3aa31c0c3";
	tscan :=
  "8b7c240c8b4424088b4c24044189fafcf2ae09c90f840600000089f829d048c331c048c3";
	Ops := [[ 7, 1, "mod",	BINOP,  CG_MOD		],
		[ 6, 1, "+",	BINOP,  CG_ADD		],
		[ 7, 2, "*",	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		],
		[ 5, 1, "&",	BINOP,  CG_AND		],
		[ 5, 1, "|",	BINOP,  CG_OR		],
		[ 5, 1, "^",	BINOP,  CG_XOR		],
		[ 0, 1, "@",	ADDROF, 0		],
		[ 0, 1, "~",	UNOP,   CG_INV		],
		[ 0, 1, ":",	COLON,  0		],
		[ 0, 2, "::",	BYTEOP, 0		],
		[ 0, 2, ":=",	ASSIGN, 0		],
		[ 0, 1, "\\",	UNOP,   CG_LOGNOT	],
		[ 1, 2, "\\/",	DISJ,   0		],
		[ 3, 2, "\\=",	BINOP,  CG_NEQ		],
		[ 4, 1, "<",	BINOP,  CG_LT		],
		[ 4, 2, "<=",	BINOP,  CG_LE		],
		[ 5, 2, "<<",	BINOP,  CG_SHL		],
		[ 4, 1, ">",	BINOP,  CG_GT		],
		[ 4, 2, ">=",   BINOP,  CG_GE		],
		[ 5, 2, ">>",	BINOP,  CG_SHR		],
		[ 6, 1, "-",	BINOP,  CG_SUB		],
		[ 0, 2, "->",	COND,   0		],
		[ 7, 2, "/",	BINOP,  CG_DIV		],
		[ 2, 2, "/\\",	CONJ,   0		],
		[ 0, 0, 0,	0,      0		] ];
	Equal_op := findop("=");
	Minus_op := findop("-");
	Mul_op := findop("*");
	Add_op := findop("+");
	i := 0;
	while (Codetbl[i][0] \= %1) do
		if (Codetbl[i][0] \= i)
			oops("bad code table entry", ntoa(i));
		i := i+1;
	end
	builtin("t.read", 3, tread);
	builtin("t.write", 3, twrite);
	builtin("t.memcomp", 3, tcomp);
	builtin("t.memcopy", 3, tcopy);
	builtin("t.memfill", 3, tfill);
	builtin("t.memscan", 3, tscan);
end

do
	init();
	readprog();
	program();
	! 16-byte align in file
	Tp := align(HEADER_SIZE+Tp, 16)-HEADER_SIZE;
	relocate();
	elfheader();
	t.write(1, Header, Hp);
	t.write(1, Text_seg, Tp);
	t.write(1, Data_seg, Dp);
end

contact