code: purgatorio

ref: 51bcc63cc6bce3f9dab27cf6bd7155512b82c8fa
dir: /appl/alphabet/eval.b/

implement Eval;
include "sys.m";
	sys: Sys;
include "draw.m";
include "sh.m";
	sh: Sh;
	n_BLOCK,  n_VAR, n_BQ, n_BQ2, n_REDIR,
	n_DUP, n_LIST, n_SEQ, n_CONCAT, n_PIPE, n_ADJ,
	n_WORD, n_NOWAIT, n_SQUASH, n_COUNT,
	n_ASSIGN, n_LOCAL: import sh;
include "alphabet/reports.m";
	reports: Reports;
		Report, report: import reports;
include "alphabet.m";

# XXX /usr/inferno/appl/alphabet/eval.b:189: function call type mismatch
# ... a remarkably uninformative error message!

checkload[T](m: T, path: string): T
{
	if(m != nil)
		return m;
	sys->fprint(sys->fildes(2), "eval: cannot load %s: %r\n", path);
	raise "fail:bad module";
}

init()
{
	sys = load Sys Sys->PATH;
	reports = checkload(load Reports Reports->PATH, Reports->PATH);
	sh = checkload(load Sh Sh->PATH, Sh->PATH);
}

WORD, VALUE: con iota;

# to do:
# - change value letters to more appropriate (e.g. fs->f, entries->e, gate->g).
# - allow shell $variable expansions

Evalstate: adt[V, M, C]
	for {
	V =>
		dup:	fn(t: self V): V;
		free:		fn(t: self V, used: int);
		gets:		fn(t: self V): string;
		isstring:	fn(t: self V): int;
		type2s:	fn(tc: int): string;
		typec:	fn(t: self V): int;
	M =>
		find: fn(c: C, s: string): (M, string);
		typesig:	fn(m: self M): string;
		run:		fn(m: self M, c: C,
					errorc: chan of string,
					opts: list of (int, list of V), args: list of V): V;
		mks:		fn(c: C, s: string): V;
		mkc: 	fn(c: C, cmd: ref Sh->Cmd): V;
		typename2c: fn(s: string): int;
		cvt:		fn(c: C, v: V, tc: int, errorc: chan of string): V;
	}
{
	ctxt: C;
	errorc: chan of string;

	expr:	fn(e: self ref Evalstate, c: ref Sh->Cmd, env: Env[V]): V;
	runcmd:	fn(e: self ref Evalstate, cmd: ref Sh->Cmd, arg0: V, args: list of V): V;
	getargs:	fn(e: self ref Evalstate, c: ref Sh->Cmd, env: Env[V]): (ref Sh->Cmd, list of V);
	getvar:	fn(e: self ref Evalstate, c: ref Sh->Cmd, env: Env[V]): V;
};

Env: adt[V]
	for {
	V =>
		free: fn(v: self V, used: int);
		dup:	fn(v: self V): V;
	}
{
	items: array of V;

	new: fn(args: list of V, nilval: V): Env[V];
	get:	fn(t: self Env, id: int): V;
	discard: fn(t: self Env);
};

Context[V, M, Ectxt].eval(expr: ref Sh->Cmd, ctxt: Ectxt, errorc: chan of string,
	args: list of V): V
{
	if(expr == nil){
		discardlist(nil, args);
		return nil;
	}
	nilv: V;
	e := ref Evalstate[V, M, Ectxt](ctxt, errorc);
	{
		return e.runcmd(expr, nilv, args);
	} exception x {
	"error:*" =>
		report(e.errorc, x);
		return nil;
	}
}

