src/user/4c.nsc

include "syscalls.nsh";
include "lib.nsh";
 
/*
 * 4c: forthc (a self-hosted forth that jit-compiles straight to raw
 * x86-64 and writes out its own elf) ported to kaboom -- a port of its
 * LANGUAGE, not of its code generator. forthc's whole back half (a
 * hand-rolled rex/modrm encoder, a linux/netbsd syscall abi, elf
 * emission) has nothing to port to: nsc can't emit machine code, and
 * kaboom already has nscc for making real binaries. what's kept is the
 * front half and its structure: tokenize(), then compile() with the
 * same do_* words, the same control stack (cpush/cpop with CK_IF,
 * CK_ELSE, CK_BEGIN, CK_WHILE, CK_DO, CK_COLON) backpatching forward
 * branches the same way, and the same compile-time loop depth -- only
 * compiling into an array of cells instead of machine code, which
 * execute() then runs, in this same process. usage: 4c file.fs. there
 * is no -b flag (forthc needed one for per-os syscall numbers; there
 * is one target here) and no output file.
 *
 * a cell is an op index plus two operands, held in three PARALLEL
 * arrays (cellop/cella/cellb): nsc arrays hold scalars only, so no
 * array of a cell struct. every big table is a plain uninitialized
 * global array -- .bss, zero bytes on disk -- and nothing big lives on
 * the stack (one shared 64kib stack for the whole process, see
 * cat.nsc).
 *
 * every word 4c knows is one entry in ONE runtime-built
 * function-pointer table, fntbl (&f isn't a constant expression, so
 * the init_* functions fill it in at startup). it holds three ranges,
 * in order: the internal ops only compiled code uses (C_LIT..C_LOOP),
 * the compile-time words (: ; if else then ... variable, which
 * compile() runs the moment it reads them, like forthc's do_* calls),
 * and forthc's PRIMS[] (each a void(void) function working directly on
 * the data stack, the way forthc's gen_* work directly on stack
 * memory). a cell's op is an index into fntbl, and execute() is just:
 * fetch a cell, fntbl[op](). the names of the named ranges are one
 * space-separated string (see init_ops), in the same order as the
 * table, which namefind walks.
 *
 * program shape is forthc's own: cells run top to bottom from cell 0
 * and end in bye (forthc's trailing gen_bye); a colon definition is
 * compiled inline where it appears, behind a C_JMP over its body
 * (forthc's do_colon jmp-over), so top-level code never falls into a
 * definition -- a body is only entered by a C_CALL to the start the
 * dictionary recorded for it, and left by its C_RET.
 *
 * deliberate differences from forthc, all where forthc would crash
 * (a fault) rather than behave: data stack underflow/overflow, return
 * stack overflow (forthc calls on the machine stack) and division by
 * zero or min/-1 (forthc's idiv traps) stop with an "err: ..." line on
 * fd 2 and exit status 1. bye can't make an exit syscall (kaboom has
 * none -- returning from main is exiting, see crt.s): it stops the run
 * loop and main returns 0. stdout is line-buffered rather than one
 * write per character. everything else is forthc's behavior, quirks
 * included: true is 1, not -1; do..loop always runs its body once;
 * loop slots are picked by compile-time nesting depth, so a recursive
 * word's do..loop shares one slot across every level; "N constant
 * NAME" works only as that exact 3-token sequence; a word's own name
 * is visible inside its body; the whole file compiles before anything
 * runs, so a compile error prints nothing else.
 *
 * size, and why this doesn't use stdio.nsh/string.nsh: disk.pl caps a
 * binary at 32768 bytes (bumped from its original 30720 -- see
 * mk/disk.pl's own note -- once real trimming still wasn't quite
 * enough), and nscc's code is roomy (every intermediate value gets its
 * own stack slot, never reused, and every call argument costs a slot
 * too, even a fixed 0), so 4c can't afford stdio.o + mem.o + string.o
 * (~12kb, linked whole) next to itself. the handful of things it needs
 * from them -- buffered output, a decimal print, reading a whole file
 * (read_all's own approach: sys_fsize, sys_alloc, read to the end, nul
 * after), a print_err-style message -- are the small
 * out/outs/outnum/readfile/ioerr helpers below. the same budget is why
 * emit/cpush/cexpect each have narrower emit1/emit2/cpush2/cexpect1
 * wrappers for their common fixed-trailing-arg calls (a real, measured
 * win: cutting a 3-arg call down to what it actually varies), why
 * branches that only differ in which constant they emit get merged
 * into one emit call fed by a variable instead, and x = x + 1 rather
 * than x++ (cheaper in nscc's output). splitting a long function into
 * smaller ones and hoisting a repeated global read into a local were
 * both tried and measured WORSE, not better -- left un-done on
 * purpose, not missed.
 */
 
