!	T 3Xr5t -- Copyright (C) 1997,1998,1999 Nils M Holm.
!	<nmh@t3x.org>
!
!	TXTRN is a compiler for a simple procedural language
!	called T3X. T3X is a superset of the language T, v3.
!	The translator reads a source program from stdin and
!	writes an equivalent Tcode program to stdout.
!
!	The T compiler is free software. Basically, do what you
!	want with it, but do not remove any copyright notices.
!	See the file LICENSE for conditions of use.
!
!	The risk of using T is entirely with you, so don't complain.

const	BUFSIZE=	1026,	! Must be <= 2050 !
	OBUFL=		1025,	! Must be <= 1025 !
	SYMBSPACE=	3072,
	NSPACE=		4096,
	TEXTLEN=	129,
	MAXTBL=		128;

const	META=	256;

const	CNST=	1,
	GLOBAL=	2,
	PROC=	4,
	PROTO=	8,
	IFACE=	16,
	EXTRN=	32;

const	SNAME=	0,
	SFLAGS=	1,
	SSIZE=	2,
	SVAL=	3,
	SYMLEN=	4;

var	Symbols[SYMBSPACE], St;
var	Sym_equ, Sym_mod, Sym_sub, Sym_add, Sym_mul,
	Sym_bar, Sym_not;
var	Names[NSPACE], Nt;
var	Line;
var	File[TEXTLEN];
var	Errcount;
var	Token;
var	Text[TEXTLEN];
var	Value;
var	Op;
var	Label;
var	Startlab, Endlab, Exitlab;
var	Looplevl;
var	Locladdr;
var	Buffer[BUFSIZE], Cp, Ep, Lowp, Nomore;
var	Obuf[OBUFL], Obp;
var	Last[5], LL;
var	Ops;
var	Bcslot;
var	Debug;


const	ENDFILE=%1;

const	SYMBOL=0, NUMBER=1, STRING=2;

const	BINOP=10, DISOP=11, CONOP=12, UNOP=20, ADDROP=21, LPAREN=30,
	RPAREN=31, LBRACK=40, RBRACK=41, SEMI=50, COMMA=60, ASSIGN=70,
	COND=80, COLON=81, BYTEOP=90, METAOP=99;

const	OPREC=	0,
	OLEN=	1,
	ONAME=	2,
	OTOK=	3,
	OCODE=	4,
	OPLEN=	5;

const	KCALL=100, KCONST=101, KDECL=102, KDO=103, KELSE=104, KEND=105,
	KEXTERN=106, KFOR=107, KHALT=108, KIE=109, KIF=110, KIFACE=111,
	KLEAVE=112, KLOOP=113, KPACKED=114, KPUBLIC=115, KRETURN=116,
	KSTRUCT=117, KVAR=118, KWHILE=119;

const	ICLAB=129, IDLAB=130, IDECL=131, IDATA=132, ICREF=133,
	IDREF=134, ISTR=135, IPSTR=136, IINIT=137, IHDR=010,
	IEND=011,

	INEG=012, ILNOT=013, IBNOT=014, IPOP=015, ICLEAN=144,
	INOP=017,

	IINDB=018, IIND=019, IDREFB=020, IDEREF=021, IINCG=150,
	IINCL=151,

	IMUL=024, IDIV=025, IMOD=026, IADD=027, ISUB=028, IBAND=029,
	IBOR=030, IBXOR=031,

	IBSHL=032, IBSHR=033, IEQU=034, INEQU=035, ILESS=036,
	IGRTR=037, ILTEQ=038, IGTEQ=039,

	ILDG=168, ILDGV=169, ILDL=170, ILDLV=171, ILDLAB=172,

	INUM=173, ISAVG=174, ISAVL=175, ISTORE=048, ISTORB=049,

	ISTACK=178, ICALL=179, ICALR=52, IEXEC=181, IBRF=182,
	IBRT=183, INBRF=184, INBRT=185, IJUMP=186, IUNEXT=187,
	IDNEXT=188, IHALT=061,

	IPUB=190, IEXT=191,

	IUMUL=64, IUDIV=65, IULESS=66, IUGRTR=67, IULTEQ=68,
	IUGTEQ=69,

	IDUP = 70, ISWAP = 71,

	ILINE = 200, IGSYM = 201, ILSYM = 202,

	IENDOFSET=75;


decl	factor(0), expr(0), stmt(0), compound(0), declaration(1);