Evalstate[V,M,C].expr(e: self ref Evalstate, c: ref Sh->Cmd, env: Env[V]): V
{
	op: ref Sh->Cmd;
	args: list of V;
	arg0: V;
	case c.ntype {
	n_PIPE =>
		if(c.left == nil){
			# N.B. side effect on env.
			arg0 = env.items[0];
			env.items[0] = nil;
			env.items = env.items[1:];
		}else
			arg0 = e.expr(c.left, env);
		{
			(op, args) = e.getargs(c.right, env);
		} exception {
		"error:*" =>
			arg0.free(0);
			raise;
		}
	n_ADJ or
	n_WORD or
	n_BLOCK or
	n_BQ2 =>
		(op, args) = e.getargs(c, env);
	* =>
		raise "error: expected pipe, adj or word, got " + sh->cmd2string(c);
	}

	return e.runcmd(op, arg0, args);
}

# a b c -> adj(adj('a', 'b'), 'c')
Evalstate[V,M,C].getargs(e: self ref Evalstate, c: ref Sh->Cmd, env: Env[V]): (ref Sh->Cmd, list of V)
{
	# do a quick sanity check of module/command-block type
	for(d := c; d.ntype == n_ADJ; d = d.left)
		;
	if(d.ntype != n_WORD && d.ntype != n_BLOCK)
		raise "error: expected word or block, got "+sh->cmd2string(d);
	args: list of V;
	for(; c.ntype == n_ADJ; c = c.left){
		r: V;
		case c.right.ntype {
		n_VAR =>
			r = e.getvar(c.right.left, env);
		n_BLOCK =>
			r = e.expr(c.right.left, env);
		n_WORD =>
			r = M.mks(e.ctxt, deglob(c.right.word));
		n_BQ2 =>
			r = M.mkc(e.ctxt, c.right.left);
		* =>
			discardlist(nil, args);
			raise "error: syntax error: expected var, block or word. got "+sh->cmd2string(c);
		}
		args = r :: args;
	}
	return (c, args);
}
	
Evalstate[V,M,C].getvar(nil: self ref Evalstate, c: ref Sh->Cmd, env: Env[V]): V
{
	if(c == nil || c.ntype != n_WORD)
		raise "error: bad variable name";
	var := deglob(c.word);
	v := env.get(int var);
	if(v == nil)
		raise sys->sprint("error: $%q not defined or cannot be reused", var);
	return v;
}

# get rid of GLOB characters left there by the shell.
deglob(s: string): string
{
	j := 0;
	for (i := 0; i < len s; i++) {
		if (s[i] != Sh->GLOB) {
			if (i != j)		# a worthy optimisation???
				s[j] = s[i];
			j++;
		}
	}
	if (i == j)
		return s;
	return s[0:j];
}

Evalstate[V,M,C].runcmd(e: self ref Evalstate, cmd: ref Sh->Cmd, arg0: V, args: list of V): V
{
	m: M;
	sig: string;
	err: string;
	if(cmd.ntype == n_WORD){
		(m, err) = M.find(e.ctxt, cmd.word);
		if(err != nil){
			discardlist(nil, arg0::args);
			raise sys->sprint("error: cannot load %q: %s", cmd.word, err);
		}
		sig = m.typesig();
	}else{
		(sig, cmd, err) = blocksig0(m, e.ctxt, cmd);
		if(sig == nil){
			discardlist(nil, arg0::args);
			raise sys->sprint("error: invalid command: %s", err);
		}
	}
	ok: int;
	opts: list of (int, list of V);
	x: M;
	(ok, opts, args) = cvtargs(x, e.ctxt, sig, cmd, arg0, args, e.errorc);
	if(ok == -1){
		x: V;
		discardlist(opts, args);
		raise "error: usage: " + sh->cmd2string(cmd)+" "+cmdusage(x, sig);
	}
	if(m != nil){
		r := m.run(e.ctxt, e.errorc, opts, args);
		if(r == nil)
			raise "error: command failed";
		return r;
	}else{
		v: V;	# XXX prevent spurious (?) compiler error message: "type polymorphic type does not have a 'discard' function"
		env := Env[V].new(args, v);
		{
			v = e.expr(cmd, env);
			env.discard();
			return v;
		} exception ex {
		"error:*" =>
			env.discard();
			raise;
		}
	}
}

