interface	readpacked(3) = 11,
		writepacked(3),
		reposition(4),
		rename(2),
		memcopy(3),
		memcomp(3);

!-------------------- IOSTREAM DEFINITIONS START --------------------!
struct IOS =	IOS_FD,
		IOS_BUFFER,
		IOS_FLAGS,
		IOS_LEN,
		IOS_PTR,
		IOS_END;

const		IOF_READ	= 00001,
		IOF_WRITE	= 00002,
		IOF_EOF		= 00004,
		IOF_LASTW	= 00008;

const		SEEK_SET	= 0,
		SEEK_REL	= 1,
		SEEK_END	= 2;


ios_create(iostream, fd, buffer, len, mode) do
	iostream[IOS_FD] := fd;
	iostream[IOS_BUFFER] := buffer;
	iostream[IOS_FLAGS] := mode;
	iostream[IOS_LEN] := len;
	iostream[IOS_PTR] := 0;
	iostream[IOS_END] := 0;
	return iostream;
end


ios_open(iostream, name, buffer, len, flags) do
	var	fd, mode;

	mode := flags = IOF_READ-> 0:
		flags = IOF_WRITE-> 1:
		flags = IOF_READ|IOF_WRITE-> 2: %1;
	if (mode < 0) return %1;
	fd := open(name, mode);
	if (fd < 0) return %1;
	return ios_create(iostream, fd, buffer, len, flags);
end


ios_flush(iostream) do
	var	k;

	if (	iostream[IOS_FLAGS] & IOF_WRITE /\
		iostream[IOS_FLAGS] & IOF_LASTW /\
		iostream[IOS_PTR]
	) do
		k := writepacked(iostream[IOS_FD], iostream[IOS_BUFFER],
			iostream[IOS_PTR]);
		if (k \= iostream[IOS_PTR]) return %1;
	end
	iostream[IOS_PTR] := 0;
	iostream[IOS_END] := 0;
	return 0;
end


ios_close(iostream) do
	if (ios_flush(iostream) = %1) return %1;
	close(iostream[IOS_FD]);
	iostream[IOS_FLAGS] := 0;
	return 0;
end


ios_wrch(iostream, ch) do
	iostream[IOS_FLAGS] := iostream[IOS_FLAGS] | IOF_LASTW;
	if (	iostream[IOS_PTR] >= iostream[IOS_LEN] /\
		ios_flush(iostream) = %1
	)
		return %1;
	iostream[IOS_BUFFER]::iostream[IOS_PTR] := ch;
	iostream[IOS_PTR] := iostream[IOS_PTR]+1;
	return ch;
end


ios_write(iostream, buffer, len) do
	var	i, p, l, b;

	iostream[IOS_FLAGS] := iostream[IOS_FLAGS] | IOF_LASTW;
	i := 0;
	p := iostream[IOS_PTR];
	l := iostream[IOS_LEN];
	b := iostream[IOS_BUFFER];
	while (len) do
		if (p >= l) do
			iostream[IOS_PTR] := p;
			if (ios_flush(iostream) = %1) return %1;
			p := iostream[IOS_PTR];
			l := iostream[IOS_LEN];
		end
		b::p := buffer::i;
		p := p+1;
		i := i+1;
		len := len-1;
	end
	iostream[IOS_PTR] := p;
	return i;
end


ios_writes(iostream, str) do
	var	k;
	var	b[1024];

	k := 0;
	while (str[k]) k := k+1;
	if (k > 1024) return %1;
	pack(str, b);
	return ios_write(iostream, b, k);
end


ios_more(iostream) do
	var	k;

	if (iostream[IOS_FLAGS] & IOF_READ) do
		k := readpacked(iostream[IOS_FD], iostream[IOS_BUFFER],
			iostream[IOS_LEN]);
		if (k < 0) return %1;
		if (k = 0)
			iostream[IOS_FLAGS] := iostream[IOS_FLAGS] | IOF_EOF;
		iostream[IOS_END] := k;
		iostream[IOS_PTR] := 0;
	end
	return k;