initvars() do
	St := 0;
	Nt := 0;
	Line := 1;
	File[0] := 0;
	Errcount := 0;
	Label := 1;
	Startlab := 0;
	Endlab := 0;
	Exitlab := 0;
	Looplevl := 0;
	Locladdr := 1;
	Cp := 0;
	Ep := 0;
	Lowp := 0;
	Nomore := 0;
	Obp := 0;
	LL := 0;
	Bcslot := 0;
	Debug := 0;
	Ops := [
		[ 6, 1, "+",	BINOP,	IADD	],
		[ 7, 1, "*",	BINOP,	IMUL	],
		[ 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,	IEQU	],
		[ 5, 1, "&",	BINOP,	IBAND	],
		[ 5, 1, "|",	BINOP,	IBOR	],
		[ 5, 1, "^",	BINOP,	IBXOR	],
		[ 0, 1, "@",	ADDROP,	0	],
		[ 0, 1, "~",	UNOP,	IBNOT	],
		[ 0, 1, ":",	COLON,	0	],
		[ 0, 2, "::",	BYTEOP,	0	],
		[ 0, 2, ":=",	ASSIGN,	0	],
		[ 0, 1, "\\",	UNOP,	ILNOT	],
		[ 1, 2, "\\/",	DISOP,	0	],
		[ 3, 2, "\\=",	BINOP,	INEQU	],
		[ 4, 1, "<",	BINOP,	ILESS	],
		[ 5, 2, "<<",	BINOP,	IBSHL	],
		[ 4, 2, "<=",	BINOP,	ILTEQ	],
		[ 4, 1, ">",	BINOP,	IGRTR	],
		[ 5, 2, ">>",	BINOP,	IBSHR	],
		[ 4, 2, ">=",	BINOP,	IGTEQ	],
		[ 6, 1, "-",	BINOP,	ISUB	],
		[ 0, 2, "->",	COND,	0	],
		[ 7, 1, "/",	BINOP,	IDIV	],
		[ 2, 2, "/\\",	CONOP,	0	],
		[ 7, 2, "./",	BINOP,	IUDIV	],
		[ 7, 2, ".*",	BINOP,	IUMUL	],
		[ 4, 2, ".<",	BINOP,	IULESS	],
		[ 4, 3, ".<=",	BINOP,	IULTEQ	],
		[ 4, 2, ".>",	BINOP,	IUGRTR	],
		[ 4, 3, ".>=",	BINOP,	IUGTEQ	],
		[ 0, 1, "#",	METAOP,	0	],
		[ 7, 3, "mod",	BINOP,	IMOD	],
		[ 0, 0, 0,	0,	0	]
	];
end


strequ(a, b) do
	var	i;

	i := 0;
	while (a[i] /\ b[i]) do
		if (a[i] - b[i]) leave;
		i := i+1;
	end
	return a[i] = b[i];
end


length(a) do
	var	k;

	k := 0;
	while (a[k]) k := k+1;
	return k;
end


strcpy(a, b) do
	var	i;

	i := 0;
	while (b[i]) do
		a[i] := b[i];
		i := i+1;
	end
	a[i] := 0;
	return i;
end


error(m, s) do
	var	o;

	o := select(1, 2);
	writes("TXTRN: ");
	if (File[0]) do
		writes(File); writes(": ");
	end
	writes(ntoa(Line, 0));
	writes(": ");
	writes(m);
	if (s) do
		writes(": ");
		writes(s);
	end
	newline();
	select(1, o);
	Errcount := Errcount+1;
end


fatal(m, s) do
	error(m, s);
	select(1, 2);
	writes("terminating."); newline();
	if (Errcount) close(open("TXTRN.ERR", 1));
	halt;
end


fillbuf() do
	var	i;

	if (Nomore) return 0;
	for (i=Cp, Ep) Buffer[i-Cp] := Buffer[i];
	i := Ep-Cp;
	Cp := 0;
	Ep := reads(@Buffer[i], BUFSIZE/2-1);
	if (\Ep) Nomore := 1;
	Ep := Ep + i;
	Lowp := Ep-TEXTLEN;
end


eof() return Nomore /\ Cp >= Ep;


getce() do
	var	c;

	c := Buffer[Cp]; Cp := Cp+1;
	if (c \= '\\') return c;
	c := Buffer[Cp]; Cp := Cp+1;
	if (c = 'a' \/ c = 'A') return '\a';
	if (c = 'b' \/ c = 'B') return '\b';
	if (c = 'e' \/ c = 'E') return '\e';
	if (c = 'f' \/ c = 'F') return '\f';
	if (c = 'n' \/ c = 'N') return '\n';
	if (c = 'q' \/ c = 'Q') return '"' | META;
	if (c = '"') return '"' | META;
	if (c = 'r' \/ c = 'R') return '\r';
	if (c = 's' \/ c = 'S') return '\s';
	if (c = 't' \/ c = 'T') return '\t';
	if (c = 'v' \/ c = 'V') return '\v';
	return c;
end


findkw(s)
	ie (s[0] = 'c') do
		if (strequ(s, "call")) return KCALL;
		if (strequ(s, "const")) return KCONST;
		return 0;
	end
	else ie (s[0] = 'd') do
		if (strequ(s, "decl")) return KDECL;
		if (strequ(s, "do")) return KDO;
		return 0;
	end
	else ie (s[0] = 'e') do
		if (strequ(s, "else")) return KELSE;
		if (strequ(s, "end")) return KEND;
		if (strequ(s, "extern")) return KEXTERN;
		return 0;
	end
	else ie (s[0] = 'f') do
		if (strequ(s, "for")) return KFOR;
		return 0;
	end
	else ie (s[0] = 'h') do
		if (strequ(s, "halt")) return KHALT;
		return 0;
	end
	else ie (s[0] = 'i') do
		if (strequ(s, "ie")) return KIE;
		if (strequ(s, "if")) return KIF;
		if (strequ(s, "interface")) return KIFACE;
		return 0;
	end
	else ie (s[0] = 'l') do
		if (strequ(s, "leave")) return KLEAVE;
		if (strequ(s, "loop")) return KLOOP;
		return 0;
	end
	else ie (s[0] = 'm') do
		if (strequ(s, "mod")) return BINOP;
		return 0;
	end
	else ie (s[0] = 'p') do
		if (strequ(s, "packed")) return KPACKED;
		if (strequ(s, "public")) return KPUBLIC;
		return 0;
	end
	else ie (s[0] = 'r') do
		if (strequ(s, "return")) return KRETURN;
		return 0;
	end
	else ie (s[0] = 's') do
		if (strequ(s, "struct")) return KSTRUCT;
		return 0;
	end
	else ie (s[0] = 'v') do
		if (strequ(s, "var")) return KVAR;
		return 0;
	end
	else ie (s[0] = 'w') do
		if (strequ(s, "while")) return KWHILE;
		return 0;
	end
	else do
		return 0;
	end


