reimplementation (oupsi)

old/object.c

@@ -0,0 +1,103 @@
+#include <inttypes.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#include "wscm.h"
+
+// clang-format off
+static const char *kindnames[] = {
+  [KIND_NIL] = "nil",
+  [KIND_NUM] = "number",
+  [KIND_SYM] = "symbol",
+  [KIND_PRIM] = "primitive",
+  [KIND_CONS] = "cons",
+  [KIND_CLOS] = "closure",
+};
+// clang-format on
+
+I kind(O obj) {
+  if (obj == NIL)
+    return KIND_NIL;
+  if (IMM(obj))
+    return KIND_NUM;
+
+  switch (TYPE(obj)) {
+  case TAG_SYM:
+    return KIND_SYM;
+  case TAG_PRIM:
+    return KIND_PRIM;
+  case TAG_GC: {
+    H *h = UNBOX(obj);
+    return h->type;
+  }
+  default:
+    fprintf(stderr, "unknown pointer tag %" PRIdPTR "\n", TYPE(obj));
+    abort();
+  }
+}
+
+const char *kindname(I k) {
+  if (k >= KIND__MAX)
+    return "??";
+  return kindnames[k];
+}
+
+// cons lists
+O cons(O head, O tail) {
+  I mark = rootmark();
+  addroot(&head);
+  addroot(&tail);
+
+  const Z sz = sizeof(H) + sizeof(C);
+  H *h = alloc(sz);
+  h->size = sz;
+  h->type = OBJ_CONS;
+
+  C *c = (C *)(h + 1);
+  c->car = head;
+  c->cdr = tail;
+
+  rootreset(mark);
+  return BOX(h);
+}
+
+C *uncons(O obj) {
+  I k = kind(obj);
+  if (k != KIND_CONS) {
+    fprintf(stderr, "expected cons, got %s\n", kindnames[k]);
+    abort();
+  }
+  H *h = UNBOX(obj);
+  return (C *)(h + 1);
+}
+
+// closures
+O mkclos(O args, O body, O env) {
+  I mark = rootmark();
+  addroot(&args);
+  addroot(&body);
+  addroot(&env);
+
+  const Z sz = sizeof(H) + sizeof(L);
+  H *h = alloc(sz);
+  h->size = sz;
+  h->type = OBJ_CLOS;
+
+  L *l = (L *)(h + 1);
+  l->args = args;
+  l->body = body;
+  l->env = env;
+
+  rootreset(mark);
+  return BOX(h);
+}
+
+L *unclos(O obj) {
+  I k = kind(obj);
+  if (k != KIND_CONS) {
+    fprintf(stderr, "expected closure, got %s\n", kindnames[k]);
+    abort();
+  }
+  H *h = UNBOX(obj);
+  return (L *)(h + 1);
+}