// Evaluates the S expression.
static Obj *eval(void *root, Obj **env, Obj **obj) {
switch ((*obj)->type) {
case TINT:
case TPRIMITIVE:
case TFUNCTION:
case TTRUE:
case TNIL:
// Self-evaluating objects
return *obj;
case TSYMBOL: {
// Variable
Obj *bind = find(env, *obj);
if (!bind)
error("Undefined symbol: %s", (*obj)->name);
return bind->cdr;
}
case TCELL: {
// Function application form
DEFINE3(fn, expanded, args);
*expanded = macroexpand(root, env, obj);
if (*expanded != *obj)
return eval(root, env, expanded);
*fn = (*obj)->car;
*fn = eval(root, env, fn);
*args = (*obj)->cdr;
if ((*fn)->type != TPRIMITIVE && (*fn)->type != TFUNCTION)
error("The head of a list must be a function");
return apply(root, env, fn, args);
}
default:
error("Bug: eval: Unknown tag type: %d", (*obj)->type);
return 0;
}
}
// (macroexpand expr)
static Obj *prim_macroexpand(void *root, Obj **env, Obj **list) {
if (length(*list) != 1)
error("Malformed macroexpand");
DEFINE1(body);
*body = (*list)->car;
return macroexpand(root, env, body);
}
Obj *eval(Env *env, Obj *root, Obj **obj) {
if ((*obj)->type == TINT || (*obj)->type == TSTRING ||
(*obj)->type == TPRIMITIVE || (*obj)->type == TFUNCTION ||
(*obj)->type == TSPE)
return *obj;
if ((*obj)->type == TCELL) {
VAR(fn);
VAR(car);
VAR(args);
*car = (*obj)->car;
*args = (*obj)->cdr;
*fn = eval(env, root, car);
if ((*fn)->type == TMACRO) {
VAR(macro);
*macro = macroexpand(env, root, obj);
return eval(env, root, macro);
}else if ((*fn)->type != TPRIMITIVE && (*fn)->type != TFUNCTION){
error("Car must be a function");
}else
return apply(env, root, fn, args);
}
if ((*obj)->type == TSYMBOL) {
Obj *val = find((*obj)->name, env);
if (!val)
error("undefined symbol: %s", (*obj)->name);
return val->cdr;
}
error("BUG: eval: Unknown tag type: %d", (*obj)->type);
return NULL;
}
Obj *prim_macroexpand(Env *env, Obj *root, Obj **list) {
if (list_length(*list) != 1)
error("malformed macroexpand");
VAR(body);
*body = (*list)->car;
return macroexpand(env, root, body);
}
static ciapos_sexp ciapos_vm_eval_withstack(ciapos_vm *self, ciapos_sexp stack, ciapos_sexp expr) {
expr = macroexpand(self, expr);
switch (expr.tag) {
case CIAPOS_TAGNIL: case CIAPOS_TAGINT: case CIAPOS_TAGREAL: case CIAPOS_TAGSTR: case CIAPOS_TAGOPAQUE:
case CIAPOS_TAGFN: return expr;
case CIAPOS_TAGSYM: return lookup(stack, expr.symbol);
case CIAPOS_TAGTUP: default:
assert(expr.tuple->length == 2);
ciapos_sexp fexpr = ciapos_tuple_get(expr, 0);
if (fexpr.tag == CIAPOS_TAGSYM) {
if (fexpr.symbol == ciapos_symbolof(&self->registry, "std:quote")) {
ciapos_sexp args = ciapos_tuple_get(expr, 1);
assert(args.tag == CIAPOS_TAGTUP);
assert(args.tuple->length == 2);
assert(ciapos_tuple_get(args, 1).tag == CIAPOS_TAGNIL);
return ciapos_tuple_get(args, 0);
}
if (fexpr.symbol == ciapos_symbolof(&self->registry, "std:lambda")) {
ciapos_sexp args = ciapos_tuple_get(expr, 1);
return parsefn(self, stack, args);
}
if (fexpr.symbol == ciapos_symbolof(&self->registry, "std:env")) {
assert(ciapos_tuple_get(expr, 1).tag == CIAPOS_TAGNIL);
return stack;
}
}
ciapos_sexp function = ciapos_vm_eval_withstack(self, stack, fexpr);
assert(function.tag == CIAPOS_TAGFN);
ciapos_sexp args = eval_args(self, stack, ciapos_tuple_get(expr, 1));
return ciapos_function_eval(function, self, args);
}
}
/* xlexpandmacros - expand macros in a form */
LVAL xlexpandmacros(LVAL form)
{
LVAL fun,args;
/* protect some pointers */
xlstkcheck(3);
xlprotect(form);
xlsave(fun);
xlsave(args);
/* expand until the form isn't a macro call */
while (consp(form)) {
fun = car(form); /* get the macro name */
args = cdr(form); /* get the arguments */
if (!symbolp(fun) || !fboundp(fun))
break;
fun = xlgetfunction(fun); /* get the expansion function */
if (!macroexpand(fun,args,&form))
break;
}
/* restore the stack and return the expansion */
xlpopn(3);
return (form);
}
/* x1macroexpand - expand a macro call */
LVAL x1macroexpand(void)
{
LVAL form,fun,args;
/* protect some pointers */
xlstkcheck(2);
xlsave(fun);
xlsave(args);
/* get the form */
form = xlgetarg();
xllastarg();
/* expand until the form isn't a macro call */
if (consp(form)) {
fun = car(form); /* get the macro name */
args = cdr(form); /* get the arguments */
if (symbolp(fun) && fboundp(fun)) {
fun = xlgetfunction(fun); /* get the expansion function */
macroexpand(fun,args,&form);
}
}
/* restore the stack and return the expansion */
xlpopn(2);
return (form);
}
VALUE* eval_string(char *prog_str, NODE *static_scope, NODE *macro_map) {
NODE *prog = parseForms(prog_str);
debugVal(prog,"before macroexpand: ");
prog = (NODE*)macroexpand(prog,static_scope,macro_map);
debugVal(prog,"after macroexpand: ");
VALUE *val = evaluate((VALUE*)prog,static_scope);
decRef(prog);
return val;
}
static ciapos_sexp expand_subexpr(ciapos_vm *self, ciapos_sexp expr) {
ciapos_sexp newexpr = ciapos_mktuple(&self->top_of_heap, expr.tuple->length);
newexpr.debug_info = expr.debug_info;
ptrdiff_t i;
for (i = 0; i < expr.tuple->length - 1; i++) {
if (ciapos_tuple_get(expr, i).tag == CIAPOS_TAGTUP) {
ciapos_tuple_put(newexpr, i, macroexpand(self, ciapos_tuple_get(expr, i)));
} else {
ciapos_tuple_put(newexpr, i, ciapos_tuple_get(expr, i));
}
}
if (ciapos_tuple_get(expr, i).tag == CIAPOS_TAGTUP) {
ciapos_tuple_put(newexpr, i, expand_subexpr(self, ciapos_tuple_get(expr, i)));
} else {
ciapos_tuple_put(newexpr, i, ciapos_tuple_get(expr, i));
}
return newexpr;
}
void do_repl(Env *env, Obj *root)
{
VAR(sexp);
VAR(expanded);
for (;;) {
char *line = readline("minilisp> ");
char *p = line;
if (!line) break;
*sexp = read(env, root, &p);
add_history(line);
free(line);
if (!*sexp) continue;
*expanded = macroexpand(env, root, sexp);
print(eval(env, root, expanded));
printf("\n");
}
}
void eval_file(Env *env, Obj *root, char *fname)
{
static char buf[BUFSIZE * 100]; /* about 100 lines of lisp code */
FILE *fp = fopen(fname, "r");
if (!fp) error("no such file");
VAR(sexp);
VAR(expanded);
fread(buf, sizeof(buf), 1, fp);
fclose(fp);
char *p = buf;
while (*p) {
*sexp = read(env, root, &p);
if (!*sexp) error("cannot load lisp program");
*expanded = macroexpand(env, root, sexp);
eval(env, root, expanded);
}
}
/* evform - evaluate a form */
LOCAL LVAL evform(LVAL form)
{
LVAL fun,args,val,type;
LVAL tracing=NIL;
LVAL *argv;
LVAL old_profile_fixnum = profile_fixnum;
FIXTYPE *old_profile_count_ptr = profile_count_ptr;
LVAL funname;
int argc;
/* protect some pointers */
xlstkcheck(2);
xlsave(fun);
xlsave(args);
(*profile_count_ptr)++; /* increment profile counter */
/* get the function and the argument list */
fun = car(form);
args = cdr(form);
funname = fun;
/* get the functional value of symbols */
if (symbolp(fun)) {
if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
tracing = fun;
fun = xlgetfunction(fun);
}
/* check for nil */
if (null(fun))
xlerror("bad function",NIL);
/* dispatch on node type */
switch (ntype(fun)) {
case SUBR:
argv = xlargv;
argc = xlargc;
xlargc = evpushargs(fun,args);
xlargv = xlfp + 3;
trenter(tracing,xlargc,xlargv);
val = (*getsubr(fun))();
trexit(tracing,val);
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
xlargv = argv;
xlargc = argc;
break;
case FSUBR:
argv = xlargv;
argc = xlargc;
xlargc = pushargs(fun,args);
xlargv = xlfp + 3;
val = (*getsubr(fun))();
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
xlargv = argv;
xlargc = argc;
break;
case CONS:
if (!consp(cdr(fun)))
xlerror("bad function",fun);
if ((type = car(fun)) == s_lambda)
fun = xlclose(NIL,
s_lambda,
car(cdr(fun)),
cdr(cdr(fun)),
xlenv,xlfenv);
else
xlerror("bad function",fun);
/**** fall through into the next case ****/
case CLOSURE:
/* do profiling */
if (profile_flag && atomp(funname)) {
LVAL profile_prop = findprop(funname, s_profile);
if (null(profile_prop)) {
/* make a new fixnum, don't use cvfixnum because
it would return shared pointer to zero, but we
are going to modify this integer in place --
dangerous but efficient.
*/
profile_fixnum = newnode(FIXNUM);
profile_fixnum->n_fixnum = 0;
setplist(funname, cons(s_profile,
cons(profile_fixnum,
getplist(funname))));
setvalue(s_profile, cons(funname, getvalue(s_profile)));
} else profile_fixnum = car(profile_prop);
profile_count_ptr = &getfixnum(profile_fixnum);
}
if (gettype(fun) == s_lambda) {
argc = evpushargs(fun,args);
argv = xlfp + 3;
trenter(tracing,argc,argv);
val = evfun(fun,argc,argv);
trexit(tracing,val);
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
}
else {
macroexpand(fun,args,&fun);
val = xleval(fun);
}
profile_fixnum = old_profile_fixnum;
profile_count_ptr = old_profile_count_ptr;
break;
default:
xlerror("bad function",fun);
}
/* restore the stack */
xlpopn(2);
/* return the result value */
return (val);
}
static void doagentcmd(FILE *str,char *line)
{
char *agentname;
char *instances;
char *inst;
char *ptr;
char regline[500];
char cumlname[100];
REGINFO regs[100];
char temp[20];
int rmax = 0;
int idx;
unsigned int cumlmask;
int agentidx;
agentname = gettoken(&line);
instances = gettoken(&line);
if (!instances) {
strcpy(temp,"*");
instances = temp;
}
fprintf(stderr,"Agent %s Instances %s\n",agentname,instances);
if (agentcnt == MAXAGENTS) {
fatal("Out of agent slots\n",NULL);
}
agentnames[agentcnt] = strdup(agentname);
agentidx = agentcnt;
agentcnt++;
regline[0] = '\0';
while ((readline(str,regline,sizeof(regline)) >= 0) && (rmax < 100)) {
char *atext,*subinst,*pfunc,*descr;
if (regline[0] == '!') break;
ptr = regline;
atext = gettoken(&ptr);
subinst = gettoken(&ptr);
pfunc = gettoken(&ptr);
descr = gettoken(&ptr);
if (!descr) {
fatal("Missing fields for ",atext);
}
regs[rmax].reg_addr = strdup(atext);
regs[rmax].reg_subinst = strdup(subinst);
regs[rmax].reg_printfunc = strdup(pfunc);
regs[rmax].reg_description = strdup(descr);
regs[rmax].reg_mask = 0;
rmax++;
}
if (rmax == 100) fatal("Too many registers in section ",agentname);
inst = strtok(instances,",");
cumlmask = 0;
while (inst) {
char defname[100];
unsigned int curmask;
sprintf(defname,"SOC_AGENT_%s%s",
agentname,inst[0] == '*' ? "" : inst);
curmask = newmask();
cumlmask |= curmask;
addconst(defname,curmask);
for (idx = 0; idx < rmax; idx++) {
char descr[100];
char atext[200];
macroexpand(regs[idx].reg_addr,inst,atext);
#if 0
strcpy(descr,agentname);
if (inst[0] != '*') {
strcat(descr,inst);
}
strcat(descr," ");
if (regs[idx].reg_subinst[0] != '*') {
strcat(descr,regs[idx].reg_subinst);
strcat(descr," ");
}
strcat(descr,regs[idx].reg_description);
#else
strcpy(descr,regs[idx].reg_description);
#endif
addreg(agentname,
agentidx,
curmask,
atext,
inst,
regs[idx].reg_subinst,
regs[idx].reg_printfunc,
descr);
}
inst = strtok(NULL,",");
}
if (instances[0] != '*') {
sprintf(cumlname,"SOC_AGENT_%s",agentname);
addconst(cumlname,cumlmask);
}
}