end


ios_rdch(iostream) do
	var	c;

	iostream[IOS_FLAGS] := iostream[IOS_FLAGS] & ~IOF_LASTW;
	if (iostream[IOS_FLAGS] & IOF_EOF) return %1;
	if (	iostream[IOS_PTR] >= iostream[IOS_END] /\
		ios_more(iostream) < 1
	)
		return %1;
	c := iostream[IOS_BUFFER]::iostream[IOS_PTR];
	iostream[IOS_PTR] := iostream[IOS_PTR]+1;
	return c;
end


ios__read(iostream, buffer, len, ckln) do
	var	i, p, e, b;

	iostream[IOS_FLAGS] := iostream[IOS_FLAGS] & ~IOF_LASTW;
	i := 0;
	p := iostream[IOS_PTR];
	e := iostream[IOS_END];
	b := iostream[IOS_BUFFER];
	while (len) do
		if (p >= e) do
			iostream[IOS_PTR] := p;
			if (ios_more(iostream) < 1) leave;
			p := iostream[IOS_PTR];
			e := iostream[IOS_END];
		end
		buffer::i := b::p;
		p := p+1;
		i := i+1;
		len := len-1;
		if (ckln /\ buffer::(i-1) = '\n') leave;
	end
	if (ckln) buffer::i := 0;
	iostream[IOS_PTR] := p;
	iostream[IOS_END] := e;
	return i;
end


ios_read(iostream, buffer, len) return ios__read(iostream, buffer, len, 0);


ios_reads(iostream, buffer, len) return ios__read(iostream, buffer, len, 1);


ios_position(iostream, offh, offl, how) do
	var	delta;

	ie (how = SEEK_REL /\ iostream[IOS_FLAGS] & IOF_LASTW) do
		if (ios_flush(iostream) = %1) return %1;
	end
	else ie (how = SEEK_REL) do
		delta := iostream[IOS_END] - iostream[IOS_PTR];
		if (ios_flush(iostream) = %1) return %1;
		if (offl < delta) offh := offh - 1;
		offl := offl - delta;
	end
	else do
		if (ios_flush(iostream) = %1) return %1;
	end
	return reposition(iostream[IOS_FD], offh, offl, how);
end


ios_rdwrd(s) return ios_rdch(s) | (ios_rdch(s) << 8);


ios_wrwrd(s, w) do
	ios_wrch(s, w & 255);
	ios_wrch(s, w >> 8);
end


ios_eof(iostream) return (iostream[IOS_FLAGS] & IOF_EOF) -> %1: 0;
!-------------------- IOSTREAM DEFINITIONS END --------------------!

!-------------------- DYNAMIC MEMORY DEFINITIONS START --------------------!

const	FREEBIT		= 32768;


mem_init(arena, size) do
	arena[0] := size-1 | FREEBIT;
	arena[size-1] := 0;
end


mem_walk(blk, sizep, statp, start) do
	var	b;

	if (\start) blk := @blk[(blk[%1] & ~FREEBIT) - 1];
	if (sizep) sizep[0] := (blk[0] & ~FREEBIT) - 1;
	if (statp) statp[0] := (blk[0] & FREEBIT) \= 0;
	if (\blk[0]) return 0;
	return @blk[1];
end


mem_alloc(arena, size) do
	var	ap, k;

	size := size+1;
	ap := 0;
	while (arena[ap]) do
		k := arena[ap];
		if (k & FREEBIT) do
			k := k & ~FREEBIT;
			ie (size = k) do
				arena[ap] := k;
				return(@arena[ap+1]);
			end
			else if (size < k) do
				arena[ap] := size;
				arena[ap+size] := k-size | FREEBIT;
				return(@arena[ap+1]);
			end
		end
		ap := ap + (k & ~FREEBIT);
	end
	return 0;
end


