wl/src/core/prim.c

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

#define BOOL(x) ((x) ? in->t : NIL)

O prim_make(In *in, const char *name, O (*fn)(In *, O *, int, O), int min_args,
            int max_args) {
  Pr *pr = malloc(sizeof(Pr));
  pr->name = name;
  pr->fn = fn;
  pr->min_args = min_args;
  pr->max_args = max_args;
  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, int argc, O env) {
  (void)env;
  if (argc != 2)
    error_throw(in, "cons: expected 2 arguments, got %d", argc);
  return pair_make(in, args[0], args[1]);
}

O prim_list(In *in, O *args, int argc, O env) {
  (void)env;
  O result = NIL;
  I mark = gc_rootmark(&in->gc);
  gc_addroot(&in->gc, &result);
  for (int i = argc - 1; i >= 0; i--) {
    result = pair_make(in, args[i], result);
  }
  gc_rootreset(&in->gc, mark);
  return result;
}

O prim_head(In *in, O *args, int argc, O env) {
  (void)env;
  if (argc != 1)
    error_throw(in, "head: expected 1 argument, got %d", argc);
  return pair_unwrap(in, args[0])->head;
}

O prim_tail(In *in, O *args, int argc, O env) {
  (void)env;
  if (argc != 1)
    error_throw(in, "tail: expected 1 argument, got %d", argc);
  return pair_unwrap(in, args[0])->tail;
}

O prim_print(In *in, O *args, int argc, O env) {
  (void)env;
  if (argc != 1)
    error_throw(in, "print: expected 1 argument, got %d", argc);
  print(args[0]);
  return NIL;
}

O prim_println(In *in, O *args, int argc, O env) {
  (void)env;
  if (argc != 1)
    error_throw(in, "println: expected 1 argument, got %d", argc);
  println(args[0]);
  return NIL;
}

O prim_write(In *in, O *args, int argc, O env) {
  (void)env;
  if (argc != 1)
    error_throw(in, "write: expected 1 argument, got %d", argc);
  if (type(args[0]) != TYPE_STR)
    error_throw(in, "write: expected string argument, got %s",
                typename(type(args[0])));
  Ss *s = (Ss *)(UNBOX(args[0]) + 1);
  printf("%.*s", (int)s->len, s->data);
  return NIL;
}

O prim_add(In *in, O *args, int argc, O env) {
  (void)env;
  I result = 0;
  for (int i = 0; i < argc; i++) {
    if (!IMM(args[i]))
      error_throw(in, "+: non numeric argument at position %d", i);
    result += ORD(args[i]);
  }
  return NUM(result);
}

O prim_sub(In *in, O *args, int argc, O env) {
  (void)env;
  if (argc == 0)
    return NUM(0);
  if (!IMM(args[0]))
    error_throw(in, "-: non numeric argument at position 0");
  I result = ORD(args[0]);
  if (argc == 1)
    return NUM(-result);
  for (int i = 1; i < argc; i++) {
    if (!IMM(args[i]))
      error_throw(in, "-: non numeric argument at position %d", i);
    result -= ORD(args[i]);
  }
  return NUM(result);
}

O prim_mul(In *in, O *args, int argc, O env) {
  (void)env;
  I result = 1;
  for (int i = 0; i < argc; i++) {
    if (!IMM(args[i]))
      error_throw(in, "*: non numeric argument at position %d", i);
    result *= ORD(args[i]);
  }
  return NUM(result);
}

O prim_div(In *in, O *args, int argc, O env) {
  (void)env;
  if (argc == 0)
    return NUM(1);
  if (!IMM(args[0]))
    error_throw(in, "/: non numeric argument at position 0");
  I result = ORD(args[0]);
  for (int i = 1; i < argc; i++) {
    if (!IMM(args[i]))
      error_throw(in, "/: non numeric argument at position %d", i);
    if (ORD(args[i]) == 0)
      error_throw(in, "/: division by zero at position %d", i);
    result /= ORD(args[i]);
  }
  return NUM(result);
}

O prim_mod(In *in, O *args, int argc, O env) {
  (void)env;
  if (argc == 0)
    return NUM(1);
  if (!IMM(args[0]))
    error_throw(in, "/: non numeric argument at position 0");
  I result = ORD(args[0]);
  for (int i = 1; i < argc; i++) {
    if (!IMM(args[i]))
      error_throw(in, "/: non numeric argument at position %d", i);
    if (ORD(args[i]) == 0)
      error_throw(in, "/: division by zero at position %d", i);
    result %= ORD(args[i]);
  }
  return NUM(result);
}

O prim_equal(In *in, O *args, int argc, O env) {
  (void)env;
  if (argc < 2)
    return in->t;
  O first = args[0];
  for (int i = 1; i < argc; i++) {
    if (first != args[i])
      return NIL;
  }
  return in->t;
}

O prim_lt(In *in, O *args, int argc, O env) {
  (void)env;
  if (argc != 2)
    error_throw(in, "<: expected 2 arguments, got %d", argc);
  if (IMM(args[0]) && IMM(args[1])) {
    return BOOL(ORD(args[0]) < ORD(args[1]));
  } else {
    error_throw(in, "<: expected numeric arguments");
    return NIL;
  }
}

O prim_gt(In *in, O *args, int argc, O env) {
  (void)env;
  if (argc != 2)
    error_throw(in, ">: expected 2 arguments, got %d", argc);
  if (IMM(args[0]) && IMM(args[1])) {
    return BOOL(ORD(args[0]) > ORD(args[1]));
  } else {
    error_throw(in, ">: expected numeric arguments");
    return NIL;
  }
}

O prim_nil_p(In *in, O *args, int argc, O env) {
  (void)env;
  if (argc != 1)
    error_throw(in, "nil?: expected 1 argument, got %d", argc);
  return BOOL(args[0] == NIL);
}

O prim_env(In *in, O *args, int argc, O env) {
  (void)args;
  (void)argc;
  (void)env;
  return in->env;
}

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