wl/eval.c

#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 apply(O fn, O args, O env) {
  I k = kind(fn);
  switch (k) {
  case KIND_PRIM: {
    P *p = (P *)UNTAG(fn);
    return p->fn(args, env);
  }
  case KIND_CLOS: {
    H *h = UNBOX(fn);
    L *l = (L *)(h + 1);
    args = evallist(args, env);
    O nenv = bind(l->args, args, l->env);
    return eval(l->body, nenv);
  }
  default:
    fprintf(stderr, "tried to call non-function value\n");
    abort();
  }
}

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);

  O res = apply(fn, c->cdr, env);
  rootreset(mark);
  return res;
}