findop(c) do
	var	k, i, j;

	k := 0;
	i := 0;
	j := %1;
	while (Ops[i][OLEN] > k) do
		if (c = Ops[i][ONAME][k]) do
			c := Buffer[Cp]; Cp := Cp+1;
			j := i;
			k := k+1;
			if (Ops[i][OLEN] > k) do
				j := %1;
				i := i-1;
			end
		end
		i := i+1;
	end
	Cp := Cp-1;
	Op := j;
	return j = %1-> 0: Ops[j][OTOK];
end


findop2(s) do
	var	i;

	i := 0;
	while (Ops[i][OLEN]) do
		if (strequ(Ops[i][ONAME], s)) return i;
		i := i+1;
	end
	fatal("bad name in findop2()", s);
end


scan() do
	var	c, i, bc[3];

	if (Cp >= Lowp) fillbuf();
	c := Buffer[Cp]; Cp := Cp+1;
	while (1) do
		while (	c = '\s' \/ c = '\t' \/ c = '\n' \/
			c = '\r' \/ c = '\f'
		) do
			if (c = '\n') Line := Line+1;
			c := Buffer[Cp]; Cp := Cp+1;
                        if (Cp >= Lowp) do
                                if (eof()) return ENDFILE;
                                fillbuf();
                        end
		end
		if (c \= '!') leave;
                while (c \= '\n') do
                        if (Cp >= Lowp) do
                                if (eof()) return ENDFILE;
                                fillbuf();
                        end
                        c := Buffer[Cp]; Cp := Cp+1;
                end
	end
	if (eof()) return ENDFILE;
	if (	'a' <= c /\ c <= 'z' \/
		'A' <= c /\ c <= 'Z' \/
		c = '_'
	) do
		i := 1;
		Text[0] := '_';
		while (1) do
			ie ('A' <= c /\ c <= 'Z')
				c := c-'A'+'a';
			else if (\('a' <= c /\ c <= 'z' \/
				'0' <= c /\ c <= '9' \/
				c = '_')
			)
				leave;
			if (i >= TEXTLEN-1) fatal("symbol too long", 0);
			Text[i] := c;
			i := i+1;
			c := Buffer[Cp]; Cp := Cp+1;
		end
		Text[i] := 0;
		Cp := Cp-1;
		c := findkw(@Text[1]);
		if (c) do
			if (c = BINOP) Op := Sym_mod;
			return c;
		end
		Text[i] := '_';
		Text[i+1] := 0;
		return SYMBOL;
	end
	if ('0' <= c /\ c <= '9' \/ c = '%') do
		Value := 0;
		i := 0;
		if (c = '%') do
			i := 1;
			c := Buffer[Cp]; Cp := Cp+1;
		end
		while ('0' <= c /\ c <= '9') do
			Value := Value*10 + (c-'0');
			c := Buffer[Cp]; Cp := Cp+1;
		end
		Cp := Cp-1;
		if (i) Value := -Value;
		return NUMBER;
	end
	if (c = '\'') do
		Value := getce() & ~META;
		c := Buffer[Cp]; Cp := Cp+1;
		if (c \= '\'') error("missing `''", 0);
		return NUMBER;
	end
	if (c = '"') do
		i := 0;
		c := getce();
		while (c \= '"') do
			if (i >= TEXTLEN-2) fatal("string too long", 0);
			Text[i] := c & ~META;
			i := i+1;
			c := getce();
			if (eof()) fatal("unexpected EOF", 0);
		end
		Text[i] := 0;
		return STRING;
	end
	i := findop(c);
	if (i) return i;
	bc[0] := c/16 + (c/16 > 9-> 'A'-10: '0');
	bc[1] := c mod 16 + (c mod 16 > 9-> 'A'-10: '0');
	bc[2] := 0;
	fatal("bad input character", bc);
end


synch(t) do
	ie (t) do
		while (Token \= t) do
			Token := scan();
			if (Token = ENDFILE)
				fatal("EOF found in error recovery", 0);
		end
	end
	else do
		Token := scan();
	end
end


findsym(name, rpt) do
	var	i, s;

	i := St-SYMLEN;
	while (i >= 0) do
		s := Symbols[i+SNAME];
		if (s[1] = name[1] /\ strequ(name, s)) return i;
		i := i-SYMLEN;
	end
	if (rpt) error("undefined symbol", name);
	return %1;
end


rptdecls() do
	var	i, s;

	i := St-SYMLEN;
	while (i >= 0) do
		s := @Symbols[i];
		if (s[SFLAGS] & (PROTO|EXTRN) = PROTO)
			error("undefined procedure", s[SNAME]);
		i := i-SYMLEN;
	end
end


newsym(name, size, val, flags) do
	var	k, sp;

	k := length(name);
	sp := findsym(name, 0);
	if (name[0] \= '*' /\ sp \= %1) do
		if (flags \= PROC \/ Symbols[sp+SFLAGS] \= (PROC|PROTO)) do
			error("duplicate symbol", name);
			return sp;
		end
	end
	if (St >= SYMBSPACE) fatal("too many symbols", name);
	if (Nt + k >= NSPACE) fatal("out of name space", name);
	strcpy(@Names[Nt], name);
	Symbols[St+SNAME] := @Names[Nt];
	Nt := Nt+k+1;
	Symbols[St+SSIZE] := size;
	Symbols[St+SVAL] := val;
	Symbols[St+SFLAGS] := flags;
	St := St+SYMLEN;
	return St-SYMLEN;
end


newlab() do
	if (\Label) fatal("out of labels", 0);
	Label := Label+1;
	return Label-1;
