103 lines
1.7 KiB
C
103 lines
1.7 KiB
C
#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);
|
|
}
|