/* fntbl layout: internal ops, then compile-time words, then prims */
enum op { C_LIT, C_STR, C_JZ, C_JMP, C_CALL, C_RET, C_DO, C_I, C_LOOP, FIRST_NAMED };
enum pr { FIRST_PRIM = 23, P_BYE = 57, NWORDS = 59 };
enum ck { CK_NONE, CK_IF, CK_ELSE, CK_BEGIN, CK_WHILE, CK_DO, CK_COLON };
enum dk { DK_WORD, DK_VAR, DK_CONST };
/* the array sizes below have to be spelled as literals; these are the
 * same numbers for the bounds checks. */
enum lim { TOK_MAX = 8192, TXT_MAX = 65536, DICT_MAX = 1024, CTRL_MAX = 256, LOOP_MAX = 32,
	CELL_MAX = 16384, DSTK_MAX = 1024, RSTK_MAX = 1024, VAR_MAX = 1024 };
 
global i64 outfd;
global i8 outbuf[256];
global i64 outlen;
 
global ptr src;
global i64 srclen;
global i64 ti;
global i64 tline;
 
/* tokens: nul-terminated copies packed into toktxt */
global i8 toktxt[65536];
global i64 txtlen;
global ptr tokptr[8192];
global i64 tokline[8192];
global i64 tokisstr[8192];
global i64 ntok;
 
global ptr fntbl[64];
global i64 nfn;
global ptr names;
 
global ptr dname[1024];
global i64 dkind[1024];
global i64 dval[1024];
global i64 ndict;
 
/* compile-time control stack. slot CTRL_MAX is never pushed to and
 * stays all zero: cexpect hands it back after a mismatch, so the
 * caller's backpatch still lands inside the arrays (and the error it
 * already reported stops the compile at the next token). */
global i64 ckind[257];
global i64 cstka[257];
global i64 cstkb[257];
global i64 ctop;
 
global i64 cellop[16384];
global i64 cella[16384];
global i64 cellb[16384];
global i64 ncell;
 
global i64 pos;
global i64 numval;
global i64 varmem[1024];
global i64 varcount;
global i64 loopdepth;
global i64 compiling;
global i64 curword;
 
global i64 dstk[1024];
global i64 dsp;
global i64 rstk[1024];
global i64 rsp;
global i64 loop_idx[32];
global i64 loop_lim[32];
global i64 pc;
global i64 opa;
global i64 opb;
global i64 ra;
global i64 rb;
global i64 halted;
global i64 failed;
 
/* ---- output: one buffer, flushed on newline, to outfd ---- */
 
i64
sb(ptr s, i64 i)
{
	return (i64)ptr_byte_at(s, (u64)i);
}
 
void
flush(void)
{
	if(outlen > 0)
	{
		sys_write((i32)outfd, &outbuf[0], (u64)outlen);
		outlen = 0;
	}
}
 
void
outc(i64 c)
{
	outbuf[outlen] = (i8)c;
	outlen = outlen + 1;
	if((c == 10) | (outlen == 256))
	{
		flush();
	}
}
 
