void dump_config(struct config* cfg)
{
printf("#include \"init.h\"\n\n");
printf("#define NULL ((void*)0)\n"); /* eh */
dump_tab("builtin_tab", cfg->inittab);
dump_env("builtin_env", cfg->env);
printf("static struct config builtin = {\n");
printf("\t.inittab = builtin_tab + 1,\n");
printf("\t.initnum = %i,\n", cfg->initnum);
printf("\t.env = builtin_env,\n");
printf("};\n\n");
printf("struct config* cfg = &builtin;\n");
}
static lisp_obj *apply(lisp_expr_application *app, lisp_env *env, lisp_err *err)
{
lisp_obj *callable = FORCE_VALUE(app->proc, env, err);
if (! callable){
return NULL;
}
lisp_obj *res = NIL;
/* Internal procedure */
if (callable->type == PROC){
/* Eval args */
lisp_obj **args = calloc(app->nparams, sizeof(lisp_obj*));
for (size_t i=0; i<app->nparams; i++){
lisp_obj *arg = FORCE_VALUE(app->params[i], env, err);
if (! arg){
for (size_t j=0; j<i; j++){
release(args[j]);
}
free(args);
return NULL;
}
args[i] = arg;
}
/* Eval internal */
res = callable->value.p(app->nparams, args);
/* Free args */
for (size_t i=0; i<app->nparams; i++){
release(args[i]);
}
free(args);
}
/* Lisp func */
else if (callable->type == LAMBDA){
lisp_lambda *lambda = &(callable->value.l);
lisp_expr_lambda *lambda_expr = &(lambda->declaration->value.mklambda);
/* Check arity */
if (app->nparams != lambda_expr->nparams){
raise_error(err, WRONG_ARITY, "Arity error ! Expected %d params, got %d",
lambda_expr->nparams, app->nparams);
return NULL;
}
/* Extend env */
lisp_env *locals = create_env(lambda->context);
for (size_t i=0; i<lambda_expr->nparams; i++){
lisp_obj *param = eval_expression(app->params[i], env, err);
if (! param){
release_env(locals);
return NULL;
}
DEBUG("Extend env with %s", lambda_expr->param_names[i]);
release(set_env(locals, lambda_expr->param_names[i], param));
}
if (enable_debug){
printf("\033[1mCALL\033[0m ");
dump_expr(lambda_expr->body);
printf(" with env\n");
dump_env(locals);
}
/* Wrap in thunk for trampoline */
res = make_thunk(lambda_expr->body, locals);
release_env(locals);
}
else {
lisp_print(callable);
raise_error(err, NOT_CALLABLE, "CANNOT CALL obj %p", callable);
return NULL;
}
release(callable);
return res;
}
struct value *eval(struct value *sexp, struct env *env)
{
struct value *car = atom("car");
struct value *cdr = atom("cdr");
struct value *cond = atom("cond");
struct value *cons_ = atom("cons");
struct value *else_ = atom("else");
struct value *equalp = atom("equal?");
struct value *lambda_ = atom("lambda");
struct value *let = atom("let*");
struct value *listp = atom("list?");
struct value *quote = atom("quote");
struct value *truth = atom("#t");
struct value *falsehood = atom("#f");
int done = 0;
while (!done) {
done = 1;
switch (sexp->type) {
case V_ATOM:
{
struct atom *name = (struct atom *)sexp;
struct value *value = lookup(env, name);
if (value == NULL) {
printf("Atom ");
dump(sexp);
printf(" has no meaning\n");
exit(1);
}
return value;
}
case V_CONS:
{
struct value *h = head(sexp);
struct value *t = tail(sexp);
struct value *bound = lookup(env, (struct atom *)h);
debug("V_CONS");
if (bound != NULL) {
debug("*(bound)");
debug(((struct atom *)h)->string);
sexp = cons(bound, t); /* pair of a lambda and a list */
done = 0; /* "tail call" */
} else if (h == car) {
struct value *k = eval(head(t), env);
debug("*car");
return head(k);
} else if (h == cdr) {
struct value *k = eval(head(t), env);
debug("*cdr");
return tail(k);
} else if (h == cond) {
struct value *branch = head(t);
debug("*cond");
/* this will error out with car(nil) if no 'else' in cond */
while (done) {
struct value *test = head(branch);
struct value *expr = head(tail(branch));
if (test == else_) {
sexp = expr;
done = 0; /* "tail call" */
} else {
test = eval(test, env);
if (test != falsehood) {
sexp = expr;
done = 0; /* "tail call" */
} else {
t = tail(t);
branch = head(t);
}
}
}
} else if (h == cons_) {
struct value *j = eval(head(t), env);
struct value *k = eval(head(tail(t)), env);
debug("*cons");
return cons(j, k);
} else if (h == equalp) {
struct value *j = eval(head(t), env);
struct value *k = eval(head(tail(t)), env);
debug("*equalp");
if (equal(j, k)) {
return truth;
} else {
return falsehood;
}
} else if (h == lambda_) {
debug("*lambda");
return lambda(env, head(t), head(tail(t)));
} else if (h == let) {
struct value *pairs = head(t);
struct value *body = head(tail(t));
debug("*let*");
while (pairs != nil) {
struct value *pair = head(pairs);
struct value *name = head(pair);
struct value *value = eval(head(tail(pair)), env);
/* TODO: check that head(pair) is an atom! */
debug("binding");
debug(((struct atom *)name)->string);
env = bind(env, (struct atom *)name, value);
pairs = tail(pairs);
}
#ifdef DEBUG
dump_env(env);
#endif
sexp = body;
done = 0; /* "tail call" */
} else if (h == listp) {
struct value *k = eval(head(t), env);
debug("*list?");
while (k->type == V_CONS) {
k = tail(k);
}
if (k == nil) {
return truth;
} else {
return falsehood;
}
} else if (h == quote) {
debug("*quote");
if (t == nil)
return t;
return head(t);
} else if (h->type == V_LAMBDA) {
struct lambda *l = (struct lambda *)h;
struct value *formals = l->formals;
struct env *l_env = l->env;
debug("*(lambda)");
while (t->type == V_CONS) {
struct value *formal = head(formals);
struct value *value = eval(head(t), env);
l_env = bind(l_env, (struct atom *)formal, value);
formals = tail(formals);
t = tail(t);
}
env = l_env;
sexp = l->body;
done = 0; /* "tail call" */
} else {
struct value *k = eval(h, env);
struct value *m = cons(eval(k, env), t);
debug("*(inner sexp)*");
return eval(m, env);
}
break;
}
case V_LAMBDA:
{
debug("V_LAMBDA\n");
return sexp;
}
}
}
return sexp;
}