end


flush() do
	Obuf[Obp] := 0;
	writes(Obuf);
	Obp := 0;
end


commit() do
	var	i;

	for (i=0, LL) do
		if (Obp >= OBUFL-1) flush();
		Obuf[Obp] := Last[i] | 256;
		Obp := Obp + 1;
	end
end


gen0(instr) do
	commit();
	Last[0] := instr;
	LL := 1;
end


gen1(instr, arg) do
	commit();
	Last[0] := instr;
	Last[1] := arg & 255;
	Last[2] := arg>>8;
	LL := 3;
end


gen2(instr, a1, a2) do
	commit();
	Last[0] := instr;
	Last[1] := a1 & 255;
	Last[2] := a1>>8;
	Last[3] := a2 & 255;
	Last[4] := a2>>8;
	LL := 5;
end


stack(n) if (n) gen1(ISTACK, n);


loadsym(k) do
	if (Symbols[k+SFLAGS] & PROC) return 0;
	ie (Symbols[k+SFLAGS] & GLOBAL)
		gen1(Symbols[k+SSIZE]-> ILDGV: ILDG, Symbols[k+SVAL]);
	else
		gen1(Symbols[k+SSIZE]-> ILDLV: ILDL, Symbols[k+SVAL]);
end


savesym(k) ie (Symbols[k+SFLAGS] & GLOBAL)
		gen1(ISAVG, Symbols[k+SVAL]);
	else
		gen1(ISAVL, Symbols[k+SVAL]);


tcond(n, flags) do
	ie (flags) do
		gen1(flags=1-> INBRT: INBRF, n);
		gen0(IPOP);
	end
	else do
		gen1(IBRF, n);
	end
end


fcond(y, n) do
	gen1(IJUMP, y);
	gen1(ICLAB, n);
end


econd(y) gen1(ICLAB, y);


match(t, m) do
	ie (t = Token)
		Token := scan();
	else
		error(m, 0);
end


xsemi() match(SEMI, "missing `;'");

xlparen() match(LPAREN, "missing `('");

xrparen() match(RPAREN, "missing `)'");

equsign() ie (Token \= BINOP \/ Op \= Sym_equ)
		error("missing `='", 0);
	else
		Token := scan();


constfac() do
	var	k, v;

	v := 1;
	ie (Token = BINOP /\ Op = Sym_sub) do
		Token := scan();
		return -constfac();
	end
	else ie (Token = UNOP /\ Op = Sym_not) do
		Token := scan();
		return ~constfac();
	end
	else ie (Token = NUMBER) do
		v := Value;
		Token := scan();
	end
	else ie (Token = SYMBOL) do
		k := findsym(Text, 1);
		if (k \= %1) do
			ie (\(Symbols[k+SFLAGS] & CNST))
				error("not a constant", Text);
			else
				v := Symbols[k+SVAL];
		end
		Token := scan();
	end
	else do
		error("constant value expected", 0);
	end
	return v;
end


constval() do
	var	v, o;

	v := constfac();
	while (Token = BINOP) do
		o := Op;
		Token := scan();
		ie (Op = Sym_add)
			v := v + constfac();
		else ie (Op = Sym_mul)
			v := v * constfac();
		else ie (Op = Sym_bar)
			v := v | constfac();
		else
			leave;
	end
	return v;
end


pcall(k, ind) do
	var	n, d[5], dl, i;

	n := 0;
	ie (k = %1) do
		error("call of non-procedure", 0);
	end
	else do
		ie (ind) do
			ie (Symbols[k+SFLAGS] & PROC)
				ind := 0;
			else if ((Symbols[k+SFLAGS] & (CNST|PROTO|IFACE)) \/
				Symbols[k+SSIZE]
			)
				error("bad indirect call", Symbols[k+SNAME]);
		end
		else do
			if (\(Symbols[k+SFLAGS] & PROC))
				error("call of non-procedure",
					Symbols[k+SNAME]);
		end
	end
	xlparen();
	if (ind) do
		for (i=0, 5) d[i] := Last[i];
		dl := LL; LL := 0;
	end
	if (Token \= RPAREN) while (1) do
		expr();
		n := n+1;
		if (Token \= COMMA) leave;
		Token := scan();
	end
	if (\ind /\ k >= 0 /\ Symbols[k+SSIZE] \= n)
		error("wrong number of arguments", Symbols[k+SNAME]);
	if (k >= 0) do
		ie (ind) do
			commit();
			for (i=0, 5) Last[i] := d[i];
			LL := dl;
			gen0(ICALR);
		end
		else ie (Symbols[k+SFLAGS] & IFACE) do
			gen1(IEXEC, Symbols[k+SVAL]);
		end
		else do
			gen1(ICALL, Symbols[k+SVAL]);
		end
		gen1(ICLEAN, n);
	end
	xrparen();
end


strlit(s, ext) do
	var	i, l, k;

	k := length(s);
	l := newlab();
	gen1(IDLAB, l);
	gen1(ext-> ISTR: IPSTR, k);
	for (i=0, k) gen0(s[i]);
	Token := scan();
	return l;
end


bytevec() do
	var	t[MAXTBL], v, i, p;

	Token := scan();
	if (Token = STRING) return strlit(Text, 0);
	if (Token \= LBRACK) do
		error("packed string or vector expected", 0);
		synch(0);
		return 0;
	end
	p := 0;
	Token := scan();
	while (Token = SYMBOL \/ Token = NUMBER) do
		t[p] := constval();
		if (t[p] > 255 \/ t[p] < -128)
			error("vector member too big", 0);
		if (p >= MAXTBL) fatal("table too big", 0);
		p := p+1;
		if (Token \= COMMA) leave;
		Token := scan();
	end
	if (\p) error("empty table", 0);
	v := newlab();
	gen1(IDLAB, v);
	gen1(IPSTR, p);
	for (i=0, p) gen0(t[i]);
	match(RBRACK, "missing `]'");
	return v;