# {(fd string); walk $2 | merge {unbundle $1}}
blocksig[M, Ectxt](nilm: M, ctxt: Ectxt, e: ref Sh->Cmd): (string, string)
	for{
	M =>
		typename2c: fn(s: string): int;
		find:	fn(c: Ectxt, s: string): (M, string);
		typesig: fn(m: self M): string;
	}
{
	(sig, nil, err) := blocksig0(nilm, ctxt, e);
	return (sig, err);
}

# {(fd string); walk $2 | merge {unbundle $1}}
blocksig0[M, Ectxt](nilm: M, ctxt, e: ref Sh->Cmd): (string, ref Sh->Cmd, string)
	for{
	M =>
		typename2c: fn(s: string): int;
		find:	fn(c: Ectxt, s: string): (M, string);
		typesig: fn(m: self M): string;
	}
{
	if(e == nil || e.ntype != n_BLOCK)
		return (nil, nil, "expected block, got "+sh->cmd2string(e));
	e = e.left;

	
	if(e == nil || e.ntype != n_SEQ || e.left == nil || e.left.ntype != n_LIST){
		(ptc, err) := pipesig(nilm, ctxt, e);
		if(err != nil)
			return (nil, nil, err);
		sig := "a";
		if(ptc != -1)
			sig[len sig] = ptc;
		return (sig, e, nil);
	}

	r := e.right;
	e = e.left.left;
	if(e == nil)
		return ("a", r, nil);
	argt: list of string;
	while(e.ntype == n_ADJ){
		if(e.right.ntype != n_WORD)
			return (nil, nil, "bad declaration: expected word, got "+sh->cmd2string(e.right));
		argt = deglob(e.right.word) :: argt;
		e = e.left;
	}
	if(e.ntype != n_WORD)
		return (nil, nil, "bad declaration: expected word, got "+sh->cmd2string(e));
	argt = e.word :: argt;
	i := 1;
	sig := "a";
	(ptc, err) := pipesig(nilm, ctxt, r);
	if(err != nil)
		return (nil, nil, err);
	if(ptc != -1)
		sig[len sig] = ptc;

	for(a := argt; a != nil; a = tl a){
		tc := M.typename2c(hd a);
		if(tc == -1)
			return (nil, nil, sys->sprint("unknown type %q", hd a));
		sig[len sig] = tc;
		i++;
	}
	return (sig, r, nil);
}

# if e represents an expression with an empty first pipe element,
# return the type of its first argument (-1 if it doesn't).
# string represents error if module doesn't have a first argument.
pipesig[M, Ectxt](nilm: M, ctxt: Ectxt, e: ref Sh->Cmd): (int, string)
	for{
	M =>
		typename2c: fn(s: string): int;
		find:	fn(c: Ectxt, s: string): (M, string);
		typesig: fn(m: self M): string;
	}
{
	if(e == nil)
		return (-1, nil);
	for(; e.ntype == n_PIPE; e = e.left){
		if(e.left == nil){
			# find actual module that's being called.
			for(e = e.right; e.ntype == n_ADJ; e = e.left)
				;
			sig: string;
			if(e.ntype == n_WORD){
				(m, err) := M.find(ctxt, e.word);
				if(m == nil)
					return (-1, err);
				sig = m.typesig();
			}
			else if(e.ntype == n_BLOCK){
				err: string;
				(sig, nil, err) = blocksig0(nilm, ctxt, e);
				if(sig == nil)
					return (-1, err);
			}else
				return (-1, "expected word or block, got "+sh->cmd2string(e));
			if(len sig < 2)
				return (-1, "cannot pipe into "+sh->cmd2string(e));
			return (sig[1], nil);
		}
	}
	return (-1, nil);
}