mem_free(arena, blk) do
	var	ap, k;
	var	head, tail;

	if (blk[%1] & FREEBIT) do
		select(1, 2);
		writes("mem_free(): bad block"); newline();
		halt;
	end
	blk[%1] := blk[%1] | FREEBIT;
	ap := 0;
	head := %1;
	while (@arena[ap] < blk) do
		ie (arena[ap] & FREEBIT)
			if (head = %1) head := ap;
		else
			head := %1;
		tail := ap;
		ap := ap + (arena[ap] & ~FREEBIT);
	end
	while (arena[ap]) do
		if (\(arena[ap] & FREEBIT)) leave;
		tail := ap;
		ap := ap + (arena[ap] & ~FREEBIT);
	end
	tail := tail + (arena[tail] & ~FREEBIT);
	arena[head] := tail-head | FREEBIT;
end

!-------------------- DYNAMIC MEMORY DEFINITIONS END --------------------!


const	BUFLEN		= 1024;
const	TEXTLEN		= 256;
const	POOLSIZE	= 8192;

var	Infile, __Infile[IOS], Inbuf::BUFLEN;
var	Outfile[IOS], Outbuf::BUFLEN;
var	FileName;
var	Line;
var	Last;
var	Pool[POOLSIZE];
var	Symbols;
var	Errcount;
var	Ignore, Iflevel;

struct	SYMBOL = S_NAME, S_VAL, S_NEXT;


plength(s) do
	var	k;

	k := 0;
	while (s::k) k := k+1;
	return k;
end


pwrites(fd, s) return writepacked(fd, s, plength(s));


pntoa(n) do
	var	s;

	s := ntoa(n,0);
	pack(s, s);
	return s;
end


paton(s) do
	var	v::TEXTLEN;

	unpack(s, v);
	return aton(v);
end


error(m, n) do
	var	o;

	o := select(1, 2);
	pwrites(2, packed"TXPP: ");
	if (FileName) do
		pwrites(2, FileName);
		pwrites(2, packed": ");
	end
	writes(ntoa(Line, 0));
	pwrites(2, packed": ");
	if (n) do
		pwrites(2, n);
		pwrites(2, packed": ");
	end
	pwrites(2, m);
	newline();
	select(1, o);
	Errcount := Errcount+1;
	return 0;
end


fatal(m, n) do
	error(m, n);
	select(1,2);
	pwrites(2, packed"TXPP: terminating.");
	newline();
	if (Errcount) close(open("TXPP.ERR", 1));
	halt;
end


init() do
	if (ios_create(__Infile, 0, Inbuf, BUFLEN, IOF_READ) = %1)
		fatal(packed"cannot create input stream", 0);
	if (ios_create(Outfile, 1, Outbuf, BUFLEN, IOF_WRITE) = %1)
		fatal(packed"cannot create output stream", 0);
	Infile := __Infile;
	FileName := 0;
	Line := 1;
	Last := 0;
	Ignore := 0;
	Iflevel := 0;
	mem_init(Pool, POOLSIZE);
	Symbols := 0;
	Errcount := 0;
end


skip(tonl) do
	var	n, ch;

	ch := Last-> Last: ios_rdch(Infile);
	n := 0;
	while (	ch = '\s' \/ ch = '\t' \/ ch = '\r' \/ ch = '\n' \/
		ch = '\f'
	) do
		if (ch = '\n') do
			if (tonl) return '\n';
			ios_wrch(Outfile, '\n');
			Line := Line+1;
		end
		ch := ios_rdch(Infile);
		n := n+1;
	end
	return ch;
end