end


table() do
	var	t[MAXTBL], tf[MAXTBL], p, v, i, k;

	p := 0;
	Token := scan();
	while (	Token = SYMBOL \/ Token = NUMBER \/
		Token = LBRACK \/ Token = STRING \/
		Token = ADDROP \/ Token = KPACKED \/
		Token = LPAREN \/
		Token = BINOP /\ Op = Sym_sub \/
		Token = UNOP /\ Op = Sym_not
	) do
		ie (	Token = SYMBOL \/ Token = NUMBER \/
			Token = BINOP /\ Op = Sym_sub \/
			Token = UNOP /\ Op = Sym_not
		) do
			t[p] := constval();
			tf[p] := IDATA;
		end
		else ie (Token = STRING) do
			t[p] := strlit(Text, 1);
			tf[p] := IDREF;
		end
		else ie (Token = KPACKED) do
			t[p] := bytevec();
			tf[p] := IDREF;
		end
		else ie (Token = ADDROP) do
			Token := scan();
			ie (Token = SYMBOL) do
				k := findsym(Text, 1);
			end
			else do
				error("symbol expected", 0);
				k := %1;
			end
			if (k >= 0) do
				ie (Symbols[k+SFLAGS] & (CNST|IFACE)) error(
					"cannot take @const or @interface",
					Text);
				else ie (Symbols[k+SFLAGS] & PROC)
					tf[p] := ICREF;
				else ie (Symbols[k+SFLAGS] & GLOBAL = GLOBAL)
					tf[p] := IDREF;
				else
					error("unknown address", Text);
			end
			t[p] := Symbols[k+SVAL];
			Token := scan();
		end
		else ie (Token = LPAREN) do
			t[p] := newlab();
			tf[p] := IDLAB;
			expr();
			gen1(ISAVG, t[p]);
		end
		else do
			t[p] := table();
			tf[p] := IDREF;
		end
		if (p >= MAXTBL) fatal("table too big", 0);
		p := p+1;
		if (Token \= COMMA) leave;
		Token := scan();
	end
	v := newlab();
	gen1(IDLAB, v);
	if (\p) error("empty table", 0);
	for (i=0, p) do
		ie (tf[i] = IDLAB) do
			gen1(IDLAB, t[i]);
			gen1(IDATA, 0);
		end
		else do
			gen1(tf[i], t[i]);
		end
	end
	match(RBRACK, "missing `]'");
	return v;
end


address() do
	var	t, k;

	if (Token \= SYMBOL) do
		error("symbol expected", 0);
		return %1;
	end
	k := findsym(Text, 1);
	Token := scan();
	if (k \= %1) do
		ie (Symbols[k+SFLAGS] & CNST)
			gen1(INUM, Symbols[k+SVAL]);
		else
			loadsym(k);
	end
	while (Token = LBRACK \/ Token = BYTEOP) do
		if (k >= 0 /\ (Symbols[k+SFLAGS] & (CNST|PROC)))
			error("bad subscript", Symbols[k+SNAME]);
		t := Token;
		Token := scan();
		ie (t = BYTEOP) do
			factor();
			gen0(IDREFB);
			gen0(IINDB);
			return %1;
		end
		else do
			expr();
			gen0(IDEREF);
			gen0(IIND);
			match(RBRACK, "missing `]'");
		end
		k := %1;
	end
	return k;
end


factor() do
	var	o, k, ind;

	ie (Token = NUMBER) do
		gen1(INUM, Value);
		Token := scan();
	end
	else ie (Token = SYMBOL \/ Token = KCALL) do
		ind := 0;
		if (Token = KCALL) do
			Token := scan(); ind := 1;
		end
		k := address();
		ie (Token = LPAREN)
			pcall(k, ind);
		else if (k >= 0 /\ Symbols[k+SFLAGS] & PROC \/ ind)
			error("incomplete procedure call",
				Symbols[k+SNAME]);
	end
	else ie (Token = STRING) do
		gen1(ILDLAB, strlit(Text, 1));
	end
	else ie (Token = KPACKED) do
		gen1(ILDLAB, bytevec());
	end
	else ie (Token = LBRACK) do
		gen1(ILDLAB, table());
	end
	else ie (Token = ADDROP) do
		Token := scan();
		k := address();
		ie (k >= 0) do
			if (\(Symbols[k+SFLAGS] & PROC)) LL := 0;
			ie (Symbols[k+SFLAGS] & (CNST|IFACE))
				error("cannot take @const or @interface",
					Symbols[k+SNAME]);
			else ie (Symbols[k+SFLAGS] & PROC)
				gen1(ILDLAB, Symbols[k+SVAL]);
			else ie (Symbols[k+SFLAGS] & GLOBAL)
				gen1(ILDGV, Symbols[k+SVAL]);
			else
				gen1(ILDLV, Symbols[k+SVAL]);
		end
		else do
			ie (Last[0] = IIND \/ Last[0] = IINDB)
				LL := 0;
			else
				error("bad lvalue", 0);
		end
	end
	else ie (Token = BINOP) do
		if (Op \= Sym_sub) error("bad unary operator", 0);
		Token := scan();
		factor();
		gen0(INEG);
	end
	else ie (Token = UNOP) do
		o := Op;
		Token := scan();
		factor();
		gen0(Ops[o][OCODE]);
	end
	else ie (Token = LPAREN) do
		Token := scan();
		expr();
		xrparen();
	end
	else do
		error("bad expression", 0);
		synch(0);
	end