void
outs(ptr s)
{
	i64 i;
 
	i = 0;
	while(sb(s, i) != 0)
	{
		outc(sb(s, i));
		i = i + 1;
	}
}
 
void
outu(u64 u)
{
	if(u >= 10)
	{
		outu(u / 10);
	}
	outc((i64)(u % 10) + '0');
}
 
void
outnum(i64 v)
{
	if(v < 0)
	{
		outc('-');
		outu(~(u64)v + 1);
		return;
	}
	outu((u64)v);
}
 
/* everything after this goes to fd 2 */
void
toerr(void)
{
	flush();
	outfd = 2;
}
 
/* forthc's fail(): the first error wins. there's no exit() to stop
 * at, so callers unwind on failed instead. */
void
fail(ptr msg)
{
	if(failed == 0)
	{
		failed = 1;
		toerr();
		outs("err: ");
		outs(msg);
		outs("\n");
	}
}
 
void
failat(i64 line, ptr t)
{
	failed = 1;
	toerr();
	outs("err: line ");
	outnum(line);
	outs(": undefined word '");
	outs(t);
	outs("'.\n");
}
 
/* a fault while running: report it and stop the run loop */
void
rtfail(ptr msg)
{
	fail(msg);
	halted = 1;
}
 
/* print_err(2, "4c", why), as cat.nsc uses it */
void
ioerr(ptr why)
{
	outfd = 2;
	outs("4c: ");
	if(sys_errno() == 1)
	{
		why = "permission denied";
	}
	outs(why);
	outs("\n");
}
 
/* string equality; a space also ends b, so b can be one word of the
 * names string (a token never holds a space unless it's a ." string,
 * and one of those never equals a name) */
i32
streq(ptr a, ptr b)
{
	i64 i;
	i64 c;
 
	i = 0;
	while(1)
	{
		c = sb(b, i);
		if(c == ' ')
		{
			c = 0;
		}
		if(sb(a, i) != c)
		{
			return 0;
		}
		if(c == 0)
		{
			return 1;
		}
		i = i + 1;
	}
	return 0;
}
 
/* ---- tokenizer: forthc's tokenize, same rules ---- */
 
i64
ch(void)
{
	return sb(src, ti);
}
 
void
step(void)
{
	if(ch() == '\n')
	{
		tline = tline + 1;
	}
	ti = ti + 1;
}
 
/* space, tab, cr, lf -- as a bitmask over the byte values up to 32 */
i32
isws(i64 c)
{
	if(c > 32)
	{
		return 0;
	}
	return (i32)((0x100002600 >> c) & 1);
}
 
void
skipto(i64 stop)
{
	while(1)
	{
		if(ti >= srclen) { break; }
		if(ch() == stop) { break; }
		step();
	}
}
 
i32
tokend(i64 str)
{
	if(str != 0)
	{
		return ch() == '"';
	}
	return isws(ch());
}
 
/* copies the token at ti into toktxt, stopping after 127 bytes --
 * forthc's TOK_LEN - 1 */
void
scan(i64 str)
{
	i64 n;
 
	n = 0;
	while(1)
	{
		if(ti >= srclen) { break; }
		if(tokend(str) != 0) { break; }
		if(n >= 127) { break; }
		toktxt[txtlen] = (i8)ch();
		txtlen = txtlen + 1;
		step();
		n = n + 1;
	}
}
 