cvtargs[M,V,C](nil: M, ctxt: C, otype: string, cmd: ref Sh->Cmd, arg0: V, args: list of V, errorc: chan of string): (int, list of (int, list of V), list of V)
	for{
	V =>
		typec: fn(v: self V): int;
		isstring: fn(v: self V): int;
		type2s: fn(tc: int): string;
		gets: fn(v: self V): string;
	M =>
		cvt: fn(c: C, v: V, tc: int, errorc: chan of string): V;
		mks: fn(c: C, s: string): V;
	}
{
	ok: int;
	opts: list of (int, list of V);
	(nil, at, t) := splittype(otype);
	x: M;
	(ok, opts, args) = cvtopts(x, ctxt, t, cmd, args, errorc);
	if(arg0 != nil)
		args = arg0 :: args;
	if(ok == -1)
		return (-1, opts, args);
	if(len at > 0 && at[0] == '*'){
		report(errorc, sys->sprint("error: invalid type descriptor %#q for %s", at, sh->cmd2string(cmd)));
		return (-1, opts, args);
	}
	n := len args;
	if(at != nil && at[len at - 1] == '*'){
		tc := at[len at - 2];
		at = at[0:len at - 2];
		for(i := len at; i < n; i++)
			at[i] = tc;
	}
	if(n != len at){
		report(errorc, sys->sprint("error: wrong number of arguments (%d/%d) to %s", n, len at, sh->cmd2string(cmd)));
		return (-1, opts, args);
	}
	d: list of V;
	(ok, args, d) = cvtvalues(x, ctxt, at, cmd, args, errorc);
	if(ok == -1)
		args = join(args, d);
	return (ok, opts, args);
}

cvtvalues[M,V,C](nil: M, ctxt: C, t: string, cmd: ref Sh->Cmd, args: list of V, errorc: chan of string): (int, list of V, list of V)
	for{
	V =>
		type2s: fn(tc: int): string;
		typec: fn(v: self V): int;
	M =>
		cvt: fn(c: C, v: V, tc: int, errorc: chan of string): V;
	}
{
	cargs: list of V;
	for(i := 0; i < len t; i++){
		tc := t[i];
		if(args == nil){
			report(errorc, sys->sprint("error: missing argument of type %s for %s", V.type2s(tc), sh->cmd2string(cmd)));
			return (-1, cargs, args);
		}
		v := M.cvt(ctxt, hd args, tc, errorc);
		if(v == nil){
			report(errorc, "error: conversion failed for "+sh->cmd2string(cmd));
			return (-1, cargs, tl args);
		}
		cargs = v :: cargs;
		args = tl args;
	}
	return (0, rev(cargs), args);
}

cvtopts[M,V,C](nil: M, ctxt: C, opttype: string, cmd: ref Sh->Cmd, args: list of V, errorc: chan of string): (int, list of (int, list of V), list of V)
	for{
	V =>
		type2s: fn(tc: int): string;
		isstring: fn(v: self V): int;
		typec: fn(v: self V): int;
		gets: fn(v: self V): string;
	M =>
		cvt: fn(c: C, v: V, tc: int, errorc: chan of string): V;
		mks: fn(c: C, s: string): V;
	}
{
	if(opttype == nil)
		return (0, nil, args);
	opts: list of (int, list of V);
getopts:
	while(args != nil){
		s := "";
		if((hd args).isstring()){
			s = (hd args).gets();
			if(s == nil || s[0] != '-' || len s == 1)
				s = nil;
			else if(s == "--"){
				args = tl args;
				s = nil;
			}
		}
		if(s == nil)
			return (0, opts, args);
		s = s[1:];
		while(len s > 0){
			opt := s[0];
			if(((ok, t) := opttypes(opt, opttype)).t0 == -1){
				report(errorc, sys->sprint("error: unknown option -%c for %s", opt, sh->cmd2string(cmd)));
				return (-1, opts, args);
			}
			if(t == nil){
				s = s[1:];
				opts = (opt, nil) :: opts;
			}else{
				if(len s > 1)
					args = M.mks(ctxt, s[1:]) :: tl args;
				else
					args = tl args;
				vl: list of V;
				x: M;
				(ok, vl, args) = cvtvalues(x, ctxt, t, cmd, args, errorc);
				if(ok == -1)
					return (-1, opts, join(vl, args));
				opts = (opt, vl) :: opts;
				continue getopts;
			}
		}
		args = tl args;
	}
	return (0, opts, args);
}