end


emitop(stk, sp) do
	sp := sp-1;
	gen0(Ops[stk[sp]][OCODE]);
	return sp;
end


binary() do
	var	stk[5], sp;

	sp := 0;
	factor();
	while (Token = BINOP) do
		while (sp /\ Ops[Op][OPREC] <= Ops[stk[sp-1]][OPREC])
			sp := emitop(stk, sp);
		if (sp >= 5) fatal("binary(): stack overflow", 0);
		stk[sp] := Op; sp := sp+1;
		Token := scan();
		factor();
	end
	while (sp) sp := emitop(stk, sp);
end


conj() do
	var	e;

	e := 0;
	binary();
	if (Token = CONOP) e := newlab();
	while (Token = CONOP) do
		Token := scan();
		tcond(e, 2);
		binary();
	end
	if (e) econd(e);
end


disj() do
	var	e;

	e := 0;
	conj();
	if (Token = DISOP) e := newlab();
	while (Token = DISOP) do
		Token := scan();
		tcond(e, 1);
		conj();
	end
	if (e) econd(e);
end


expr() do
	var	y, n;

	disj();
	if (Token = COND) do
		y := newlab();
		n := newlab();
		Token := scan();
		tcond(n, 0);
		expr();
		fcond(y, n);
		match(COLON, "missing `:'");
		expr();
		econd(y);
	end
end


ie_stmt(alt) do
	var	y, n;

	n := newlab();
	if (alt) y := newlab();
	Token := scan();
	xlparen();
	expr();
	xrparen();
	tcond(n, 0);
	stmt();
	if (alt) do
		fcond(y, n);
		match(KELSE, "missing `ELSE'");
		stmt();
	end
	econd(alt-> y: n);
end


while_stmt() do
	var	s, e, levl;

	s := Startlab;
	e := Endlab;
	levl := Looplevl;
	Startlab := newlab();
	Endlab := newlab();
	Looplevl := Locladdr;
	Token := scan();
	xlparen();
	gen1(ICLAB, Startlab);
	expr();
	tcond(Endlab, 0);
	xrparen();
	stmt();
	gen1(IJUMP, Startlab);
	econd(Endlab);
	Startlab := s;
	Endlab := e;
	Looplevl := levl;
end


for_stmt() do
	var	k, step, r, s, e, levl;

	step := 1;
	s := Startlab;
	e := Endlab;
	levl := Looplevl;
	Startlab := newlab();
	r := newlab();
	Endlab := newlab();
	Looplevl := Locladdr;
	Token := scan();
	xlparen();
	ie (Token = SYMBOL) do
		k := findsym(Text, 1);
		if (k \= %1 /\ Symbols[k+SFLAGS] & (CNST|PROC))
			error("bad lvalue", Text);
		if (k \= %1 /\ Symbols[k+SSIZE])
			error("index may not be a vector", Text);
	end
	else do
		k := %1;
	end
	match(SYMBOL, "symbol name expected");
	equsign();
	expr();
	if (k \= %1) savesym(k);
	match(COMMA, "missing `,'");
	gen1(ICLAB, r);
	if (k \= %1) loadsym(k);
	expr();
	if (Token = COMMA) do
		Token := scan();
		step := constval();
	end
	xrparen();
	gen1(step>0-> IUNEXT: IDNEXT, Endlab);
	stmt();
	gen1(ICLAB, Startlab);
	ie (Symbols[k+SFLAGS] & GLOBAL)
		gen2(IINCG, Symbols[k+SVAL], step);
	else
		gen2(IINCL, Symbols[k+SVAL], step);
	gen1(IJUMP, r);
	gen1(ICLAB, Endlab);
	Startlab := s;
	Endlab := e;
	Looplevl := levl;
end


asg_or_call() do
	var	k;

	if (Token \= SYMBOL) do
		error("bad statement", 0);
		synch(SEMI);
		xsemi();
		return 0;
	end
	k := address();
	ie (Token = ASSIGN) do
		Token := scan();
		ie (k \= %1) do
			ie (Symbols[k+SFLAGS] & (CNST|PROC))
				error("bad lvalue", Symbols[k+SNAME]);
			else if (Symbols[k+SSIZE])
				error("missing subscript", Symbols[k+SNAME]);
			LL := 0;
			expr();
			savesym(k);
		end
		else do
			k := Last[0]; LL := 0;
			if (k \= IIND /\ k \= IINDB) error("bad lvalue", 0);
			expr();
			gen0(k=IIND-> ISTORE: ISTORB);
		end
		xsemi();
	end
	else ie (Token = LPAREN) do
		pcall(k, 0);
		gen0(IPOP);
		xsemi();
	end
	else do
		error("bad statement", 0);
		synch(SEMI);
		xsemi();
	end
end


metacmd() do
	var	badsyn;

	badsyn := 0;
	Token := scan();
	ie (Token \= SYMBOL) do
		badsyn := 1;
	end
	else ie (Text[1] = 'l' /\ \Text[3]) do
		Token := scan();
		ie (Token \= NUMBER) badsyn := 1;
		else Token := scan();
		Line := Value;
		ie (Token \= STRING) do
			badsyn := 1;
		end
		else do
			if (\badsyn) strcpy(File, Text);
			Token := scan();
		end
	end
	else ie (strequ(Text, "_debug_")) do
		Token := scan();
		Debug := 1;
	end
	else ie (strequ(Text, "_r5_")) do
		Token := scan();
		! ignore
	end
	else do
		badsyn := 1;
	end
	if (badsyn) do
		error("invalid # syntax", 0); synch(SEMI); return 0;
	end
	xsemi();