void
token(void)
{
	i64 str;
 
	if(ntok == TOK_MAX)
	{
		fail("too many tokens.");
		return;
	}
	if(txtlen > TXT_MAX - 128)
	{
		fail("too many tokens.");
		return;
	}
	str = 0;
	if(ch() == '.')
	{
		if(sb(src, ti + 1) == '"')
		{
			/* ." text" -- one token holding just text */
			str = 1;
			ti = ti + 2;
			if(ch() == ' ')
			{
				ti = ti + 1;
			}
		}
	}
	tokline[ntok] = tline;
	tokisstr[ntok] = str;
	tokptr[ntok] = &toktxt[txtlen];
	scan(str);
	if(ti < srclen)
	{
		if(tokend(str) == 0)
		{
			if(str != 0)
			{
				fail("string literal too long.");
				return;
			}
			fail("token too long.");
			return;
		}
	}
	if(str != 0)
	{
		if(ti >= srclen)
		{
			fail("unterminated string literal.");
			return;
		}
	}
	ti = ti + str; /* past a string's closing quote */
	toktxt[txtlen] = 0;
	txtlen = txtlen + 1;
	ntok = ntok + 1;
}
 
void
tokenize(void)
{
	i64 c;
 
	tline = 1;
	while(1)
	{
		if(ti >= srclen) { break; }
		if(failed != 0) { break; }
		c = ch();
		if(c == '\\')
		{
			skipto('\n');
		}
		else if(c == '(')
		{
			skipto(')');
			ti = ti + 1;
		}
		else if(isws(c) != 0)
		{
			step();
		}
		else
		{
			token();
		}
	}
}
 
/* forthc's isnum: optional '-', then one or more decimal digits. the
 * value lands in numval. */
i32
isnum(ptr s)
{
	i64 i;
	i64 start;
	i64 v;
	i64 d;
 
	i = 0;
	v = 0;
	if(sb(s, 0) == '-')
	{
		i = 1;
	}
	start = i;
	while(sb(s, i) != 0)
	{
		d = sb(s, i) - '0';
		if((u64)d > 9)
		{
			return 0;
		}
		v = v * 10 + d;
		i = i + 1;
	}
	if(i == start)
	{
		return 0;
	}
	if(start != 0)
	{
		v = -v;
	}
	numval = v;
	return 1;
}
 
/* ---- dictionary, control stack, cells ---- */
 
i64
namefind(ptr t)
{
	i64 k;
 
	i64 i;
 
	i = 0;
	k = FIRST_NAMED;
	while(k < NWORDS)
	{
		if(streq(t, names + (u64)i) != 0)
		{
			return k;
		}
		while(sb(names, i) > ' ')
		{
			i = i + 1;
		}
		i = i + 1;
		k = k + 1;
	}
	return -1;
}
 
i64
dictfind(ptr t)
{
	i64 k;
 
	k = ndict - 1;
	while(k >= 0)
	{
		if(streq(dname[k], t) != 0)
		{
			return k;
		}
		k = k - 1;
	}
	return -1;
}
 
void
dictadd(ptr name, i64 kind, i64 val)
{
	if(ndict == DICT_MAX)
	{
		fail("too many words.");
		return;
	}
	if(my_strlen(name) >= 32)
	{
		fail("word name too long.");
		return;
	}
	dname[ndict] = name;
	dkind[ndict] = kind;
	dval[ndict] = val;
	ndict = ndict + 1;
}
 
void
cpush(i64 kind, i64 a, i64 b)
{
	if(ctop == CTRL_MAX)
	{
		fail("control stack overflow.");
		return;
	}
	ckind[ctop] = kind;
	cstka[ctop] = a;
	cstkb[ctop] = b;
	ctop = ctop + 1;
}
 
void
cpush2(i64 kind, i64 a)
{
	cpush(kind, a, 0);
}
 
/* forthc's cpop, plus the kind check every one of its callers makes */
i64
cexpect(i64 k1, i64 k2, ptr msg)
{
	if(ctop == 0)
	{
		fail("unbalanced control structure.");
		return CTRL_MAX;
	}
	ctop = ctop - 1;
	if(ckind[ctop] != k1)
	{
	if(ckind[ctop] != k2)
	{
		fail(msg);
		return CTRL_MAX;
	}
	}
	return ctop;
}
 
/* the common k1==k2 case of cexpect */
i64
cexpect1(i64 k, ptr msg)
{
	return cexpect(k, k, msg);
}
 