discardlist[V](ol: list of (int, list of V), vl: list of V)
	for{
	V =>
		free: fn(v: self V, used: int);
	}
{
	for(; ol != nil; ol = tl ol)
		for(ovl := (hd ol).t1; ovl != nil; ovl = tl ovl)
			vl = (hd ovl) :: vl;
	for(; vl != nil; vl = tl vl)
		(hd vl).free(0);
}

# true if a module with type sig t1 is compatible with a caller that expects t0
typecompat(t0, t1: string): int
{
	(rt0, at0, ot0) := splittype(t0);
	(rt1, at1, ot1) := splittype(t1);

	if((rt0 != rt1 && rt0 != 'a') || at0 != at1)	# XXX could do better for repeated args.
		return 0;

	for(i := 1; i < len ot0; i++){
		for(j := i; j < len ot0; j++)
			if(ot0[j] == '-')
				break;
		(ok, t) := opttypes(ot0[i], ot1);
		if(ok == -1 || ot0[i+1:j] != t)
			return 0;
		i = j;
	}
	return 1;
}

splittype(t: string): (int, string, string)
{
	if(t == nil)
		return (-1, nil, nil);
	for(i := 1; i < len t; i++)
		if(t[i] == '-')
			break;
	return (t[0], t[1:i], t[i:]);
}

opttypes(opt: int, opts: string): (int, string)
{
	for(i := 1; i < len opts; i++){
		if(opts[i] == opt && opts[i-1] == '-'){
			for(j := i+1; j < len opts; j++)
				if(opts[j] == '-')
					break;
			return (0, opts[i+1:j]);
		}
	}
	return (-1, nil);
}

usage2sig[V](nil: V, u: string): (string, string)
	for{
	V =>
		typename2c: fn(s: string): int;
	}
{
	u[len u] = '\0';

	i := 0;
	t: int;
	tok: string;

	# options
	opts: string;
	for(;;){
		(t, tok, i) = optstok(u, i);
		if(t != '[')
			break;
		o := i;
		(t, tok, i) = optstok(u, i);
		if(t != '-'){
			i = o;
			t = '[';
			break;
		}
		for(j := 0; j < len tok; j++){
			opts[len opts] = '-';
			opts[len opts] = tok[j];
		}
		for(;;){
			(t, tok, i) = optstok(u, i);
			if(t == ']')
				break;
			if(t != 't')
				return (nil, sys->sprint("bad option syntax, got '%c'", t));
			tc := V.typename2c(tok);
			if(tc == -1)
				return (nil, "unknown type: "+tok);
			opts[len opts] = tc;
		}
	}

	# arguments
	args: string;
parseargs:
	for(;;){
		case t {
		'>' =>
			break parseargs;
		'[' =>
			(t, tok, i) = optstok(u, i);
			if(t != 't')
				return (nil, "bad argument syntax");
			tc := V.typename2c(tok);
			if(tc == -1)
				return (nil, "unknown type: "+tok);
			if(((t, nil, i) = optstok(u, i)).t0 != '*')
				return (nil, "bad argument syntax");
			if(((t, nil, i) = optstok(u, i)).t0 != ']')
				return (nil, "bad argument syntax");
			if(((t, nil, i) = optstok(u, i)).t0 != '>')
				return (nil, "bad argument syntax");
			args[len args] = tc;
			args[len args] = '*';
			break parseargs;
		't' =>
			tc := V.typename2c(tok);
			if(tc == -1)
				return (nil, "unknown type: "+tok);
			args[len args] = tc;
			(t, tok, i) = optstok(u, i);
		* =>
			return (nil, "no return type");
		}
	}

	# return type
	(t, tok, i) = optstok(u, i);
	if(t != 't')
		return (nil, "expected return type");
	tc := V.typename2c(tok);
	if(tc == -1)
		return (nil, "unknown type: "+tok);
	r: string;
	r[0] = tc;
	r += args;
	r += opts;
	return (r, nil);
}

