static inline int tinyp(fl_context_t *fl_ctx, value_t v)
{
if (issymbol(v))
return (u8_strwidth(symbol_name(fl_ctx, v)) < SMALL_STR_LEN);
if (fl_isstring(fl_ctx, v))
return (cv_len((cvalue_t*)ptr(v)) < SMALL_STR_LEN);
return (isfixnum(v) || isbuiltin(v) || v==fl_ctx->F || v==fl_ctx->T || v==fl_ctx->NIL ||
v == fl_ctx->FL_EOF);
}
static inline int tinyp(value_t v)
{
if (issymbol(v))
return (u8_strwidth(symbol_name(v)) < SMALL_STR_LEN);
if (fl_isstring(v))
return (cv_len((cvalue_t*)ptr(v)) < SMALL_STR_LEN);
return (isfixnum(v) || isbuiltin(v) || v==FL_F || v==FL_T || v==FL_NIL ||
v == FL_EOF);
}
static action_t cont_apply_apply() {
ref_t func = C(cont)->val[0], args = expr;
ref_t formals = getformals(func);
size_t arity = getarity(func);
C(cont)->closure = getclosure(func);
for(; arity > 0; arity--, formals = cdr(formals), args = cdr(args))
bind(car(formals), car(args));
if (!isnil(formals))
bind(car(formals), args);
init_vals(cont);
if (isbuiltin(func)) {
getfn(func)();
pop_cont();
}
else
eval_do(getbody(func));
return ACTION_APPLY_CONT;
}
void fl_print_child(ios_t *f, value_t v)
{
char *name, *str;
char buf[64];
if (print_level >= 0 && P_LEVEL >= print_level &&
(iscons(v) || isvector(v) || isclosure(v))) {
outc('#', f);
return;
}
P_LEVEL++;
switch (tag(v)) {
case TAG_NUM :
case TAG_NUM1: //HPOS+=ios_printf(f, "%ld", numval(v)); break;
str = uint2str(&buf[1], sizeof(buf)-1, labs(numval(v)), 10);
if (numval(v)<0)
*(--str) = '-';
outs(str, f);
break;
case TAG_SYM:
name = symbol_name(v);
if (print_princ)
outs(name, f);
else if (ismanaged(v)) {
outsn("#:", f, 2);
outs(name, f);
}
else
print_symbol_name(f, name);
break;
case TAG_FUNCTION:
if (v == FL_T) {
outsn("#t", f, 2);
}
else if (v == FL_F) {
outsn("#f", f, 2);
}
else if (v == FL_NIL) {
outsn("()", f, 2);
}
else if (v == FL_EOF) {
outsn("#<eof>", f, 6);
}
else if (isbuiltin(v)) {
if (!print_princ)
outsn("#.", f, 2);
outs(builtin_names[uintval(v)], f);
}
else {
assert(isclosure(v));
if (!print_princ) {
if (print_circle_prefix(f, v)) break;
function_t *fn = (function_t*)ptr(v);
outs("#fn(", f);
char *data = cvalue_data(fn->bcode);
size_t i, sz = cvalue_len(fn->bcode);
for(i=0; i < sz; i++) data[i] += 48;
fl_print_child(f, fn->bcode);
for(i=0; i < sz; i++) data[i] -= 48;
outc(' ', f);
fl_print_child(f, fn->vals);
if (fn->env != NIL) {
outc(' ', f);
fl_print_child(f, fn->env);
}
if (fn->name != LAMBDA) {
outc(' ', f);
fl_print_child(f, fn->name);
}
outc(')', f);
}
else {
outs("#<function>", f);
}
}
break;
case TAG_CVALUE:
case TAG_CPRIM:
if (v == UNBOUND) { outs("#<undefined>", f); break; }
case TAG_VECTOR:
case TAG_CONS:
if (print_circle_prefix(f, v)) break;
if (isvector(v)) {
outc('[', f);
int newindent = HPOS, est;
int i, sz = vector_size(v);
for(i=0; i < sz; i++) {
if (print_length >= 0 && i >= print_length && i < sz-1) {
outsn("...", f, 3);
break;
}
fl_print_child(f, vector_elt(v,i));
if (i < sz-1) {
if (!print_pretty) {
outc(' ', f);
}
else {
est = lengthestimate(vector_elt(v,i+1));
if (HPOS > SCR_WIDTH-4 ||
(est!=-1 && (HPOS+est > SCR_WIDTH-2)) ||
(HPOS > SCR_WIDTH/2 &&
!smallp(vector_elt(v,i+1)) &&
!tinyp(vector_elt(v,i))))
newindent = outindent(newindent, f);
else
outc(' ', f);
}
}
}
outc(']', f);
break;
}
if (iscvalue(v) || iscprim(v))
cvalue_print(f, v);
else
print_pair(f, v);
break;
}
P_LEVEL--;
}
value_t eval_sexpr(value_t e, value_t *penv)
{
value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
value_t *rest;
cons_t *c;
symbol_t *sym;
u_int32_t saveSP;
int i, nargs, noeval=0;
number_t s, n;
eval_top:
if (issymbol(e)) {
sym = (symbol_t*)ptr(e);
if (sym->constant != UNBOUND) return sym->constant;
v = *penv;
while (iscons(v)) {
bind = car_(v);
if (iscons(bind) && car_(bind) == e)
return cdr_(bind);
v = cdr_(v);
}
if ((v = sym->binding) == UNBOUND)
lerror("eval: error: variable %s has no value\n", sym->name);
return v;
}
if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
lerror("eval: error: stack overflow\n");
saveSP = SP;
PUSH(e);
PUSH(*penv);
f = eval(car_(e), penv);
*penv = Stack[saveSP+1];
if (isbuiltin(f)) {
// handle builtin function
if (!isspecial(f)) {
// evaluate argument list, placing arguments on stack
v = Stack[saveSP] = cdr_(Stack[saveSP]);
while (iscons(v)) {
v = eval(car_(v), penv);
*penv = Stack[saveSP+1];
PUSH(v);
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
}
apply_builtin:
nargs = SP - saveSP - 2;
switch (intval(f)) {
// special forms
case F_QUOTE:
v = cdr_(Stack[saveSP]);
if (!iscons(v))
lerror("quote: error: expected argument\n");
v = car_(v);
break;
case F_MACRO:
case F_LAMBDA:
v = Stack[saveSP];
if (*penv != NIL) {
// build a closure (lambda args body . env)
v = cdr_(v);
PUSH(car(v));
argsyms = &Stack[SP-1];
PUSH(car(cdr_(v)));
body = &Stack[SP-1];
v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
cons(argsyms, cons(body, penv)));
}
break;
case F_LABEL:
v = Stack[saveSP];
if (*penv != NIL) {
v = cdr_(v);
PUSH(car(v)); // name
pv = &Stack[SP-1];
PUSH(car(cdr_(v))); // function
body = &Stack[SP-1];
*body = eval(*body, penv); // evaluate lambda
v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
}
break;
case F_IF:
v = car(cdr_(Stack[saveSP]));
if (eval(v, penv) != NIL)
v = car(cdr_(cdr_(Stack[saveSP])));
else
v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
tail_eval(v, Stack[saveSP+1]);
break;
case F_COND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = NIL;
while (iscons(*pv)) {
c = tocons(car_(*pv), "cond");
v = eval(c->car, penv);
*penv = Stack[saveSP+1];
if (v != NIL) {
*pv = cdr_(car_(*pv));
// evaluate body forms
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv), penv);
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
}
*pv = cdr_(*pv);
}
break;
case F_AND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = T;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv), penv)) == NIL) {
SP = saveSP;
return NIL;
}
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
case F_OR:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv), penv)) != NIL) {
SP = saveSP;
return v;
}
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
case F_WHILE:
PUSH(cdr(cdr_(Stack[saveSP])));
body = &Stack[SP-1];
PUSH(*body);
Stack[saveSP] = car_(cdr_(Stack[saveSP]));
value_t *cond = &Stack[saveSP];
PUSH(NIL);
pv = &Stack[SP-1];
while (eval(*cond, penv) != NIL) {
*penv = Stack[saveSP+1];
*body = Stack[SP-2];
while (iscons(*body)) {
*pv = eval(car_(*body), penv);
*penv = Stack[saveSP+1];
*body = cdr_(*body);
}
}
v = *pv;
break;
case F_PROGN:
// return last arg
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv), penv);
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
// ordinary functions
case F_SET:
argcount("set", nargs, 2);
e = Stack[SP-2];
v = *penv;
while (iscons(v)) {
bind = car_(v);
if (iscons(bind) && car_(bind) == e) {
cdr_(bind) = (v=Stack[SP-1]);
SP=saveSP;
return v;
}
v = cdr_(v);
}
tosymbol(e, "set")->binding = (v=Stack[SP-1]);
break;
case F_BOUNDP:
argcount("boundp", nargs, 1);
sym = tosymbol(Stack[SP-1], "boundp");
if (sym->binding == UNBOUND && sym->constant == UNBOUND)
v = NIL;
else
v = T;
break;
case F_EQ:
argcount("eq", nargs, 2);
v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
break;
case F_CONS:
argcount("cons", nargs, 2);
v = mk_cons();
car_(v) = Stack[SP-2];
cdr_(v) = Stack[SP-1];
break;
case F_CAR:
argcount("car", nargs, 1);
v = car(Stack[SP-1]);
break;
case F_CDR:
argcount("cdr", nargs, 1);
v = cdr(Stack[SP-1]);
break;
case F_RPLACA:
argcount("rplaca", nargs, 2);
car(v=Stack[SP-2]) = Stack[SP-1];
break;
case F_RPLACD:
argcount("rplacd", nargs, 2);
cdr(v=Stack[SP-2]) = Stack[SP-1];
break;
case F_ATOM:
argcount("atom", nargs, 1);
v = ((!iscons(Stack[SP-1])) ? T : NIL);
break;
case F_SYMBOLP:
argcount("symbolp", nargs, 1);
v = ((issymbol(Stack[SP-1])) ? T : NIL);
break;
case F_NUMBERP:
argcount("numberp", nargs, 1);
v = ((isnumber(Stack[SP-1])) ? T : NIL);
break;
case F_ADD:
s = 0;
for (i=saveSP+2; i < (int)SP; i++) {
n = tonumber(Stack[i], "+");
s += n;
}
v = number(s);
break;
case F_SUB:
if (nargs < 1)
lerror("-: error: too few arguments\n");
i = saveSP+2;
s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
for (; i < (int)SP; i++) {
n = tonumber(Stack[i], "-");
s -= n;
}
v = number(s);
break;
case F_MUL:
s = 1;
for (i=saveSP+2; i < (int)SP; i++) {
n = tonumber(Stack[i], "*");
s *= n;
}
v = number(s);
break;
case F_DIV:
if (nargs < 1)
lerror("/: error: too few arguments\n");
i = saveSP+2;
s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
for (; i < (int)SP; i++) {
n = tonumber(Stack[i], "/");
if (n == 0)
lerror("/: error: division by zero\n");
s /= n;
}
v = number(s);
break;
case F_LT:
argcount("<", nargs, 2);
if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
v = T;
else
v = NIL;
break;
case F_NOT:
argcount("not", nargs, 1);
v = ((Stack[SP-1] == NIL) ? T : NIL);
break;
case F_EVAL:
argcount("eval", nargs, 1);
v = Stack[SP-1];
tail_eval(v, NIL);
break;
case F_PRINT:
for (i=saveSP+2; i < (int)SP; i++)
print(stdout, v=Stack[i]);
break;
case F_READ:
argcount("read", nargs, 0);
v = read_sexpr(stdin);
break;
case F_LOAD:
argcount("load", nargs, 1);
v = load_file(tosymbol(Stack[SP-1], "load")->name);
break;
case F_PROG1:
// return first arg
if (nargs < 1)
lerror("prog1: error: too few arguments\n");
v = Stack[saveSP+2];
break;
case F_APPLY:
argcount("apply", nargs, 2);
v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
f = Stack[SP-2]; // first arg is new function
POPN(2); // pop apply's args
if (isbuiltin(f)) {
if (isspecial(f))
lerror("apply: error: cannot apply special operator "
"%s\n", builtin_names[intval(f)]);
// unpack arglist onto the stack
while (iscons(v)) {
PUSH(car_(v));
v = cdr_(v);
}
goto apply_builtin;
}
noeval = 1;
goto apply_lambda;
}
SP = saveSP;
return v;
}
else {
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
apply_lambda:
if (iscons(f)) {
headsym = car_(f);
if (headsym == LABEL) {
// (label name (lambda ...)) behaves the same as the lambda
// alone, except with name bound to the whole label expression
labl = f;
f = car(cdr(cdr_(labl)));
headsym = car(f);
}
// apply lambda or macro expression
PUSH(cdr(cdr(cdr_(f))));
lenv = &Stack[SP-1];
PUSH(car_(cdr_(f)));
argsyms = &Stack[SP-1];
PUSH(car_(cdr_(cdr_(f))));
body = &Stack[SP-1];
if (labl) {
// add label binding to environment
PUSH(labl);
PUSH(car_(cdr_(labl)));
*lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
POPN(3);
v = Stack[saveSP]; // refetch arglist
}
if (headsym == MACRO)
noeval = 1;
else if (headsym != LAMBDA)
lerror("apply: error: head must be lambda, macro, or label\n");
// build a calling environment for the lambda
// the environment is the argument binds on top of the captured
// environment
while (iscons(v)) {
// bind args
if (!iscons(*argsyms)) {
if (*argsyms == NIL)
lerror("apply: error: too many arguments\n");
break;
}
asym = car_(*argsyms);
if (!issymbol(asym))
lerror("apply: error: formal argument not a symbol\n");
v = car_(v);
if (!noeval) {
v = eval(v, penv);
*penv = Stack[saveSP+1];
}
PUSH(v);
*lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
POPN(2);
*argsyms = cdr_(*argsyms);
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
if (*argsyms != NIL) {
if (issymbol(*argsyms)) {
if (noeval) {
*lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
}
else {
PUSH(NIL);
PUSH(NIL);
rest = &Stack[SP-1];
// build list of rest arguments
// we have to build it forwards, which is tricky
while (iscons(v)) {
v = eval(car_(v), penv);
*penv = Stack[saveSP+1];
PUSH(v);
v = cons_(&Stack[SP-1], &NIL);
POP();
if (iscons(*rest))
cdr_(*rest) = v;
else
Stack[SP-2] = v;
*rest = v;
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
*lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
}
}
else if (iscons(*argsyms)) {
lerror("apply: error: too few arguments\n");
}
}
noeval = 0;
// macro: evaluate expansion in the calling environment
if (headsym == MACRO) {
SP = saveSP;
PUSH(*lenv);
lenv = &Stack[SP-1];
v = eval(*body, lenv);
tail_eval(v, *penv);
}
else {
tail_eval(*body, *lenv);
}
// not reached
}
type_error("apply", "function", f);
return NIL;
}
lex()
{
int c, d;
char *s;
if (regexflg)
return sym = scanreg();
next:
while ((c = Getc()) == ' ' || c == '\t')
;
while (c == '#')
for (c = Getc(); c != '\n'; c = Getc())
;
switch (c) {
case '\\':
if ((c = Getc()) == '\n') {
lineno++;
goto next;
}
break;
case '\n':
lineno++;
break;
}
switch (c) {
case EOF: return sym = 0;
case '+': return sym = follow2('=', '+', ADDEQ, INC, ADD);
case '-': return sym = follow2('=', '-', SUBEQ, DEC, SUB);
case '*': return sym = follow('=', MULTEQ, MULT);
case '/': return sym = follow('=', DIVEQ, DIV);
case '%': return sym = follow('=', MODEQ, MOD);
case '^': return sym = follow('=', POWEQ, POWER);
case '=': return sym = follow('=', EQ, ASSIGN);
case '!': return sym = follow2('=', '~', NE, NOMATCH, NOT);
case '&': return sym = follow('&', AND, BINAND);
case '|': sym = follow('|', OR, BINOR);
if (printflg && sym == BINOR)
sym = R_POUT;
return sym;
case '<': sym = follow2('=', '<', LE, SHIFTL, LT);
if (getlineflg && sym == LT)
sym = R_IN;
return sym;
case '>': sym = follow2('=', '>', GE, SHIFTR, GT);
if (printflg) {
switch (sym) {
case GT: sym = R_OUT; break;
case SHIFTR: sym = R_APD; break;
}
}
return sym;
case '~': return sym = MATCH; break;
case ';': case '\n': return sym = EOL;
}
if (isalpha(c) || c == '_') {
for (s = text; isalnum(c) || c == '_'; ) {
*s++ = c; c = Getc();
}
Ungetc(c);
*s = '\0';
if ((d = iskeywd(text)) == 0 &&
(d = isbuiltin(text, &sym1)) == 0) {
if (c == '(')
return sym = CALL;
else if (funflg) {
if ((sym1 = isarg(text)) != -1)
return sym = ARG;
}
}
return sym = d ? d : IDENT;
}
else if (c == '.' || (isdigit(c))) {
Ungetc(c);
return sym = scannum(text); /* NUMBER */
}
else if (c == '"')
return sym = scanstr(text); /* STRING */
return sym = c;
}
extern void exec(List *s, bool parent) {
char **av, **ev = NULL;
int pid, stat;
builtin_t *b;
char *path = NULL;
bool didfork, returning, saw_exec, saw_builtin;
av = list2array(s, dashex);
saw_builtin = saw_exec = FALSE;
do {
if (*av == NULL || isabsolute(*av))
b = NULL;
else if (!saw_builtin && fnlookup(*av) != NULL)
b = funcall;
else
b = isbuiltin(*av);
/*
a builtin applies only to the immmediately following
command, e.g., builtin exec echo hi
*/
saw_builtin = FALSE;
if (b == b_exec) {
av++;
saw_exec = TRUE;
parent = FALSE;
} else if (b == b_builtin) {
av++;
saw_builtin = TRUE;
}
} while (b == b_exec || b == b_builtin);
if (*av == NULL && saw_exec) { /* do redirs and return on a null exec */
doredirs();
return;
}
/* force an exit on exec with any rc_error, but not for null commands as above */
if (saw_exec)
rc_pid = -1;
if (b == NULL) {
path = which(*av, TRUE);
if (path == NULL && *av != NULL) { /* perform null commands for redirections */
set(FALSE);
redirq = NULL;
if (parent)
return;
rc_exit(1);
}
ev = makeenv(); /* environment only needs to be built for execve() */
}
/*
If parent & the redirq is nonnull, builtin or not it has to fork.
If the fifoq is nonnull, then it must be emptied at the end so we
must fork no matter what.
*/
if ((parent && (b == NULL || redirq != NULL)) || outstanding_cmdarg()) {
pid = rc_fork();
didfork = TRUE;
} else {
pid = 0;
didfork = FALSE;
}
returning = (!didfork && parent);
switch (pid) {
case -1:
uerror("fork");
rc_error(NULL);
/* NOTREACHED */
case 0:
if (!returning)
setsigdefaults(FALSE);
pop_cmdarg(FALSE);
doredirs();
/* null commands performed for redirections */
if (*av == NULL || b != NULL) {
if (b != NULL)
(*b)(av);
if (returning)
return;
rc_exit(getstatus());
}
execve(path, (char * const *) av, (char * const *) ev);
uerror(*av);
rc_exit(1);
/* NOTREACHED */
default:
redirq = NULL;
rc_wait4(pid, &stat, TRUE);
setstatus(-1, stat);
if ((stat & 0xff) == 0)
nl_on_intr = FALSE;
SIGCHK;
nl_on_intr = TRUE;
pop_cmdarg(TRUE);
}
}
static void b_whatis(char **av) {
bool ess, eff, vee, pee, bee;
bool f, found;
int i, ac, c;
List *s;
Node *n;
char *e;
for (rc_optind = ac = 0; av[ac] != NULL; ac++)
; /* count the arguments for getopt */
ess = eff = vee = pee = bee = FALSE;
while ((c = rc_getopt(ac, av, "sfvpb")) != -1)
switch (c) {
default: set(FALSE); return;
case 's': ess = TRUE; break;
case 'f': eff = TRUE; break;
case 'v': vee = TRUE; break;
case 'p': pee = TRUE; break;
case 'b': bee = TRUE; break;
}
av += rc_optind;
if (*av == NULL) {
if (vee|eff)
whatare_all_vars(eff, vee);
if (ess)
whatare_all_signals();
if (bee)
for (i = 0; i < arraysize(builtins); i++)
fprint(1, "builtin %s\n", builtins[i].name);
if (pee)
fprint(2, "whatis -p: must specify argument\n");
if (show(FALSE)) /* no options? */
whatare_all_vars(TRUE, TRUE);
set(TRUE);
return;
}
found = TRUE;
for (i = 0; av[i] != NULL; i++) {
f = FALSE;
errno = ENOENT;
if (show(vee) && (s = varlookup(av[i])) != NULL) {
f = TRUE;
prettyprint_var(1, av[i], s);
}
if (((show(ess)&&issig(av[i])) || show(eff)) && (n = fnlookup(av[i])) != NULL) {
f = TRUE;
prettyprint_fn(1, av[i], n);
} else if (show(bee) && isbuiltin(av[i]) != NULL) {
f = TRUE;
fprint(1, "builtin %s\n", av[i]);
} else if (show(pee) && (e = which(av[i], FALSE)) != NULL) {
f = TRUE;
fprint(1, "%S\n", e);
}
if (!f) {
found = FALSE;
if (errno != ENOENT)
uerror(av[i]);
else
fprint(2, "%s not found\n", av[i]);
}
}
set(found);
}