i64
emit(i64 op, i64 a, i64 b)
{
	if(ncell == CELL_MAX)
	{
		fail("program too large.");
		return 0;
	}
	cellop[ncell] = op;
	cella[ncell] = a;
	cellb[ncell] = b;
	ncell = ncell + 1;
	return ncell - 1;
}
 
/* narrower-arity wrappers: nscc materializes every call argument
 * through its own stack slot, so a fixed 0 argument costs as much as
 * a real one -- these two cut the common (op,0,0)/(op,a,0) emit()
 * calls down to what they actually vary. */
i64
emit1(i64 op)
{
	return emit(op, 0, 0);
}
 
i64
emit2(i64 op, i64 a)
{
	return emit(op, a, 0);
}
 
/* forthc's i_patchhere: aim the branch at cell p at "here" */
void
patchhere(i64 p)
{
	cella[p] = ncell;
}
 
/* ---- compile-time words: forthc's do_* ---- */
 
void
do_if(void)
{
	cpush2(CK_IF, emit1(C_JZ));
}
 
void
do_else(void)
{
	i64 e;
	i64 p;
 
	e = cexpect1(CK_IF, "else without matching if.");
	p = emit1(C_JMP);
	patchhere(cstka[e]);
	cpush2(CK_ELSE, p);
}
 
void
do_then(void)
{
	patchhere(cstka[cexpect(CK_IF, CK_ELSE, "then without matching if.")]);
}
 
void
do_begin(void)
{
	cpush2(CK_BEGIN, ncell);
}
 
void
do_until(void)
{
	emit2(C_JZ, cstka[cexpect1(CK_BEGIN, "until without matching begin.")]);
}
 
void
do_while(void)
{
	i64 e;
 
	e = cexpect1(CK_BEGIN, "while without matching begin.");
	cpush(CK_WHILE, cstka[e], emit1(C_JZ));
}
 
void
do_repeat(void)
{
	i64 e;
 
	e = cexpect1(CK_WHILE, "repeat without matching while.");
	emit2(C_JMP, cstka[e]);
	patchhere(cstkb[e]);
}
 
/* the loop slot is picked HERE, by nesting depth (forthc's
 * loopidxaddr(loopdepth)), and baked into the cell */
void
do_do(void)
{
	if(loopdepth == LOOP_MAX)
	{
		fail("do loops nested too deeply.");
		return;
	}
	emit2(C_DO, loopdepth);
	cpush(CK_DO, ncell, loopdepth);
	loopdepth = loopdepth + 1;
}
 
void
do_i(void)
{
	i64 k;
 
	k = ctop - 1;
	while(k >= 0)
	{
		if(ckind[k] == CK_DO)
		{
			emit2(C_I, cstkb[k]);
			return;
		}
		k = k - 1;
	}
	fail("i used outside do loop.");
}
 
void
do_loop(void)
{
	i64 e;
 
	e = cexpect1(CK_DO, "loop without matching do.");
	emit(C_LOOP, cstkb[e], cstka[e]);
	loopdepth = loopdepth - 1;
}
 
void
do_colon(void)
{
	i64 p;
 
	if(pos >= ntok)
	{
		fail("colon needs a name.");
		return;
	}
	if(compiling != 0)
	{
		fail("nested colon definition.");
		return;
	}
	p = emit1(C_JMP);
	dictadd(tokptr[pos], DK_WORD, ncell);
	pos = pos + 1;
	cpush(CK_COLON, p, ncell);
	compiling = 1;
	curword = ncell;
}
 
void
do_semi(void)
{
	i64 e;
 
	e = cexpect1(CK_COLON, "semicolon without matching colon.");
	emit1(C_RET);
	patchhere(cstka[e]);
	compiling = 0;
}
 
void
do_recurse(void)
{
	if(compiling == 0)
	{
		fail("recurse outside colon definition.");
		return;
	}
	emit2(C_CALL, curword);
}
 