next(s, fill) do
	var	ch, n;
	var	dq, cq;

	if (\Ignore /\ fill /\ Last \= '\n') ios_wrch(Outfile, '\s');
	ch := skip(0);
	n := 0;
	dq := 0; cq := 0;
	if (ch = '#') do
		ch := ios_rdch(Infile);
		s::0 := '#'; n := 1;
		while (1) do
			if ('A' <= ch /\ ch <= 'Z') ch := ch+('a'-'A');
			if ((ch < 'a' \/ ch > 'z') /\ ch \= '_') leave;
			if (n >= TEXTLEN-1) do
				error(packed"token too long", 0); leave;
			end
			s::n := ch; n := n+1;
			ch := ios_rdch(Infile);
		end
		s::n := 0;
		Last := ch;
		return 0;
	end
	while (	ch \= '\s' /\ ch \= '\t' /\ ch \= '\r' /\ ch \= '\n' /\
		ch \= '\f' /\ ch \= '#' \/ dq \/ cq
	) do
		if (ch = %1) leave;
		if (ch = '\n' /\ \dq) leave;
		if (dq /\ ch = '\n') Line := Line+1;
		if (n >= TEXTLEN-1) do
			error(packed"token too long", 0); leave;
		end
		if (\cq /\ ch = '"') dq := \dq;
		if (\(dq|cq) /\ ch = ''') do
			s::n := ch; n := n+1;
			ch :=ios_rdch(Infile);
			if (ch = '\\') do
				s::n := ch; n := n+1;
				ch :=ios_rdch(Infile);
			end
			s::n := ch; n := n+1;
			ch :=ios_rdch(Infile);
			if (ch \= ''')
				error(packed"bad character constant", 0);
		end
		if (\dq /\ ch = '!') cq := 1;
		s::n := ch; n := n+1;
		ch :=ios_rdch(Infile);
	end
	Last := ch;
	s::n := 0;
end


rest(s) do
	var	o;

	o := Line;
	next(s, 0);
	if (Line > o) return %1;
	if (	Last = '\s' \/ Last = '\t' \/ Last = '\r' \/
		Last = '\f' \/ Last = '\n'
	)
		Last := skip(1);
	if (Last \= '\n') error(packed"trailing characters", 0);
	return 0;
end


lineinfo(fname, ln) do
	var	pn;

	ios_write(Outfile, packed"#L\s", 3);
	pn := pntoa(ln);
	ios_write(Outfile, pn, plength(pn));
	ios_write(Outfile, packed"\s\q", 2);
	if (fname) ios_write(Outfile, fname, plength(fname));
	ios_write(Outfile, packed"\q;\n", 3);
end


validate(name, silent) do
	var	i;

	i := 0;
	while (name::i) do
		if ('a' <= name::i /\ name::i <= 'z')
			name::i := name::i + 'A' - 'a';
		if ((name::i < 'A' \/ name::i > 'Z') /\ name::i \= '_') do
			if (\silent)
				error(packed"non-letter in name", name);
			return %1;
		end
		i := i+1;
	end
	return 0;
end


findsym(name, ref) do
	var	y, n, k;

	y := ref-> ref[0]: Symbols;
	k := plength(name)+1;
	if (ref) ref[0] := Symbols;
	validate(name, 1);
	while (y) do
		n := y[S_NAME];
		if (n::0 = name::0 /\ \memcomp(n, name, k))
			return y;
		if (ref) ref[0] := @y[S_NEXT];
		y := y[S_NEXT];
	end
	return 0;
end


alloc(n) do
	var	p;

	p := mem_alloc(Pool, n);
	if (\p) fatal(packed"out of dynamic memory", 0);
	return p;
end


cmd_define() do
	var	name::TEXTLEN;
	var	val, __val::TEXTLEN;
	var	sym, k;
	var	i;

	if (Ignore) return 0;
	next(name, 0);
	validate(name, 0);
	if (rest(__val)) do
		error(packed"missing macro text", name);
		return __val;
	end
	val := __val;
	if (val::0 = '"') do
		val := val+1;
		val::(plength(val)-1) := 0;
	end
	i := 0;
	while (val::i) do
		if (val::i = '\n') val::i := '\s';
		i := i+1;
	end
	if (findsym(name, 0)) error(packed"redefined", name);
	sym := alloc(SYMBOL);
	k := plength(name)+1;
	sym[S_NAME] := alloc(k);
	memcopy(sym[S_NAME], name, k);
	k := plength(val)+1;
	sym[S_VAL] := alloc(k);
	memcopy(sym[S_VAL], val, k);
	sym[S_NEXT] := Symbols;
	Symbols := sym;
	return 0;