end


stmt() do
	if (Debug) gen1(ILINE, Line);
	ie (Token = KDO) do
		return compound();
	end
	else ie (Token = KIE) do
		ie_stmt(1);
	end
	else ie (Token = KIF) do
		ie_stmt(0);
	end
	else ie (Token = KWHILE) do
		while_stmt();
	end
	else ie (Token = KFOR) do
		for_stmt();
	end
	else ie (Token = KLEAVE) do
		Token := scan();
		xsemi();
		if (\Endlab) error("`LEAVE' in wrong context", 0);
		stack(-(Locladdr - Looplevl));
		gen1(IJUMP, Endlab);
	end
	else ie (Token = KLOOP) do
		Token := scan();
		xsemi();
		if (\Startlab) error("`LOOP' in wrong context", 0);
		stack(-(Locladdr - Looplevl));
		gen1(IJUMP, Startlab);
	end
	else ie (Token = KRETURN) do
		Token := scan();
		expr();
		xsemi();
		if (\Exitlab) error("`RETURN' in wrong context", 0);
		gen0(IPOP);
		stack(-Locladdr+1);
		gen1(IJUMP, Exitlab);
		return 1;
	end
	else ie (Token = KHALT) do
		Token := scan();
		xsemi();
		gen0(IHALT);
	end
	else ie (Token = SEMI) do
		Token := scan();
	end
	else ie (Token = KELSE) do
		Token := scan();
		error("`ELSE' with no matching `IE'", 0);
	end
	else ie (Token = KCALL) do
		factor();
		gen0(IPOP);
		xsemi();
	end
	else ie (Token = METAOP) do
		metacmd();
	end
	else do
		asg_or_call();
	end
	return 0;
end


cleanup() do
	var	k, la;

	la := Locladdr;
	k := findsym("*", 0);
	if (k \= %1) do
		St := k;
		Nt := Symbols[k+SSIZE];
		Locladdr := Symbols[k+SVAL];
	end
	stack(-(la - Locladdr));
end


compound() do
	var	ot, rv;

	ot := Locladdr;
	newsym("*", Nt, Locladdr, 0);
	Token := scan();
	while (	Token = KVAR \/ Token = KCONST \/ Token = KSTRUCT \/
		Token = METAOP
	)
		declaration(1);
	stack(Locladdr - ot);
	rv := 0;
	while (Token \= KEND) do
		if (eof()) fatal("unexpected EOF", 0);
		rv := stmt();
	end
	Token := scan();
	cleanup();
	return rv;
end


adjust(k, n) do
	n := n+3;
	while (k < St) do
		Symbols[k+SVAL] := Symbols[k+SVAL]-n;
		k := k+SYMLEN;
	end
end


linkage(linkop, name) do
	var	i, k;

	k := length(name);
	gen1(linkop, k);
	for (i=0, k) gen0(name[i]);
end


dumpsym(k, local) do
	var	i, j, s;

	s := Symbols[k+SNAME];
	j := length(s);
	gen1(local-> ILSYM: IGSYM, j);
	for (i=0, j) gen0(s[i]);
	gen0(Symbols[k+SVAL]);
	gen0(Symbols[k+SVAL]>>8);
end


pdecl(linkop) do
	var	p, k, pb, lv, n, addr, rv;

	n := 0;
	addr := 2;
	p := findsym(Text, 0);
	Exitlab := newlab();
	if (linkop) linkage(linkop, Text);
	k := newsym(Text, 0, 0, PROC);
	lv := newsym("*", Nt, 1, 0)+SYMLEN;
	Token := scan();
	xlparen();
	pb := St;
	if (Token \= RPAREN) while (1) do
		if (Token = SYMBOL) do
			newsym(Text, 0, addr, 0);
			addr := addr+1;
		end
		match(SYMBOL, "argument name expected");
		n := n+1;
		if (Token \= COMMA) leave;
		Token := scan();
	end
	Symbols[k+SSIZE] := n;
	ie (p \= %1 /\ (Symbols[p+SFLAGS] & PROTO)) do
		if (Symbols[p+SSIZE] \= n)
			error("argument count mismatch", Symbols[k+SNAME]);
		Symbols[k+SVAL] := Symbols[p+SVAL];
		Symbols[p+SFLAGS] := 0;
	end
	else do
		Symbols[k+SVAL] := newlab();
	end
	gen1(ICLAB, Symbols[k+SVAL]);
	gen0(IHDR);
	adjust(lv, n);
	if (Debug) do
		for (k=pb, St, SYMLEN) dumpsym(k, 1);
	end
	xrparen();
	rv := stmt();
	cleanup();
	if (\rv) do
		gen1(INUM, 0);
		gen0(IPOP);
	end
	gen1(ICLAB, Exitlab);
	gen0(IEND);
	Exitlab := 0;
end


pproto(linkop) do
	var	k, flgs;

	Token := scan();
	flgs := PROC|PROTO|(linkop->EXTRN:0);
	while (1) do
		if (Token \= SYMBOL) do
			error("symbol expected", 0);
			synch(SEMI); Token := scan();
			return 0;
		end
		k := newsym(Text, 0, 0, flgs);
		Token := scan();
		xlparen();
		Symbols[k+SSIZE] := constval();
		Symbols[k+SVAL] := newlab();
		xrparen();
		if (linkop) do
			gen1(ICLAB, Symbols[k+SVAL]);
			linkage(linkop, Symbols[k+SNAME]);
		end
		if (Token \= COMMA) leave;
		Token := scan();
	end
	xsemi();