void
do_variable(void)
{
	if(pos >= ntok)
	{
		fail("variable needs a name.");
		return;
	}
	if(varcount == VAR_MAX)
	{
		fail("too many variables.");
		return;
	}
	dictadd(tokptr[pos], DK_VAR, (i64)&varmem[varcount]);
	pos = pos + 1;
	varcount = varcount + 1;
}
 
/* ---- internal ops: what compiled code runs besides the prims ---- */
 
void
push(i64 v)
{
	if(dsp == DSTK_MAX)
	{
		rtfail("stack overflow.");
		return;
	}
	dstk[dsp] = v;
	dsp = dsp + 1;
}
 
i64
pop(void)
{
	if(dsp == 0)
	{
		rtfail("stack underflow.");
		return 0;
	}
	dsp = dsp - 1;
	return dstk[dsp];
}
 
void
op_lit(void)
{
	push(opa);
}
 
void
op_str(void)
{
	outs((ptr)opa);
}
 
void
op_jz(void)
{
	if(pop() == 0) { pc = opa; }
}
 
void
op_jmp(void)
{
	pc = opa;
}
 
void
op_call(void)
{
	if(rsp == RSTK_MAX)
	{
		rtfail("return stack overflow.");
		return;
	}
	rstk[rsp] = pc;
	rsp = rsp + 1;
	pc = opa;
}
 
void
op_ret(void)
{
	rsp = rsp - 1;
	pc = rstk[rsp];
}
 
/* top of stack is the start index, under it the limit */
void
op_do(void)
{
	loop_idx[opa] = pop();
	loop_lim[opa] = pop();
}
 
void
op_i(void)
{
	push(loop_idx[opa]);
}
 
void
op_loop(void)
{
	loop_idx[opa] = loop_idx[opa] + 1;
	if(loop_idx[opa] < loop_lim[opa])
	{
		pc = opb;
	}
}
 
/* ---- prims: forthc's gen_*, as functions on the data stack ---- */
 
/* the two operands of a binary word: ra is the deeper one */
void
pop2(void)
{
	rb = pop();
	ra = pop();
}
 
void
p_add(void)
{
	pop2();
	push(ra + rb);
}
 
void
p_sub(void)
{
	pop2();
	push(ra - rb);
}
 
void
p_mul(void)
{
	pop2();
	push(ra * rb);
}
 
/* forthc's gen_divmod is idiv: truncates toward zero, remainder takes
 * the dividend's sign. its two traps are errors here instead. */
i32
divok(void)
{
	pop2();
	if(rb == 0)
	{
		rtfail("division by zero.");
	}
	if(rb == -1)
	{
	if(ra == -0x7fffffffffffffff - 1)
	{
		rtfail("division overflow.");
	}
	}
	return failed == 0;
}
 
void
p_div(void)
{
	if(divok() != 0) { push(ra / rb); }
}
 
void
p_mod(void)
{
	if(divok() != 0) { push(ra % rb); }
}
 
void
p_dup(void)
{
	ra = pop();
	push(ra);
	push(ra);
}
 
void
p_drop(void)
{
	pop();
}
 
void
p_swap(void)
{
	pop2();
	push(rb);
	push(ra);
}
 
void
p_over(void)
{
	pop2();
	push(ra);
	push(rb);
	push(ra);
}
 
void
p_rot(void)
{
	i64 c;
 
	c = pop();
	pop2();
	push(rb);
	push(c);
	push(ra);
}
 
void
p_nip(void)
{
	pop2();
	push(rb);
}
 
/* flags are 1 or 0 -- forthc's true is 1, not -1 */
void
p_eq(void)
{
	pop2();
	push((i64)(ra == rb));
}
 
void
p_ne(void)
{
	pop2();
	push((i64)(ra != rb));
}
 
void
p_lt(void)
{
	pop2();
	push((i64)(ra < rb));
}
 
void
p_gt(void)
{
	pop2();
	push((i64)(ra > rb));
}
 
