wl/src/prim.c

#include <prim.h>
#include <stdlib.h>
#include <wolflisp.h>

static O nextarg(O *list) {
  if (*list == NIL)
    return NIL;
  O arg = pair_unwrap(*list)->head;
  *list = pair_unwrap(*list)->tail;
  return arg;
}

static O bool(In *in, I i) {
  if (i)
    return in->t;
  else
    return NIL;
}

O prim_make(In *in, const char *name, O (*fn)(In *, O, O)) {
  Pr *pr = malloc(sizeof(Pr));
  pr->name = name;
  pr->fn = fn;
  O sym = BOX(TAG(intern(&in->symtab, name, 0), TAG_SYM));
  O prim = BOX(TAG(pr, TAG_PRIM));
  return pair_make(in, sym, prim);
}

O prim_cons(In *in, O args, O env) {
  args = interp_eval_list(in, args, env);
  O head = nextarg(&args);
  O tail = nextarg(&args);
  return pair_make(in, head, tail);
}

O prim_list(In *in, O args, O env) { return interp_eval_list(in, args, env); }

O prim_head(In *in, O args, O env) {
  args = interp_eval_list(in, args, env);
  return pair_unwrap(nextarg(&args))->head;
}

O prim_tail(In *in, O args, O env) {
  args = interp_eval_list(in, args, env);
  return pair_unwrap(nextarg(&args))->tail;
}

O prim_print(In *in, O args, O env) {
  args = interp_eval_list(in, args, env);
  print(nextarg(&args));
  return NIL;
}

O prim_println(In *in, O args, O env) {
  args = interp_eval_list(in, args, env);
  O arg = nextarg(&args);
  println(arg);
  return NIL;
}

O prim_quote(In *in, O args, O env) {
  (void)in;
  (void)env;
  return nextarg(&args);
}

O prim_if(In *in, O args, O env) {
  O cond_expr = nextarg(&args);
  O then_expr = nextarg(&args);
  O else_expr = nextarg(&args);

  if (cond_expr == NIL || then_expr == NIL) {
    fprintf(stderr, "if: expected at least 2 arguments\n");
    abort();
  }

  if (interp_eval(in, cond_expr, env) != NIL) {
    return interp_eval(in, then_expr, env);
  } else {
    return interp_eval(in, else_expr, env);
  }
}

O prim_progn(In *in, O args, O env) {
  O result = NIL;
  for (O expr = nextarg(&args); expr != NIL; expr = nextarg(&args))
    result = interp_eval(in, expr, env);
  return result;
}

O prim_add(In *in, O args, O env) {
  args = interp_eval_list(in, args, env);
  I result = nextarg(&args);
  if (result == NIL) {
    return NUM(0);
  } else {
    result = ORD(result);
  }
  for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&args)) {
    if (!IMM(arg)) {
      error_throw(in, "+: non numeric argument");
    }
    result += ORD(arg);
  }
  return NUM(result);
}

O prim_sub(In *in, O args, O env) {
  args = interp_eval_list(in, args, env);
  I result = nextarg(&args);
  if (result == NIL) {
    return NUM(0);
  } else {
    result = ORD(result);
  }
  for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&args)) {
    if (!IMM(arg)) {
      error_throw(in, "-: non numeric argument");
    }
    result -= ORD(arg);
  }
  return NUM(result);
}

O prim_mul(In *in, O args, O env) {
  args = interp_eval_list(in, args, env);
  I result = nextarg(&args);
  if (result == NIL) {
    return NUM(1);
  } else {
    result = ORD(result);
  }
  for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&args)) {
    if (!IMM(arg)) {
      error_throw(in, "*: non numeric argument");
    }
    result *= ORD(arg);
  }
  return NUM(result);
}

O prim_div(In *in, O args, O env) {
  args = interp_eval_list(in, args, env);
  I result = nextarg(&args);
  if (result == NIL) {
    return NUM(1);
  } else {
    result = ORD(result);
  }
  for (O arg = nextarg(&args); arg != NIL; arg = nextarg(&args)) {
    if (!IMM(arg)) {
      error_throw(in, "/: non numeric argument");
    }
    if (ORD(arg) == 0) {
      error_throw(in, "/: division by zero");
    }
    result /= ORD(arg);
  }
  return NUM(result);
}