optstok(u: string, i: int): (int, string, int)
{
	while(u[i] == ' ')
		i++;
	case u[i] {
	'\0' =>
		return (-1, nil, i);
	'-' =>
		i++;
		if(u[i] == '>')
			return ('>', nil, i+1);
		start := i;
		while((c := u[i]) != '\0'){
			if(c == ']' || c == ' ')
				break;
			i++;
		}
		return ('-', u[start:i], i);
	'[' =>
		return (u[i], nil, i+1);
	']' =>
		return (u[i], nil, i+1);
	'.' =>
		start := i;
		while(u[i] == '.')
			i++;
		if(i - start < 3)
			raise "parse:error at '.'";
		return ('*', nil, i);
	* =>
		start := i;
		while((c := u[i]) != '\0'){
			if(c == ' ' || c == ']' || c == '-' || (c == '.' && u[i+1] == '.'))
				return ('t', u[start:i], i);
			i++;
		}
		return ('t', u[start:i], i);
	}
}

cmdusage[V](nil: V, t: string): string
	for{
	V =>
		type2s: fn(c: int): string;
	}
{
	if(t == nil)
		return "-> bad";
	for(oi := 0; oi < len t; oi++)
		if(t[oi] == '-')
			break;
	s := "";
	if(oi < len t){
		single, multi: string;
		for(i := oi; i < len t - 1;){
			for(j := i + 1; j < len t; j++)
				if(t[j] == '-')
					break;

			optargs := t[i+2:j];
			if(optargs == nil)
				single[len single] = t[i+1];
			else{
				multi += sys->sprint(" [-%c", t[i+1]);
				for (k := 0; k < len optargs; k++)
					multi += " " + V.type2s(optargs[k]);
				multi += "]";
			}
			i = j;
		}
		if(single != nil)
			s += " [-" + single + "]";
		s += multi;
	}
	multi := 0;
	if(oi > 2 && t[oi - 1] == '*'){
		multi = 1;
		oi -= 2;
	}
	for(k := 1; k < oi; k++)
		s += " " + V.type2s(t[k]);
	if(multi)
		s += " [" + V.type2s(t[k]) + "...]";
	s += " -> " + V.type2s(t[0]);
	if(s[0] == ' ')
		s=s[1:];
	return s;
}

Env[V].new(args: list of V, nilval: V): Env[V]
{
	if(args == nil)
		return Env(nil);
	e := Env[V](array[len args] of {* => nilval});
	for(i := 0; args != nil; args = tl args)
		e.items[i++] = hd args;
	return e;
}

Env[V].get(t: self Env, id: int): V
{
	id--;
	if(id < 0 || id >= len t.items)
		return nil;
	x := t.items[id];
	if((y := x.dup()) == nil){
		t.items[id] = nil;
		y = x;
	}
	return y;
}

Env[V].discard(t: self Env)
{
	for(i := 0; i < len t.items; i++)
		t.items[i].free(0);
}

rev[T](x: list of T): list of T
{
	l: list of T;
	for(; x != nil; x = tl x)
		l = hd x :: l;
	return l;
}

# join x to y, leaving result in arbitrary order.
join[T](x, y: list of T): list of T
{
	if(len x > len y)
		(x, y) = (y, x);
	for(; x != nil; x = tl x)
		y = hd x :: y;
	return y;
}