void
p_le(void)
{
	pop2();
	push((i64)(ra <= rb));
}
 
void
p_ge(void)
{
	pop2();
	push((i64)(ra >= rb));
}
 
void
p_zeq(void)
{
	push((i64)(pop() == 0));
}
 
void
p_zlt(void)
{
	push((i64)(pop() < 0));
}
 
void
p_and(void)
{
	pop2();
	push(ra & rb);
}
 
void
p_or(void)
{
	pop2();
	push(ra | rb);
}
 
void
p_xor(void)
{
	pop2();
	push(ra ^ rb);
}
 
void
p_invert(void)
{
	push(~pop());
}
 
void
p_negate(void)
{
	push(-pop());
}
 
void
p_inc(void)
{
	push(pop() + 1);
}
 
void
p_dec(void)
{
	push(pop() - 1);
}
 
/* addresses are real ones (a variable pushes &varmem[k]), so @ ! +!
 * are plain 8-byte loads and stores, same as forthc's. the failed
 * checks keep an underflow's stand-in 0 from being used as an address
 * (or printed) after the error. */
void
p_fetch(void)
{
	ra = pop();
	if(failed == 0) { push(*(ptr)ra); }
}
 
void
p_store(void)
{
	pop2();
	if(failed == 0) { *(ptr)rb = ra; }
}
 
void
p_plusstore(void)
{
	pop2();
	if(failed == 0) { *(ptr)rb = *(ptr)rb + ra; }
}
 
void
p_emit(void)
{
	ra = pop();
	if(failed == 0) { outc(ra & 255); }
}
 
void
p_dot(void)
{
	ra = pop();
	if(failed == 0) { outnum(ra); outc(' '); }
}
 
void
p_cr(void)
{
	outc('\n');
}
 
void
p_space(void)
{
	outc(' ');
}
 
void
p_true(void)
{
	push(1);
}
 
void
p_false(void)
{
	push(0);
}
 
void
p_bye(void)
{
	halted = 1;
}
 
/* ---- the word table ---- */
 
void
r(ptr fn)
{
	fntbl[nfn] = fn;
	nfn = nfn + 1;
}
 
/* the names of fntbl[FIRST_NAMED..], in table order: the r() calls
 * in init_ctl/init_prims* are in this same order, and the prims are
 * forthc's PRIMS[] order */
void
init_ops(void)
{
	names = ": ; if else then begin until while repeat do loop i recurse variable + - * / mod dup drop swap over rot = <> < > <= >= 0= 0< and or xor invert negate 1+ 1- @ ! +! emit . cr space true false bye nip";
	r(&op_lit); r(&op_str); r(&op_jz); r(&op_jmp); r(&op_call);
	r(&op_ret); r(&op_do); r(&op_i); r(&op_loop);
}
 
void
init_ctl(void)
{
	r(&do_colon); r(&do_semi); r(&do_if); r(&do_else); r(&do_then);
	r(&do_begin); r(&do_until); r(&do_while); r(&do_repeat); r(&do_do);
	r(&do_loop); r(&do_i); r(&do_recurse); r(&do_variable);
}
 
void
init_prims1(void)
{
	r(&p_add); r(&p_sub); r(&p_mul); r(&p_div); r(&p_mod);
	r(&p_dup); r(&p_drop); r(&p_swap); r(&p_over); r(&p_rot);
	r(&p_eq); r(&p_ne); r(&p_lt); r(&p_gt); r(&p_le); r(&p_ge);
	r(&p_zeq); r(&p_zlt);
}
 
void
init_prims2(void)
{
	r(&p_and); r(&p_or); r(&p_xor); r(&p_invert); r(&p_negate);
	r(&p_inc); r(&p_dec);
	r(&p_fetch); r(&p_store); r(&p_plusstore);
	r(&p_emit); r(&p_dot); r(&p_cr); r(&p_space);
	r(&p_true); r(&p_false); r(&p_bye);
	r(&p_nip);
}
 