O prim_equal(In *in, O args, O env) {
  args = interp_eval_list(in, args, env);
  I result = NIL;

  O fst = nextarg(&args);
  for (O next = nextarg(&args); next != NIL; next = nextarg(&args)) {
    if (fst == next) {
      result = in->t;
    } else {
      return NIL;
    }
    fst = next;
  }
  return result;
}

O prim_lt(In *in, O args, O env) {
  args = interp_eval_list(in, args, env);
  O fst = nextarg(&args);
  O snd = nextarg(&args);
  if (IMM(fst) && IMM(snd)) {
    return bool(in, ORD(fst) < ORD(snd));
  } else {
    error_throw(in, "<: expected numeric arguments");
    return NIL;
  };
}

O prim_gt(In *in, O args, O env) {
  args = interp_eval_list(in, args, env);
  O fst = nextarg(&args);
  O snd = nextarg(&args);
  if (IMM(fst) && IMM(snd)) {
    return bool(in, ORD(fst) > ORD(snd));
  } else {
    error_throw(in, ">: expected numeric arguments");
    return NIL;
  };
}

O prim_fn(In *in, O args, O env) {
  O params = nextarg(&args);
  O body = args;

  I mark = gc_rootmark(&in->gc);
  gc_addroot(&in->gc, &params);
  gc_addroot(&in->gc, &env);
  gc_addroot(&in->gc, &body);

  O progn = symbol_make(in, "progn");
  O body_form = pair_make(in, progn, body);
  gc_addroot(&in->gc, &body_form);

  Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl));
  hdr->type = TYPE_CLOS;
  Cl *cl = (Cl *)(hdr + 1);
  cl->args = params;
  cl->env = env;
  cl->body = body_form;

  gc_rootreset(&in->gc, mark);
  return BOX(hdr);
}

O prim_mac(In *in, O args, O env) {
  O params = nextarg(&args);
  O body = args;

  I mark = gc_rootmark(&in->gc);
  gc_addroot(&in->gc, &params);
  gc_addroot(&in->gc, &env);
  gc_addroot(&in->gc, &body);

  O progn = symbol_make(in, "progn");
  O body_form = pair_make(in, progn, body);
  gc_addroot(&in->gc, &body_form);

  Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl));
  hdr->type = TYPE_MAC;
  Cl *cl = (Cl *)(hdr + 1);
  cl->args = params;
  cl->env = env;
  cl->body = body_form;

  gc_rootreset(&in->gc, mark);
  return BOX(hdr);
}

O prim_gc(In *in, O args, O env) {
  (void)in;
  (void)args;
  (void)env;
  gc_collect(&in->gc);
  return NIL;
}

O prim_def(In *in, O args, O env) {
  O sym = nextarg(&args);
  O val_expr = nextarg(&args);

  if (type(sym) != TYPE_SYM) {
    error_throw(in, "def: expected symbol");
  }

  I mark = gc_rootmark(&in->gc);
  gc_addroot(&in->gc, &sym);
  gc_addroot(&in->gc, &env);

  O val = interp_eval(in, val_expr, env);
  gc_addroot(&in->gc, &val);

  O pair = pair_make(in, sym, val);
  gc_addroot(&in->gc, &pair);

  in->env = pair_make(in, pair, in->env);

  gc_rootreset(&in->gc, mark);
  return sym;
}

O prim_defn(In *in, O args, O env) {
  O sym = nextarg(&args);
  O params = nextarg(&args);
  O body = args;

  if (type(sym) != TYPE_SYM) {
    error_throw(in, "defn: expected symbol");
  }

  I mark = gc_rootmark(&in->gc);
  gc_addroot(&in->gc, &sym);
  gc_addroot(&in->gc, &params);
  gc_addroot(&in->gc, &body);
  gc_addroot(&in->gc, &env);

  O progn = symbol_make(in, "progn");
  O body_form = pair_make(in, progn, body);
  gc_addroot(&in->gc, &body_form);

  Gh *hdr = gc_alloc(&in->gc, sizeof(Gh) + sizeof(Cl));
  hdr->type = TYPE_CLOS;
  Cl *cl = (Cl *)(hdr + 1);
  cl->args = params;
  cl->env = env;
  cl->body = body_form;

  O fn = BOX(hdr);
  gc_addroot(&in->gc, &fn);

  O pair = pair_make(in, sym, fn);
  gc_addroot(&in->gc, &pair);

  in->env = pair_make(in, pair, in->env);

  gc_rootreset(&in->gc, mark);
  return sym;
}