end


cmd_end() do
	if (\Iflevel) do
		error(packed"unexpected #end", 0); return 0;
	end
	Iflevel := Iflevel-1;
	if (Ignore) Ignore := Ignore-1;
	return 0;
end


cmd_ifeq() do
	var	name::TEXTLEN;
	var	val, __val::TEXTLEN;
	var	sym, k;
	var	i;

	if (Ignore) return 0;
	next(name, 0);
	validate(name, 0);
	if (rest(__val)) do
		error(packed"missing pattern", name);
		return __val;
	end
	val := __val;
	if (val::0 = '"') do
		val := val+1;
		val::(plength(val)-1) := 0;
	end
	sym := findsym(name, 0);
	if (\sym) do
		error(packed"undefined", name);
		return 0;
	end
	k := plength(val)+1;
	if (memcomp(val, sym[S_VAL], k)) Ignore := Ignore+1;
	Iflevel := Iflevel + 1;
	return 0;
end


decl	process(0);
cmd_include() do
	var	fname, __fname::TEXTLEN, uname[TEXTLEN];
	var	oldin, oldname, oldline;
	var	newin[IOS], newbuf::BUFLEN;

	fname := __fname;
	rest(fname);
	if (fname::0 = '"') do
		fname := @fname::1;
		fname::(plength(fname)-1) := 0;
	end
	unpack(fname, uname);
	if (ios_open(newin, uname, newbuf, BUFLEN, IOF_READ) = %1) do
		error(packed"cannot open file", fname);
		ios_wrch(Outfile, '\n');
		return 0;
	end
	lineinfo(fname, 1);
	oldin := Infile;
	oldname := FileName;
	oldline := Line;
	Infile := newin;
	FileName := fname;
	Line := 1;
	Last := 0;
	process();
	ios_close(newin);
	Infile := oldin;
	FileName := oldname;
	Line := oldline;
	lineinfo(FileName, Line);
	Last := 0;
	Line := Line+1;
	return 0;
end


cmd_undef() do
	var	name::TEXTLEN;
	var	y, ref;

	if (Ignore) return 0;
	rest(name);
	validate(name, 0);
	ref := Symbols;
	y := findsym(name, @ref);
	if (\y) return error(packed"undefined", name);
	mem_free(Pool, y[S_NAME]);
	mem_free(Pool, y[S_VAL]);
	ref[0] := y[S_NEXT];
	mem_free(Pool, y);
	return 0;
end


command(s) do
	var	i, c, y;

	i := 1;
	while (s::i) do
		c := s::i;
		if ('A' <= c /\ c <= 'Z') c := c+('a'-'A');
		s::i := c;
		i := i+1;
	end
	if (\memcomp(s, packed"#l", 3)) return s; ! pass through
	if (\memcomp(s, packed"#define", 8)) return cmd_define();
	if (\memcomp(s, packed"#end", 5)) return cmd_end();
	if (\memcomp(s, packed"#ifeq", 6)) return cmd_ifeq();
	if (\memcomp(s, packed"#include", 9)) return cmd_include();
	if (\memcomp(s, packed"#undef", 7)) return cmd_undef();
	y := findsym(@s::1, 0);
	if (\y) return error(packed"undefined", s);
	return y[S_VAL];
end


process() do
	var	nl;
	var	token::TEXTLEN;
	var	s, fill;

	fill := 0;
	while (1) do
		next(token, fill);
		if (ios_eof(Infile)) leave;
		ie (token::0 = '#')
			s := command(token);
		else
			s := token;
		if (\Ignore /\ s) ios_write(Outfile, s, plength(s));
		fill := 1;
	end
end


finish() do
	ios_close(Infile);
	ios_close(Outfile);
end


do
	init();
	process();
	finish();
	if (Errcount) close(open("TXPP.ERR", 1));
end