/* ---- compile: forthc's compile(), token for token ---- */
 
/* a number: a literal, or the start of "N constant NAME" */
void
compile_num(void)
{
	if(pos < ntok)
	{
	if(streq(tokptr[pos], "constant") != 0)
	{
		if(pos + 1 >= ntok)
		{
			fail("constant needs a name.");
			return;
		}
		dictadd(tokptr[pos + 1], DK_CONST, numval);
		pos = pos + 2;
		return;
	}
	}
	emit2(C_LIT, numval);
}
 
/* a defined word: a call, or a variable's address / constant's value */
void
compile_dict(ptr t)
{
	i64 k;
	i64 op;
 
	k = dictfind(t);
	if(k < 0)
	{
		failat(tokline[pos - 1], t);
		return;
	}
	op = C_LIT;
	if(dkind[k] == DK_WORD)
	{
		op = C_CALL;
	}
	emit2(op, dval[k]);
}
 
void
compile_tok(void)
{
	ptr t;
	i64 k;
 
	t = tokptr[pos];
	pos = pos + 1;
	if(tokisstr[pos - 1] != 0)
	{
		emit2(C_STR, (i64)t);
		return;
	}
	if(isnum(t) != 0)
	{
		compile_num();
		return;
	}
	k = namefind(t);
	if(k >= FIRST_PRIM)
	{
		emit1(k);
		return;
	}
	if(k >= 0)
	{
		fntbl[k](); /* a compile-time word runs now */
		return;
	}
	compile_dict(t);
}
 
void
compile(void)
{
	while(1)
	{
		if(pos >= ntok) { break; }
		if(failed != 0) { break; }
		compile_tok();
	}
	if(failed != 0)
	{
		return;
	}
	if(compiling != 0)
	{
		fail("unterminated colon definition.");
		return;
	}
	if(ctop != 0)
	{
		fail("unterminated control structure.");
		return;
	}
	emit1(P_BYE); /* forthc's trailing gen_bye */
}
 
/* ---- execute: run cells from 0 until bye ---- */
 
void
execute(void)
{
	i64 op;
 
	while(halted == 0)
	{
		op = cellop[pc];
		opa = cella[pc];
		opb = cellb[pc];
		pc = pc + 1;
		fntbl[op]();
	}
}
 
/* read_all's approach: the whole file, sized by sys_fsize, into one
 * sys_alloc'd buffer with 8 spare bytes, nul-terminated at srclen */
ptr
readfile(i32 fd)
{
	ptr buf;
	i64 got;
	i64 n;
 
	srclen = sys_fsize(fd);
	if(srclen < 0)
	{
		return (ptr)0;
	}
	buf = sys_alloc((u64)srclen + 8);
	if(buf == (ptr)0)
	{
		return buf;
	}
	*(buf + (u64)srclen) = 0;
	got = 0;
	while(got < srclen)
	{
		n = sys_read(fd, buf + (u64)got, (u64)(srclen - got));
		if(n <= 0)
		{
			return (ptr)0;
		}
		got = got + n;
	}
	return buf;
}
 
global i32
main(i32 argc, ptr argv)
{
	ptr fname;
	i32 fd;
 
	outfd = 1;
	if(argc < 2)
	{
		outfd = 2;
		outs("usage: 4c file.fs\n");
		return 1;
	}
 
	fname = argv_get(argv, 1);
	fd = sys_open(fname, my_strlen(fname));
	if(fd < 0)
	{
		ioerr("file not found");
		return 1;
	}
 
	src = readfile(fd);
	sys_close(fd);
	if(src == (ptr)0)
	{
		ioerr("read failed");
		return 1;
	}
 
	init_ops();
	init_ctl();
	init_prims1();
	init_prims2();
	tokenize();
	if(failed == 0)
	{
		compile();
	}
	if(failed == 0)
	{
		execute();
	}
	flush();
	return (i32)failed;
}