end


vardecl(local) do
	var	n, t, k;

	t := Token;
	Token := scan();
	while (1) do
		if (Token \= SYMBOL) do
			error("symbol expected", 0);
			synch(SEMI); Token := scan();
			return 0;
		end
		k := newsym(Text, 0, 0,
			t=KCONST-> CNST: local-> 0 : GLOBAL);
		Token := scan();
		ie (t = KCONST) do
			equsign();
			Symbols[k+SVAL] := constval();
		end
		else do
			if (Token = LBRACK \/ Token = BYTEOP) do
				t := Token;
				Token := scan();
				n := constval();
				ie (t = BYTEOP)
					n := n+1 >> 1;
				else
					match(RBRACK, "missing ']'");
				if (n < 1) error("bad vector size",
					Symbols[k+SNAME]);
				Symbols[k+SSIZE] := n;
			end
			ie (local) do
				Symbols[k+SVAL] := Locladdr;
				if (Symbols[k+SSIZE])
					Symbols[k+SVAL] :=
						Symbols[k+SVAL] +
						Symbols[k+SSIZE]-1;
				Locladdr := Locladdr +
					(Symbols[k+SSIZE]->
					Symbols[k+SSIZE]: 1);
			end
			else do
				Symbols[k+SVAL] := newlab();
				gen1(IDLAB, Symbols[k+SVAL]);
				gen1(IDECL, Symbols[k+SSIZE]);
			end
			if (Debug) dumpsym(k, local);
		end
		if (Token \= COMMA) leave;
		Token := scan();
	end
	xsemi();
end


defstruct() do
	var	base, count;

	Token := scan();
	if (Token \= SYMBOL) do
		error("struct name expected", 0);
		synch(SEMI); Token := scan();
		return 0;
	end
	base := newsym(Text, 0, 0, CNST);
	Token := scan();
	equsign();
	count := 0;
	while (1) do
		if (Token \= SYMBOL) do
			error("member name expected", 0);
			synch(SEMI); Token := scan();
			return 0;
		end
		newsym(Text, 0, count, CNST);
		Token := scan();
		count := count+1;
		if (Token \= COMMA) leave;
		Token := scan();
	end
	Symbols[base+SVAL] := count;
	xsemi();
end


ifacedecl() do
	var	k, slot;

	Token := scan();
	while (1) do
		if (Token \= SYMBOL) do
			error("symbol expected", 0);
			synch(SEMI); Token := scan();
			return 0;
		end
		k := newsym(Text, 0, Bcslot, PROC|IFACE);
		Token := scan();
		xlparen();
		Symbols[k+SSIZE] := constval();
		xrparen();
		if (Token = BINOP /\ Op = Sym_equ) do
			Token := scan();
			slot := constval();
			if (slot < Bcslot)
				error("slot already in use", 0);
			Bcslot := slot;
			Symbols[k+SVAL] := slot;
		end
		Bcslot := Bcslot+1;
		if (Token \= COMMA) leave;
		Token := scan();
	end
	xsemi();
end


declaration(local) do
	var	linkop;

	linkop := 0;
	ie (Token = KPUBLIC) do
		linkop := IPUB;
		Token := scan();
		if (Token \= SYMBOL)
			error("PUBLIC in wrong context", 0);
	end
	else if (Token = KEXTERN) do
		linkop := IEXT;
		Token := scan();
		if (Token \= KDECL)
			error("EXTERN in wrong context", 0);
	end
	ie (Token = KVAR \/ Token = KCONST) do
		vardecl(local);
	end
	else ie (Token = KDECL) do
		pproto(linkop);
	end
	else ie (Token = KSTRUCT) do
		defstruct();
	end
	else ie (Token = SYMBOL) do
		pdecl(linkop);
	end
	else ie (Token = KIFACE) do
		ifacedecl();
	end
	else ie (Token = METAOP) do
		metacmd();
	end
	else do
		error("bad declaration", 0);
		synch(0);
	end
end


external(s, n) do
	newsym(s, n, Bcslot, PROC|IFACE);
	Bcslot := Bcslot+1;
end


initfuncs() do
	external("_open_", 2);
	external("_close_", 1);
	external("_erase_", 1);
	external("_select_", 2);
	external("_reads_", 2);
	external("_writes_", 1);
	external("_newline_", 0);
	external("_aton_", 1);
	external("_ntoa_", 2);
	external("_pack_", 2);
	external("_unpack_", 2);
	newsym("__version__", 0, 305, CNST);
	Sym_equ := findop2("=");
	Sym_sub := findop2("-");
	Sym_mod := findop2("mod");
	Sym_add := findop2("+");
	Sym_mul := findop2("*");
	Sym_bar := findop2("|");
	Sym_not := findop2("~");
end


do
	initvars();
	initfuncs();
	gen2(IINIT, 2, 0);
	gen1(IJUMP, 0);
	gen1(IDATA, 0);
	Token := scan();
	while (	Token = KVAR \/ Token = KCONST \/ Token = SYMBOL \/
		Token = KDECL \/ Token = KSTRUCT \/ Token = KIFACE \/
		Token = KPUBLIC \/ Token = KEXTERN \/ Token = METAOP
	)
		declaration(0);
	if (Token \= KDO) fatal("`DO' or declaration expected", 0);
	gen1(ICLAB, 0);
	gen0(IHDR);
	compound();
	if (Token \= ENDFILE) error("trailing definitions", 0);
	rptdecls();
	gen0(IHALT);
	commit();
	flush();
	if (Errcount) close(open("TXTRN.ERR", 1));
end

