first evaluator draft

eval.c

@@ -0,0 +1,216 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+#include "wscm.h"
+
+static O listrev(O list) {
+  O prev = NIL;
+  O curr = list;
+  O next;
+
+  while (curr != NIL) {
+    C *c = uncons(curr);
+    next = c->cdr;
+    c->cdr = prev;
+    prev = curr;
+    curr = next;
+  }
+  return prev;
+}
+
+O assoc(O v, O env) {
+  while (kind(env) == KIND_CONS) {
+    C *c = uncons(env);
+    O pair = c->car;
+    if (pair == NIL) {
+      env = c->cdr;
+      continue;
+    }
+    if (kind(pair) == KIND_CONS) {
+      C *kv = uncons(pair);
+      if (kv->car == v)
+        return pair;
+    }
+    env = c->cdr;
+  }
+  return NIL;
+}
+
+O bind(O params, O args, O env) {
+  I mark = rootmark();
+  addroot(&params);
+  addroot(&args);
+  addroot(&env);
+
+  O res = env;
+  addroot(&res);
+
+  while (params != NIL) {
+    if (kind(params) == KIND_SYM) {
+      O pair = cons(params, args);
+      addroot(&pair);
+      res = cons(pair, res);
+      break;
+    }
+
+    if (kind(params) != KIND_CONS) {
+      fprintf(stderr, "error: expected proper list or symbol for parameters\n");
+      abort();
+    }
+
+    C *p = uncons(params);
+    O sym = p->car;
+
+    O val = NIL;
+    if (args != NIL) {
+      if (kind(args) != KIND_CONS) {
+        fprintf(stderr, "error: too many parameters for arguments\n");
+        abort();
+      }
+      C *a = uncons(args);
+      val = a->car;
+      args = a->cdr;
+    }
+
+    O pair = cons(sym, val);
+    addroot(&pair);
+    res = cons(pair, res);
+
+    params = p->cdr;
+  }
+
+  rootreset(mark);
+  return res;
+}
+
+O eval(O obj, O env);
+
+static O evallist(O list, O env) {
+  I mark = rootmark();
+  addroot(&list);
+  addroot(&env);
+
+  O head = NIL;
+  addroot(&head);
+
+  O curr = list;
+  addroot(&curr);
+
+  while (curr != NIL) {
+    C *c = uncons(curr);
+    O val = eval(c->car, env);
+    head = cons(val, head);
+    curr = c->cdr;
+  }
+
+  O res = listrev(head);
+
+  rootreset(mark);
+  return res;
+}
+
+/* primitives */
+
+O prim_cons(O args, O env) {
+  args = evallist(args, env);
+
+  O x = uncons(args)->car;
+  args = uncons(args)->cdr;
+  O y = uncons(args)->car;
+  return cons(x, y);
+}
+
+O prim_car(O args, O env) {
+  args = evallist(args, env);
+  O list = uncons(args)->car;
+  return uncons(list)->car;
+}
+
+O prim_cdr(O args, O env) {
+  args = evallist(args, env);
+  O list = uncons(args)->car;
+  return uncons(list)->cdr;
+}
+
+O prim_quote(O args, O env) {
+  if (args == NIL)
+    return NIL;
+  return uncons(args)->car;
+}
+
+O prim_if(O args, O env) {
+  C *ac = uncons(args);
+  O cond = eval(ac->car, env);
+  args = ac->cdr;
+  if (args == NIL)
+    return NIL;
+  ac = uncons(args);
+  if (cond != NIL) {
+    return eval(ac->car, env);
+  } else {
+    if (ac->cdr == NIL)
+      return NIL;
+    return eval(uncons(ac->cdr)->car, env);
+  }
+}
+
+O mkprim(const char *name, O (*fn)(O, O)) {
+  P *p = malloc(sizeof(P));
+  p->name = name;
+  p->fn = fn;
+  O sym = BOX(TAG(intern(name, -1), TAG_SYM));
+  O prim = BOX(TAG(p, TAG_PRIM));
+  return cons(sym, prim);
+}
+
+V setupenv(O *env) {
+  *env = cons(mkprim("cons", prim_cons), *env);
+  *env = cons(mkprim("car", prim_car), *env);
+  *env = cons(mkprim("cdr", prim_cdr), *env);
+  *env = cons(mkprim("quote", prim_quote), *env);
+  *env = cons(mkprim("if", prim_if), *env);
+}
+
+O eval(O obj, O env) {
+  I k = kind(obj);
+
+  if (k == KIND_SYM) {
+    O pair = assoc(obj, env);
+    if (pair == NIL) {
+      S *s = (S *)UNTAG(obj);
+      fprintf(stderr, "error: undefined symbol '%.*s'\n", (int)s->len, s->data);
+      abort();
+    }
+    return uncons(pair)->cdr;
+  } else if (k != KIND_CONS) {
+    return obj;
+  }
+
+  I mark = rootmark();
+  addroot(&obj);
+  addroot(&env);
+
+  C *c = uncons(obj);
+  O fn = eval(c->car, env);
+  addroot(&fn);
+
+  I fk = kind(fn);
+  O res = NIL;
+
+  if (fk == KIND_PRIM) {
+    P *p = (P *)UNTAG(fn);
+    res = p->fn(c->cdr, env);
+  } else if (fk == KIND_CLOS) {
+    H *h = UNBOX(fn);
+    L *l = (L *)(h + 1);
+    O args = evallist(c->cdr, env);
+    O nenv = bind(l->args, args, l->env);
+    res = eval(l->body, nenv);
+  } else {
+    fprintf(stderr, "tried to call non-function value\n");
+    abort();
+  }
+
+  rootreset(mark);
+  return res;
+}