simple-lisp/src/lisp.c

#include "lisp.h"

// used by static function registering macros
#include "read.h" // IWYU pragma: keep

#include <ctype.h>
#include <stdarg.h>
#include <stdio.h>
#include <string.h>

struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
    [TYPE_STRING] = {"string", sizeof("string") - 1},
    [TYPE_SYMBOL] = {"symbol", sizeof("symbol") - 1},
    [TYPE_PAIR] = {"pair", sizeof("pair") - 1},
    [TYPE_INTEGER] = {"integer", sizeof("integer") - 1},
    [TYPE_FLOAT] = {"float", sizeof("float") - 1},
    [TYPE_VECTOR] = {"vector", sizeof("vector") - 1},
    [TYPE_FUNCTION] = {"function", sizeof("function") - 1},
    [TYPE_HASHTABLE] = {"hashtable", sizeof("hashtable") - 1},
    [TYPE_USER_POINTER] = {"user-pointer", sizeof("user-pointer") - 1},
};

void free_opt_arg_desc(void *obj) {
    struct OptArgDesc *oad = obj;
    refcount_unref(oad->name);
    refcount_unref(oad->default_form);
    refcount_unref(oad->pred_var);
    lisp_free(oad);
}

DEF_STATIC_STRING(_Qnil_name, "nil");
LispSymbol _Qnil = {
    .type = TYPE_SYMBOL,
    .name = &_Qnil_name,
    .plist = Qnil,
    .function = Qunbound,
    .value = Qnil,
    .is_constant = true,
};

DEF_STATIC_STRING(_Qunbound_name, "unbound");
LispSymbol _Qunbound = {
    .type = TYPE_SYMBOL,
    .name = &_Qunbound_name,
    .plist = Qnil,
    .function = Qunbound,
    .value = Qunbound,
    .is_constant = true,
};

DEF_STATIC_STRING(_Qt_name, "t");
LispSymbol _Qt = {
    .type = TYPE_SYMBOL,
    .name = &_Qt_name,
    .plist = Qnil,
    .function = Qunbound,
    .value = Qt,
    .is_constant = true,
};

DEF_STATIC_SYMBOL(backquote, "`");
DEF_STATIC_SYMBOL(comma, ",");
DEF_STATIC_SYMBOL(comma_at, ",@");

struct GCRoot {
    struct GCRoot *next;
    struct GCRoot *prev;
    LispVal *object;
};

static size_t bytes_allocated = 0;
static size_t last_gc = 0;

void *lisp_malloc(size_t size) {
    return lisp_realloc(NULL, size);
}

void *lisp_realloc(void *old_ptr, size_t size) {
    if (!size) {
        return NULL;
    }
    if (refcount_default_context && !refcount_is_doing_gc()) {
        bytes_allocated += size;
    }
    void *new_ptr = realloc(old_ptr, size);
    if (!new_ptr) {
        abort();
    }
    return new_ptr;
}

void garbage_collect(void) {
    last_gc = bytes_allocated;
    refcount_garbage_collect();
}

#define CONSTRUCT_OBJECT(var, Type, TYPE)  \
    Type *var = lisp_malloc(sizeof(Type)); \
    refcount_init_obj(var);                \
    var->type = TYPE;

LispVal *make_lisp_string(const char *data, size_t length, bool take,
                          bool is_static) {
    CONSTRUCT_OBJECT(self, LispString, TYPE_STRING);
    if (take) {
        self->data = (char *) data;
    } else {
        self->data = lisp_malloc(length + 1);
        memcpy(self->data, data, length);
        self->data[length] = '\0';
    }
    self->length = length;
    self->is_static = is_static;
    return LISPVAL(self);
}

LispVal *sprintf_lisp(const char *format, ...) {
    va_list args;
    va_start(args, format);
    va_list args_measure;
    va_copy(args_measure, args);
    int size = vsnprintf(NULL, 0, format, args_measure) + 1;
    va_end(args_measure);
    char *buffer = lisp_malloc(size);
    vsnprintf(buffer, size, format, args);
    LispVal *obj = make_lisp_string(buffer, size, true, false);
    va_end(args);
    return obj;
}

LispVal *make_lisp_symbol(LispVal *name) {
    CONSTRUCT_OBJECT(self, LispSymbol, TYPE_SYMBOL);
    self->name = (LispString *) refcount_ref(name);
    self->plist = Qnil;
    self->function = Qunbound;
    self->value = Qunbound;
    self->is_constant = false;
    return LISPVAL(self);
}

LispVal *make_lisp_pair(LispVal *head, LispVal *tail) {
    CONSTRUCT_OBJECT(self, LispPair, TYPE_PAIR);
    self->head = refcount_ref(head);
    self->tail = refcount_ref(tail);
    return LISPVAL(self);
}

LispVal *make_lisp_integer(intmax_t value) {
    CONSTRUCT_OBJECT(self, LispInteger, TYPE_INTEGER);
    self->type = TYPE_INTEGER;
    self->value = value;
    return LISPVAL(self);
}

LispVal *make_lisp_float(long double value) {
    CONSTRUCT_OBJECT(self, LispFloat, TYPE_FLOAT);
    self->value = value;
    return LISPVAL(self);
}

LispVal *make_lisp_vector(LispVal **data, size_t length) {
    CONSTRUCT_OBJECT(self, LispVector, TYPE_VECTOR);
    self->data = data;
    self->length = length;
    self->is_static = false;
    return LISPVAL(self);
}

DEF_STATIC_SYMBOL(opt, "&opt");
DEF_STATIC_SYMBOL(key, "&key");
DEF_STATIC_SYMBOL(allow_other_keys, "&allow-other-keys");
DEF_STATIC_SYMBOL(rest, "&rest");
DEF_STATIC_SYMBOL(declare, "declare");
DEF_STATIC_SYMBOL(name, "name");

static bool parse_opt_arg_entry(LispVal *ent, struct OptArgDesc *aod,
                                LispVal *found_args) {
    aod->name = Qnil;
    aod->default_form = Qnil;
    aod->pred_var = Qnil;
    if (TYPEOF(ent) == TYPE_SYMBOL) {
        if (VALUE_CONSTANTP(ent)) {
            return false;
        } else if (!NILP(gethash(found_args, ent, Qnil))) {
            return false;
        }
        aod->name = refcount_ref(ent);
        aod->pred_var = Qnil;
        aod->default_form = Qnil;
        return true;
    } else if (LISTP(ent) && SYMBOLP(HEAD(ent)) && !VALUE_CONSTANTP(HEAD(ent))
               && LISTP(TAIL(ent))) {
        LispVal *end = TAIL(TAIL(ent));
        if (!LISTP(end) || (!SYMBOLP(HEAD(end)) && !NILP(HEAD(end)))
            || (!NILP(HEAD(end)) && VALUE_CONSTANTP(HEAD(end)))) {
            return false;
        } else if (!NILP(gethash(found_args, HEAD(ent), Qnil))) {
            return false;
        } else if (!NILP(end)
                   && (!NILP(gethash(found_args, HEAD(end), Qnil))
                       || VALUE_CONSTANTP(HEAD(end))
                       || HEAD(end) == HEAD(ent))) {
            return false;
        }
        aod->name = refcount_ref(HEAD(ent));
        aod->default_form = refcount_ref(HEAD(TAIL(ent)));
        aod->pred_var = refcount_ref(HEAD(end));
        return true;
    }
    return false;
}

void set_function_args(LispFunction *func, LispVal *args) {
    refcount_unref(func->args);
    refcount_unref(func->kwargs);
    refcount_unref(func->rargs);
    refcount_unref(func->oargs);
    refcount_unref(func->rest_arg);

    LispVal *found_args = make_lisp_hashtable(Qnil, Qnil);

    enum {
        REQ,
        OPT,
        KEY,
        REST,
        MUST_CHANGE,
    } mode = REQ;
    bool has_opt = false;
    bool has_key = false;
    bool has_rest = false;

    func->n_req = 0;
    func->rargs = Qnil;
    func->n_opt = 0;
    func->oargs = Qnil;
    func->rest_arg = Qnil;
    func->kwargs = make_lisp_hashtable(Qnil, Qnil);
    func->allow_other_keys = false;

    LispVal *rargs_end;
    LispVal *oargs_end;

    FOREACH(arg, args) {
        if (arg == Qopt) {
            if (has_opt || mode == REST) {
                goto malformed;
            }
            has_opt = true;
            mode = OPT;
        } else if (arg == Qkey) {
            if (has_key || mode == REST) {
                goto malformed;
            }
            has_key = true;
            mode = KEY;
        } else if (arg == Qrest) {
            if (has_rest) {
                goto malformed;
            }
            has_rest = true;
            mode = REST;
        } else if (arg == Qallow_other_keys) {
            if (func->allow_other_keys || mode != KEY) {
                goto malformed;
            }
            func->allow_other_keys = true;
            mode = MUST_CHANGE;
        } else {
            switch (mode) {
            case REQ:
                if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg)
                    || !NILP(gethash(found_args, arg, Qnil))) {
                    goto malformed;
                }
                if (NILP(func->rargs)) {
                    func->rargs = Fpair(arg, Qnil);
                    rargs_end = func->rargs;
                } else {
                    LispVal *new_end = Fpair(arg, Qnil);
                    Fsettail(rargs_end, new_end);
                    refcount_unref(new_end);
                    rargs_end = new_end;
                }
                puthash(found_args, arg, Qt);
                ++func->n_req;
                break;
            case OPT: {
                LispVal *desc =
                    ALLOC_USERPTR(struct OptArgDesc, free_opt_arg_desc);
                USERPTR(struct OptArgDesc, desc)->index = 0;
                if (!parse_opt_arg_entry(arg, USERPTR(struct OptArgDesc, desc),
                                         found_args)) {
                    refcount_unref(desc);
                    goto malformed;
                }
                if (NILP(func->oargs)) {
                    func->oargs = Fpair(desc, Qnil);
                    oargs_end = func->oargs;
                } else {
                    LispVal *new_end = Fpair(desc, Qnil);
                    Fsettail(oargs_end, new_end);
                    refcount_unref(new_end);
                    oargs_end = new_end;
                }
                refcount_unref(desc);
                puthash(found_args, USERPTR(struct OptArgDesc, desc)->name, Qt);
                if (!NILP(USERPTR(struct OptArgDesc, desc)->pred_var)) {
                    puthash(found_args,
                            USERPTR(struct OptArgDesc, desc)->pred_var, Qt);
                }
                ++func->n_opt;
            } break;
            case KEY: {
                LispVal *desc =
                    ALLOC_USERPTR(struct OptArgDesc, free_opt_arg_desc);
                if (!parse_opt_arg_entry(arg, USERPTR(struct OptArgDesc, desc),
                                         found_args)) {
                    refcount_unref(desc);
                    goto malformed;
                }
                USERPTR(struct OptArgDesc, desc)->index =
                    ((LispHashtable *) func->kwargs)->count;
                LispString *sn =
                    ((LispSymbol *) USERPTR(struct OptArgDesc, desc)->name)
                        ->name;
                char kns[sn->length + 2];
                kns[0] = ':';
                memcpy(kns + 1, sn->data, sn->length);
                kns[sn->length + 1] = '\0';
                LispVal *kn =
                    make_lisp_string(kns, sn->length + 1, false, false);
                LispVal *keyword = Fintern(kn);
                puthash(func->kwargs, keyword, desc);
                refcount_unref(keyword);
                refcount_unref(kn);
                refcount_unref(desc);
                puthash(found_args, USERPTR(struct OptArgDesc, desc)->name, Qt);
                if (!NILP(USERPTR(struct OptArgDesc, desc)->pred_var)) {
                    puthash(found_args,
                            USERPTR(struct OptArgDesc, desc)->pred_var, Qt);
                }
            } break;
            case REST:
                if (!NILP(func->rest_arg)) {
                    goto malformed;
                } else if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg)) {
                    goto malformed;
                } else if (!NILP(Fgethash(found_args, arg, Qnil))) {
                    goto malformed;
                }
                func->rest_arg = refcount_ref(arg);
                mode = MUST_CHANGE;
                break;
            case MUST_CHANGE:
                goto malformed;
            }
        }
    }
    refcount_unref(found_args);
    // do this last
    func->args = refcount_ref(args);
    return;
malformed:
    refcount_unref(func->rargs);
    refcount_unref(func->oargs);
    refcount_unref(func->rest_arg);
    refcount_unref(func->kwargs);
    refcount_unref(found_args);
    Fthrow(Qmalformed_lambda_list_error, Fpair(args, Qnil));
}

LispVal *make_lisp_function(LispVal *name, LispVal *return_tag, LispVal *args,
                            LispVal *lexenv, LispVal *body, bool is_macro) {
    CONSTRUCT_OBJECT(self, LispFunction, TYPE_FUNCTION);
    self->is_builtin = false;
    self->is_macro = is_macro;
    self->args = Qnil;
    self->rargs = Qnil;
    self->oargs = Qnil;
    self->rest_arg = Qnil;
    self->kwargs = Qnil;
    self->name = Qnil;
    self->return_tag = Qnil;
    self->lexenv = Qnil;
    self->doc = Qnil;
    self->body = Qnil;
    void *cl = register_cleanup(&refcount_unref_as_callback, self);
    set_function_args(self, args);
    cancel_cleanup(cl);

    // do these after the potential throw
    self->name = refcount_ref(name);
    self->return_tag = refcount_ref(return_tag);
    self->lexenv = refcount_ref(lexenv);
    if (STRINGP(HEAD(body))) {
        self->doc = refcount_ref(HEAD(body));
        self->body = refcount_ref(TAIL(body));
    } else {
        self->doc = Qnil;
        self->body = refcount_ref(body);
    }
    return LISPVAL(self);
}

LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn) {
    CONSTRUCT_OBJECT(self, LispHashtable, TYPE_HASHTABLE);
    self->table_size = LISP_HASHTABLE_INITIAL_SIZE;
    self->data =
        lisp_malloc(sizeof(struct HashtableBucket *) * self->table_size);
    memset(self->data, 0, sizeof(struct HashtableBucket *) * self->table_size);
    self->count = 0;
    self->eq_fn = eq_fn;
    self->hash_fn = hash_fn;
    return LISPVAL(self);
}

LispVal *make_user_pointer(void *data, void (*free_func)(void *)) {
    CONSTRUCT_OBJECT(self, LispUserPointer, TYPE_USER_POINTER);
    self->data = data;
    self->free_func = free_func;
    return LISPVAL(self);
}

DEFUN(make_hashtable, "make-hashtable", (LispVal * hash_fn, LispVal *eq_fn)) {
    return make_lisp_hashtable(eq_fn, hash_fn);
}

DEFUN(vector, "vector", (LispVal * elems)) {
    struct UnrefListData uld = {.vals = NULL, .len = 0};
    WITH_PUSH_FRAME(Qnil, Qnil, true, {
        void *cl_handler = register_cleanup(&unref_free_list_double_ptr, &uld);
        FOREACH(elt, elems) {
            uld.vals = lisp_realloc(uld.vals, sizeof(LispVal *) * (++uld.len));
            uld.vals[uld.len - 1] = elt;
        }
        cancel_cleanup(cl_handler);
    });
    return make_lisp_vector(uld.vals, uld.len);
}

DEFUN(pair, "pair", (LispVal * head, LispVal *tail)) {
    return make_lisp_pair(head, tail);
}

DEFUN(hash_string, "hash-string", (LispVal * obj)) {
    CHECK_TYPE(TYPE_STRING, obj);
    const char *str = ((LispString *) obj)->data;
    uint64_t hash = 5381;
    int c;
    while ((c = *(str++))) {
        hash = ((hash << 5) + hash) + c;
    }
    return make_lisp_integer(hash);
}

DEFUN(strings_equal, "strings-equal", (LispVal * obj1, LispVal *obj2)) {
    CHECK_TYPE(TYPE_STRING, obj1);
    CHECK_TYPE(TYPE_STRING, obj2);
    LispString *str1 = (LispString *) obj1;
    LispString *str2 = (LispString *) obj2;
    if (str1->length != str2->length) {
        return Qnil;
    }
    return LISP_BOOL(memcmp(str1->data, str2->data, str1->length) == 0);
}

bool strings_equal_nocase(const char *s1, const char *s2, size_t n) {
    for (size_t i = 0; i < n; ++i) {
        if (!s1[i] || !s2[i]) {
            return !s1[i] && !s2[i];
        } else if (tolower(s1[i]) != tolower(s2[i])) {
            return false;
        }
    }
    return true;
}

DEFUN(id, "id", (LispVal * obj)) {
    return make_lisp_integer((int64_t) obj);
}

DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2)) {
    return LISP_BOOL(obj1 == obj2);
}

static bool hash_table_eq(LispHashtable *self, LispVal *v1, LispVal *v2) {
    if (NILP(self->eq_fn)) {
        return v1 == v2;
    } else if (self->eq_fn == Qstrings_equal) {
        return !NILP(Fstrings_equal(v1, v2));
    } else {
        LispVal *eq_obj;
        LispVal *args = const_list(true, 2, v1, v2);
        WITH_CLEANUP_DOUBLE_PTR(args, {
            eq_obj = Ffuncall(self->eq_fn, args); //
        });
        bool result = !NILP(eq_obj);
        refcount_unref(eq_obj);
        return result;
    }
}

static uint64_t hash_table_hash(LispHashtable *self, LispVal *key) {
    if (NILP(self->hash_fn)) {
        return (uint64_t) key;
    } else if (self->hash_fn == Qhash_string) {
        // Make obarray and lexenv lookups faster
        LispVal *hash_obj = Fhash_string(key);
        uint64_t hash = ((LispInteger *) hash_obj)->value;
        refcount_unref(hash_obj);
        return hash;
    } else {
        LispVal *hash_obj;
        LispVal *args = const_list(true, 1, key);
        WITH_CLEANUP_DOUBLE_PTR(args, {
            hash_obj = Ffuncall(self->hash_fn, args); //
        });
        uint64_t hash;
        WITH_CLEANUP_DOUBLE_PTR(hash_obj, {
            CHECK_TYPE(TYPE_INTEGER, hash_obj);
            hash = ((LispInteger *) hash_obj)->value;
        });
        return hash;
    }
}

static struct HashtableBucket *
find_hash_table_bucket(LispHashtable *self, LispVal *key, uint64_t hash) {
    struct HashtableBucket *cur = self->data[hash % self->table_size];
    while (cur) {
        if (hash_table_eq(self, key, cur->key)) {
            return cur;
        }
        cur = cur->next;
    }
    return NULL;
}

static void hash_table_rehash(LispHashtable *self, size_t new_size) {
    struct HashtableBucket **new_data =
        lisp_malloc(sizeof(struct HashtableBucket *) * new_size);
    memset(new_data, 0, sizeof(struct HashtableBucket *) * new_size);
    for (size_t i = 0; i < self->table_size; ++i) {
        struct HashtableBucket *cur = self->data[i];
        while (cur) {
            struct HashtableBucket *next = cur->next;
            cur->next = new_data[cur->hash % new_size];
            new_data[cur->hash % new_size] = cur;
            cur = next;
        }
    }
    free(self->data);
    self->data = new_data;
    self->table_size = new_size;
}

LispVal *puthash(LispVal *table, LispVal *key, LispVal *value) {
    CHECK_TYPE(TYPE_HASHTABLE, table);
    LispHashtable *self = (LispHashtable *) table;
    uint64_t hash = hash_table_hash(self, key);
    struct HashtableBucket *cur_bucket =
        find_hash_table_bucket(self, key, hash);
    if (cur_bucket) {
        refcount_ref(value);
        refcount_unref(cur_bucket->value);
        cur_bucket->value = value;
    } else {
        cur_bucket = lisp_malloc(sizeof(struct HashtableBucket));
        cur_bucket->next = self->data[hash % self->table_size];
        cur_bucket->hash = hash;
        cur_bucket->key = refcount_ref(key);
        cur_bucket->value = refcount_ref(value);
        self->data[hash % self->table_size] = cur_bucket;
        ++self->count;
        if ((double) self->count / self->table_size
            >= LISP_HASHTABLE_GROWTH_THRESHOLD) {
            hash_table_rehash(self,
                              LISP_HASHTABLE_GROWTH_FACTOR * self->table_size);
        }
    }
    return table;
}

DEFUN(puthash, "puthash", (LispVal * table, LispVal *key, LispVal *value)) {
    return refcount_ref(puthash(table, key, value));
}

LispVal *gethash(LispVal *table, LispVal *key, LispVal *def) {
    CHECK_TYPE(TYPE_HASHTABLE, table);
    LispHashtable *self = (LispHashtable *) table;
    uint64_t hash = hash_table_hash(self, key);
    struct HashtableBucket *cur_bucket =
        find_hash_table_bucket(self, key, hash);
    if (cur_bucket) {
        return cur_bucket->value;
    }
    return def;
}

DEFUN(gethash, "gethash", (LispVal * table, LispVal *key, LispVal *def)) {
    return refcount_ref(gethash(table, key, def));
}

LispVal *remhash(LispVal *table, LispVal *key) {
    CHECK_TYPE(TYPE_HASHTABLE, table);
    LispHashtable *self = (LispHashtable *) table;
    uint64_t hash = hash_table_hash(self, key);
    struct HashtableBucket *cur_bucket = self->data[hash % self->table_size];
    if (cur_bucket && hash_table_eq(self, cur_bucket->key, key)) {
        self->data[hash % self->table_size] = cur_bucket->next;
        refcount_unref(cur_bucket->key);
        refcount_unref(cur_bucket->value);
        lisp_free(cur_bucket);
        --self->count;
    } else {
        struct HashtableBucket *prev_bucket = cur_bucket;
        cur_bucket = cur_bucket->next;
        while (cur_bucket) {
            if (hash_table_eq(self, cur_bucket->key, key)) {
                prev_bucket->next = cur_bucket->next;
                refcount_unref(cur_bucket->key);
                refcount_unref(cur_bucket->value);
                lisp_free(cur_bucket);
                --self->count;
                break;
            }
        }
    }
    if ((double) self->count / self->table_size
            <= LISP_HASHTABLE_SHRINK_THRESHOLD
        && self->table_size > LISP_HASHTABLE_INITIAL_SIZE) {
        hash_table_rehash(self,
                          self->table_size / LISP_HASHTABLE_GROWTH_FACTOR);
    }
    return table;
}

DEFUN(remhash, "remhash", (LispVal * table, LispVal *key)) {
    return refcount_ref(remhash(table, key));
}

DEFUN(hash_table_count, "hash-table-count", (LispVal * table)) {
    CHECK_TYPE(TYPE_HASHTABLE, table);
    return make_lisp_integer(((LispHashtable *) table)->count);
}

DEFUN(intern, "intern", (LispVal * name)) {
    CHECK_TYPE(TYPE_STRING, name);
    LispVal *cur = gethash(Vobarray, name, Qunbound);
    if (cur != Qunbound) {
        return refcount_ref(cur);
    }
    LispVal *sym = make_lisp_symbol(name);
    puthash(Vobarray, name, sym);
    return sym;
}

LispVal *intern(const char *name, size_t length, bool take) {
    LispVal *name_obj = make_lisp_string((char *) name, length, take, false);
    LispVal *sym = Fintern(name_obj);
    refcount_unref(name_obj);
    return sym;
}

DEFUN(sethead, "sethead", (LispVal * pair, LispVal *head)) {
    CHECK_TYPE(TYPE_PAIR, pair);
    refcount_unref(((LispPair *) pair)->head);
    ((LispPair *) pair)->head = refcount_ref(head);
    return Qnil;
}

DEFUN(settail, "settail", (LispVal * pair, LispVal *tail)) {
    CHECK_TYPE(TYPE_PAIR, pair);
    refcount_unref(((LispPair *) pair)->tail);
    ((LispPair *) pair)->tail = refcount_ref(tail);
    return Qnil;
}

size_t list_length(LispVal *obj) {
    if (NILP(obj)) {
        return 0;
    }
    CHECK_TYPE(TYPE_PAIR, obj);
    size_t length = 0;
    LispPair *tortise = (LispPair *) obj;
    LispPair *hare = (LispPair *) tortise->tail;
    while (!NILP(tortise)) {
        if (!LISTP(LISPVAL(tortise))) {
            break;
        } else if (tortise == hare) {
            Fthrow(Qcircular_error, Qnil);
        }
        ++length;
        tortise = (LispPair *) tortise->tail;
        if (PAIRP(hare)) {
            if (PAIRP(((LispPair *) hare)->tail)) {
                hare = (LispPair *) ((LispPair *) hare->tail)->tail;
            } else if (NILP(((LispPair *) hare)->tail)) {
                hare = (LispPair *) Qnil;
            }
        }
    }
    return length;
}

StackFrame *the_stack = NULL;
LispVal *stack_return = NULL;
DEF_STATIC_SYMBOL(toplevel, "toplevel");

void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
    StackFrame *frame = lisp_malloc(sizeof(StackFrame));
    frame->name = name;
    frame->return_tag = Qnil;
    frame->hidden = true;
    frame->detail = detail;
    frame->lexenv = Qnil;
    if (inherit && the_stack) {
        frame->lexenv = refcount_ref(the_stack->lexenv);
    }
    frame->enable_handlers = true;
    frame->handlers = make_lisp_hashtable(Qnil, Qnil);
    frame->unwind_form = Qnil;
    frame->cleanup_handlers = NULL;

    frame->next = the_stack;
    the_stack = frame;
}

void stack_leave(void) {
    StackFrame *frame = the_stack;
    the_stack = the_stack->next;
    refcount_unref(frame->name);
    refcount_unref(frame->return_tag);
    refcount_unref(frame->detail);
    refcount_unref(frame->lexenv);
    refcount_unref(frame->handlers);
    while (frame->cleanup_handlers) {
        frame->cleanup_handlers->fun(frame->cleanup_handlers->data);
        struct CleanupHandlerEntry *next = frame->cleanup_handlers->next;
        lisp_free(frame->cleanup_handlers);
        frame->cleanup_handlers = next;
    }
    LispVal *unwind_form = frame->unwind_form;
    // steal the ref
    frame->unwind_form = Qnil;
    lisp_free(frame);
    if (!NILP(unwind_form)) {
        WITH_CLEANUP(unwind_form, {
            refcount_unref(Feval(unwind_form)); //
        })
    }
}

void *register_cleanup(lisp_cleanup_func_t fun, void *data) {
    struct CleanupHandlerEntry *entry =
        lisp_malloc(sizeof(struct CleanupHandlerEntry));
    entry->fun = fun;
    entry->data = data;
    entry->next = the_stack->cleanup_handlers;
    the_stack->cleanup_handlers = entry;
    return entry;
}

void free_double_ptr(void *ptr) {
    lisp_free(*(void **) ptr);
}

void unref_free_list_double_ptr(void *ptr) {
    struct UnrefListData *data = ptr;
    for (size_t i = 0; i < data->len; ++i) {
        refcount_unref(data->vals[i]);
    }
    lisp_free(data->vals);
}

void unref_double_ptr(void *ptr) {
    if (*(void **) ptr) {
        refcount_unref(*(void **) ptr);
        *(void **) ptr = NULL;
    }
}

void cancel_cleanup(void *handle) {
    struct CleanupHandlerEntry *entry = the_stack->cleanup_handlers;
    if (entry == handle) {
        the_stack->cleanup_handlers = entry->next;
        lisp_free(entry);
    } else {
        while (entry) {
            if (entry->next == handle) {
                struct CleanupHandlerEntry *to_free = entry->next;
                entry->next = entry->next->next;
                lisp_free(to_free);
                break;
            }
            entry = entry->next;
        }
    }
}

DEFUN(backtrace, "backtrace", (void) ) {
    LispVal *head = Qnil;
    LispVal *end;
    for (StackFrame *frame = the_stack; frame; frame = frame->next) {
        if (frame->hidden) {
            continue;
        }
        if (NILP(head)) {
            head = Fpair(Fpair(LISPVAL(frame->name), frame->detail), Qnil);
            refcount_unref(HEAD(head));
            end = head;
        } else {
            LispVal *new_end =
                Fpair(Fpair(LISPVAL(frame->name), frame->detail), Qnil);
            refcount_unref(HEAD(new_end));
            Fsettail(end, new_end);
            refcount_unref(new_end);
            end = new_end;
        }
    }
    return head;
}

DEFMACRO(return_from, "return-from", (LispVal * name, LispVal *value)) {
    Fthrow(Qreturn_frame_error,
           const_list(false, 2, refcount_ref(name), Feval(value)));
}

STATIC_DEFMACRO(internal_real_return, "internal-real-return",
                (LispVal * name, LispVal *tag, LispVal *value)) {
    for (StackFrame *cur = the_stack; cur; cur = cur->next) {
        if (!NILP(cur->return_tag) && cur->enable_handlers
            && cur->return_tag == tag) {
            Fthrow(cur->return_tag, const_list(false, 1, Feval(value)));
        }
    }
    Fthrow(Qreturn_frame_error,
           const_list(false, 2, refcount_ref(name), Feval(value)));
}

#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Winfinite-recursion"
DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
    CHECK_TYPE(TYPE_SYMBOL, signal);
    LispVal *error_arg =
        const_list(false, 2, Fpair(signal, rest), Fbacktrace());
    while (the_stack) {
        if (!the_stack->enable_handlers) {
            goto up_frame;
        }
        LispVal *handler =
            gethash(LISPVAL(the_stack->handlers), signal, Qunbound);
        if (handler == Qunbound) {
            // handler for all exceptions
            handler = gethash(LISPVAL(the_stack->handlers), Qt, Qunbound);
        }
        if (handler != Qunbound) {
            the_stack->enable_handlers = false;
            LispVal *var = HEAD(handler);
            LispVal *form = TAIL(handler);
            WITH_PUSH_FRAME(Qnil, Qnil, true, {
                if (!NILP(var)) {
                    // TODO make sure this isn't constant
                    push_to_lexenv(&the_stack->lexenv, var, error_arg);
                }
                WITH_CLEANUP(error_arg, {
                    stack_return = Feval(form); //
                });
            });
            longjmp(the_stack->start, STACK_EXIT_THROW);
        }
    up_frame: {
        // steal the form so we can call it after we unwind (in case it
        // throws)
        LispVal *unwind_form = the_stack->unwind_form;
        the_stack->unwind_form = Qnil;
        stack_leave();
        if (!NILP(unwind_form)) {
            void *cl_handler =
                register_cleanup(&refcount_unref_as_callback, error_arg);
            WITH_CLEANUP(unwind_form, {
                refcount_unref(Feval(unwind_form)); //
            });
            cancel_cleanup(cl_handler);
        }
    }
    }
    fprintf(stderr,
            "ERROR: An exception has propagated past the top of the stack!\n");
    fprintf(stderr, "Type: ");
    debug_dump(stderr, signal, true);
    fprintf(stderr, "Args: ");
    debug_dump(stderr, rest, true);
    fprintf(stderr, "Lisp will now exit...");
    // we never used it, so drop it
    refcount_unref(error_arg);
    abort();
}
#pragma GCC diagnostic pop

DEF_STATIC_SYMBOL(success, ":success");
DEF_STATIC_SYMBOL(finally, ":finally");
DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal");
DEF_STATIC_SYMBOL(type_error, "type-error");
DEF_STATIC_SYMBOL(read_error, "read-error");
DEF_STATIC_SYMBOL(unclosed_error, "read-error");
DEF_STATIC_SYMBOL(eof_error, "eof-error");
DEF_STATIC_SYMBOL(void_variable_error, "void-variable-error");
DEF_STATIC_SYMBOL(void_function_error, "void-function-error");
DEF_STATIC_SYMBOL(circular_error, "circular-error");
DEF_STATIC_SYMBOL(malformed_lambda_list_error, "malformed-lambda-list-error");
DEF_STATIC_SYMBOL(argument_error, "argument-error");
DEF_STATIC_SYMBOL(invalid_function_error, "invalid-function-error");
DEF_STATIC_SYMBOL(no_applicable_method_error, "no-applicable-method-error");
DEF_STATIC_SYMBOL(return_frame_error, "return-frame-error");

LispVal *predicate_for_type(LispType type) {
    switch (type) {
    case TYPE_STRING:
        return Qstringp;
    case TYPE_SYMBOL:
        return Qsymbolp;
    case TYPE_PAIR:
        return Qpairp;
    case TYPE_INTEGER:
        return Qintegerp;
    case TYPE_FLOAT:
        return Qfloatp;
    case TYPE_VECTOR:
        return Qvectorp;
    case TYPE_FUNCTION:
        return Qfunctionp;
    case TYPE_HASHTABLE:
        return Qhashtablep;
    case TYPE_USER_POINTER:
        return Quser_pointer_p;
    default:
        abort();
    }
}

LispVal *Vobarray = Qnil;

static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) {
    switch (TYPEOF(obj)) {
    case TYPE_STRING:
    case TYPE_INTEGER:
    case TYPE_FLOAT:
    case TYPE_USER_POINTER:
        // no held refs
        return true;
    case TYPE_SYMBOL:
        *held = refcount_list_push(*held, ((LispSymbol *) obj)->name);
        *held = refcount_list_push(*held, ((LispSymbol *) obj)->function);
        *held = refcount_list_push(*held, ((LispSymbol *) obj)->plist);
        *held = refcount_list_push(*held, ((LispSymbol *) obj)->value);
        return true;
    case TYPE_PAIR:
        *held = refcount_list_push(*held, ((LispPair *) obj)->head);
        *held = refcount_list_push(*held, ((LispPair *) obj)->tail);
        return true;
    case TYPE_VECTOR: {
        LispVector *vec = obj;
        for (size_t i = 0; i < vec->length; ++i) {
            *held = refcount_list_push(*held, vec->data[i]);
        }
        return true;
    }
    case TYPE_HASHTABLE:
        HASHTABLE_FOREACH(key, val, obj, {
            *held = refcount_list_push(*held, key);
            *held = refcount_list_push(*held, val);
        });
        return true;
    case TYPE_FUNCTION: {
        LispFunction *fn = obj;
        *held = refcount_list_push(*held, fn->name);
        *held = refcount_list_push(*held, fn->return_tag);
        *held = refcount_list_push(*held, fn->args);
        *held = refcount_list_push(*held, fn->kwargs);
        *held = refcount_list_push(*held, fn->oargs);
        *held = refcount_list_push(*held, fn->rargs);
        *held = refcount_list_push(*held, fn->lexenv);
        *held = refcount_list_push(*held, fn->doc);
        *held = refcount_list_push(*held, fn->rest_arg);
        if (!fn->is_builtin) {
            *held = refcount_list_push(*held, fn->body);
        }
        return true;
    }
    default:
        abort();
    }
}

static void free_obj_callback(void *obj, void *ignored) {
    switch (TYPEOF(obj)) {
    case TYPE_STRING: {
        LispString *str = obj;
        if (!str->is_static) {
            lisp_free(str->data);
        }
    } break;
    case TYPE_VECTOR: {
        LispVector *vec = obj;
        if (!vec->is_static) {
            lisp_free(vec->data);
        }
    } break;
    case TYPE_USER_POINTER: {
        LispUserPointer *ptr = obj;
        if (ptr->free_func) {
            ptr->free_func(ptr->data);
        }
    } break;
    case TYPE_HASHTABLE: {
        LispHashtable *tbl = obj;
        for (size_t i = 0; i < tbl->table_size; ++i) {
            struct HashtableBucket *cur = tbl->data[i];
            while (cur) {
                struct HashtableBucket *next = cur->next;
                lisp_free(cur);
                cur = next;
            }
        }
        lisp_free(tbl->data);
    } break;
    case TYPE_FUNCTION:
    case TYPE_SYMBOL:
    case TYPE_PAIR:
    case TYPE_INTEGER:
    case TYPE_FLOAT:
        // no internal data to free
        break;
    default:
        abort();
    }
    lisp_free(obj);
}

static DECLARE_FUNCTION(set_for_return, (LispVal * entry, LispVal *dest));

void lisp_init(void) {
    RefcountContext *ctx = refcount_make_context(
        offsetof(LispVal, refcount), Qnil, held_refs_callback,
        free_obj_callback, NULL,
        &(RefcountAllocator) {.malloc.no_data = lisp_malloc,
                              .free.no_data = lisp_free});
    refcount_default_context = ctx;

    Vobarray = make_lisp_hashtable(Qstrings_equal, Qhash_string);

    refcount_init_static(Qunbound);
    refcount_init_static(&_Qunbound_name);
    REGISTER_SYMBOL(nil);
    REGISTER_SYMBOL(t);
    REGISTER_SYMBOL(opt);
    REGISTER_SYMBOL(allow_other_keys);
    REGISTER_SYMBOL(key);
    REGISTER_SYMBOL(rest);
    REGISTER_SYMBOL(declare);
    REGISTER_SYMBOL(name);
    REGISTER_SYMBOL(comma);
    REGISTER_SYMBOL(comma_at);
    REGISTER_SYMBOL(backquote);
    REGISTER_SYMBOL(success);
    REGISTER_SYMBOL(finally);
    REGISTER_SYMBOL(shutdown_signal);
    REGISTER_SYMBOL(type_error);
    REGISTER_SYMBOL(read_error);
    REGISTER_SYMBOL(eof_error);
    REGISTER_SYMBOL(unclosed_error);
    REGISTER_SYMBOL(void_variable_error);
    REGISTER_SYMBOL(void_function_error);
    REGISTER_SYMBOL(circular_error);
    REGISTER_SYMBOL(malformed_lambda_list_error);
    REGISTER_SYMBOL(argument_error);
    REGISTER_SYMBOL(invalid_function_error);
    REGISTER_SYMBOL(no_applicable_method_error);
    REGISTER_SYMBOL(return_frame_error);

    // some stuff that musn't be user accesable
    REGISTER_SYMBOL_NOINTERN(toplevel);
    REGISTER_STATIC_FUNCTION(set_for_return, "(entry dest)", "");
    REGISTER_STATIC_FUNCTION(internal_real_return, "(name tag value)", "");

    REGISTER_FUNCTION(make_hashtable, "(&opt hash-fn eq-fn)", "");
    REGISTER_FUNCTION(puthash, "(table key value)", "");
    REGISTER_FUNCTION(gethash, "(table key &opt def)", "");
    REGISTER_FUNCTION(remhash, "(table key)", "");
    REGISTER_FUNCTION(vector, "(&rest elements)", "");
    REGISTER_FUNCTION(breakpoint, "(&opt id)", "Do nothing...");
    REGISTER_FUNCTION(sethead, "(pair newval)",
                      "Set the head of PAIR to NEWVAL.");
    REGISTER_FUNCTION(settail, "(pair newval)",
                      "Set the tail of PAIR to NEWVAL.");
    REGISTER_FUNCTION(funcall, "(function &rest args)", "")
    REGISTER_FUNCTION(apply, "(function &rest args)", "")
    REGISTER_FUNCTION(throw, "(signal &rest data)", "");
    REGISTER_FUNCTION(pair, "(head tail)",
                      "Return a new pair with HEAD and TAIL.");
    REGISTER_FUNCTION(head, "(pair)", "Return the head of PAIR.");
    REGISTER_FUNCTION(tail, "(pair)", "Return the tail of PAIR.");
    REGISTER_FUNCTION(quote, "(form)", "Return FORM as read by the reader.");
    REGISTER_FUNCTION(exit, "(&opt code)",
                      "Exit with CODE, defaulting to zero.");
    REGISTER_FUNCTION(print, "(obj)",
                      "Print a human-readable representation of OBJ.");
    REGISTER_FUNCTION(
        println, "(obj)",
        "Print a human-readable representation of OBJ followed by a newline.");
    REGISTER_FUNCTION(not, "(obj)",
                      "Return t if OBJ is nil, otherwise return t.");
    REGISTER_FUNCTION(add, "(&rest nums)", "Return the sun of NUMS.");
    REGISTER_FUNCTION(sub, "(&rest nums)",
                      "Return (head NUMS) - (apply '+ (tail NUMS)).");
    REGISTER_FUNCTION(
        if, "(cond then &rest else)",
        "Evaluate THEN if COND is non-nil, otherwise evaluate ELSE.");
    REGISTER_FUNCTION(
        setq, "(&rest name-value-pairs)",
        "Set each of a number of variables to their respective values.");
    REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS.");
    REGISTER_FUNCTION(symbol_name, "(sym)", "");
    REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", "");
    REGISTER_FUNCTION(symbol_value, "(sym)", "Return the global value of SYM.");
    REGISTER_FUNCTION(symbol_plist, "(sym)", "Return the plist of SYM.");
    REGISTER_FUNCTION(setplist, "(sym plist)",
                      "Set the plist of SYM to PLIST.");
    REGISTER_FUNCTION(fset, "(sym new-func)", "");
    REGISTER_FUNCTION(defun, "(name args &rest body)",
                      "Define NAME to be a new function.");
    REGISTER_FUNCTION(defmacro, "(name args &rest body)",
                      "Define NAME to be a new macro.");
    REGISTER_FUNCTION(lambda, "(args &rest body)", "Return a new closure.");
    REGISTER_FUNCTION(while, "(cond &rest body)",
                      "Run BODY until COND returns nil.");
    REGISTER_FUNCTION(eval, "(expr)", "Evaluate the lisp expression EXPR");
    REGISTER_FUNCTION(read, "(source)",
                      "Read and return the next s-expr from SOURCE.");
    REGISTER_FUNCTION(eq, "(obj1 obj2)",
                      "Return non-nil if OBJ1 and OBJ2 are equal");
    REGISTER_FUNCTION(make_symbol, "(name)",
                      "Return a new un-interned symbol named NAME.");
    REGISTER_FUNCTION(macroexpand_1, "(form &opt lexical-macros)",
                      "Return the form which FORM expands to.");
    REGISTER_FUNCTION(macroexpand_toplevel, "(form &opt lexical-macros)", "");
    REGISTER_FUNCTION(macroexpand_all, "(form &opt lexical-macros)", "");
    REGISTER_FUNCTION(stringp, "(val)", "Return non-nil if VAL is a string.");
    REGISTER_FUNCTION(symbolp, "(val)", "Return non-nil if VAL is a symbol.");
    REGISTER_FUNCTION(pairp, "(val)", "Return non-nil if VAL is a pair.");
    REGISTER_FUNCTION(integerp, "(val)", "Return non-nil if VAL is a integer.");
    REGISTER_FUNCTION(floatp, "(val)", "Return non-nil if VAL is a float.");
    REGISTER_FUNCTION(vectorp, "(val)", "Return non-nil if VAL is a vector.");
    REGISTER_FUNCTION(
        functionp, "(val)",
        "Return non-nil if VAL is a non-macro function (includes buitlins).");
    REGISTER_FUNCTION(macrop, "(val &opt lexical-macros)",
                      "Return non-nil if VAL is a non-builtin macro.");
    REGISTER_FUNCTION(builtinp, "(val)",
                      "Return non-nil if VAL is a non-macro builtin.");
    REGISTER_FUNCTION(special_form_p, "(val)",
                      "Return non-nil if VAL is a macro-builtin.");
    REGISTER_FUNCTION(hashtablep, "(val)",
                      "Return non-nil if VAL is a hashtable.");
    REGISTER_FUNCTION(user_pointer_p, "(val)",
                      "Return non-nil if VAL is a user pointer.");
    REGISTER_FUNCTION(atom, "(val)", "Return non-nil if VAL is a atom.");
    REGISTER_FUNCTION(listp, "(val)", "Return non-nil if VAL is a list.");
    REGISTER_FUNCTION(keywordp, "(val)", "Return non-nil if VAL is a keyword.");
    REGISTER_FUNCTION(numberp, "(val)", "Return non-nil if VAL is a number.");
    REGISTER_FUNCTION(list_length, "(list)", "Return the length of LIST.");
    REGISTER_FUNCTION(copy_list, "(list)", "Return a shallow copy of LIST.");
    REGISTER_FUNCTION(copy_tree, "(tree)",
                      "Return a deep copy of TREE and all sublists in it.");
    REGISTER_FUNCTION(num_eq, "(n1 n2)",
                      "Return non-nil if N1 and N2 are equal numerically.")
    REGISTER_FUNCTION(num_gt, "(n1 n2)",
                      "Return non-nil if N1 is greather than N2.")
    REGISTER_FUNCTION(and, "(&rest args)",
                      "Logical and (with short circuit evaluation.)");
    REGISTER_FUNCTION(or, "(&rest args)",
                      "Logical or (with short circuit evaluation.)");
    REGISTER_FUNCTION(type_of, "(obj)", "Return the type of OBJ.");
    REGISTER_FUNCTION(function_docstr, "(func)",
                      "Return the documentation string of FUNC.");
    REGISTER_FUNCTION(plist_get, "(plist key &opt def pred)", "");
    REGISTER_FUNCTION(plist_set, "(plist key value &opt pred)", "");
    REGISTER_FUNCTION(plist_rem, "(plist key &opt pred)", "");
    REGISTER_FUNCTION(return_from, "(name &opt value)",
                      "Return from the function named NAME and return VALUE.");
    REGISTER_FUNCTION(intern, "(name)", "");
    REGISTER_FUNCTION(condition_case, "(form &rest handlers)", "");
}

void lisp_shutdown(void) {
    refcount_unref(Vobarray);

    garbage_collect();

    refcount_context_destroy(refcount_default_context);
    refcount_default_context = NULL;
}

static inline LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) {
    return Fplist_get(lexenv, key, Qunbound, Qnil);
}

static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
    if (!NILP(lexenv)) {
        LispVal *local = find_in_lexenv(lexenv, key);
        if (local != Qunbound) {
            return local;
        }
    }
    LispVal *sym_val = Fsymbol_value(key);
    if (sym_val != Qunbound) {
        return sym_val;
    }
    Fthrow(Qvoid_variable_error, const_list(true, 1, key));
}

static void breakpoint(int64_t id) {}

DEFUN(breakpoint, "breakpoint", (LispVal * id)) {
    if (NILP(id)) {
        breakpoint(0);
    } else {
        CHECK_TYPE(TYPE_INTEGER, id);
        breakpoint(((LispInteger *) id)->value);
    }
    return Qnil;
}

DEFUN(symbol_name, "symbol-name", (LispVal * symbol)) {
    CHECK_TYPE(TYPE_SYMBOL, symbol);
    return refcount_ref(((LispSymbol *) symbol)->name);
}

DEFUN(symbol_function, "symbol-function",
      (LispVal * symbol, LispVal *resolve)) {
    CHECK_TYPE(TYPE_SYMBOL, symbol);
    if (NILP(resolve)) {
        LispVal *fn = ((LispSymbol *) symbol)->function;
        return fn == Qunbound ? Qnil : fn;
    }
    while (SYMBOLP(symbol) && symbol != Qunbound) {
        symbol = ((LispSymbol *) symbol)->function;
    }
    return refcount_ref(symbol);
}

DEFUN(symbol_value, "symbol-value", (LispVal * symbol)) {
    CHECK_TYPE(TYPE_SYMBOL, symbol);
    return refcount_ref(((LispSymbol *) symbol)->value);
}

DEFUN(symbol_plist, "symbol-plist", (LispVal * symbol)) {
    CHECK_TYPE(TYPE_SYMBOL, symbol);
    return refcount_ref(((LispSymbol *) symbol)->plist);
}

DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist)) {
    CHECK_TYPE(TYPE_SYMBOL, symbol);
    LispSymbol *real = (LispSymbol *) symbol;
    refcount_unref(real->plist);
    real->plist = refcount_ref(plist);
    return Qnil;
}

static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) {
    LispVal *final_args = Qnil;
    WITH_PUSH_FRAME(Qnil, Qnil, true, {
        void *cl_handle = register_cleanup(
            (lisp_cleanup_func_t) &unref_double_ptr, &final_args);
        LispVal *end;
        FOREACH(elt, args) {
            if (NILP(final_args)) {
                final_args = Fpair(Feval_in_env(elt, lexenv), Qnil);
                refcount_unref(HEAD(final_args));
                end = final_args;
            } else {
                LispVal *new_end = Fpair(Feval_in_env(elt, lexenv), Qnil);
                refcount_unref(HEAD(new_end));
                Fsettail(end, new_end);
                refcount_unref(new_end);
                end = new_end;
            }
        }
        cancel_cleanup(cl_handle);
    });
    return final_args;
}

static LispVal **process_builtin_args(LispVal *fname, LispFunction *func,
                                      LispVal *args, size_t *nargs) {
    size_t raw_count =
        (func->n_req + func->n_opt + ((LispHashtable *) func->kwargs)->count
         + !NILP(func->rest_arg));
    *nargs = raw_count;
    LispVal **vec = lisp_malloc(sizeof(LispVal *) * raw_count);
    memset(vec, 0, sizeof(LispVal *) * raw_count);
    LispVal *rest = Qnil;
    LispVal *rest_end;
    size_t have_count = 0;
    LispVal *opt_desc;
    LispVal *arg = Qnil; // last arg processed
    while (!NILP(args)) {
        arg = HEAD(args);
        if (have_count < func->n_req + func->n_opt) {
            vec[have_count++] = refcount_ref(arg);
        } else if (KEYWORDP(arg)
                   && !NILP(opt_desc = HEAD(gethash(func->kwargs, arg, Qnil)))
                   && NILP(rest)) {
            struct OptArgDesc *oad = USERPTR(struct OptArgDesc, opt_desc);
            if (vec[oad->index]) {
                goto multikey;
            }
            args = TAIL(args);
            if (NILP(args)) {
                goto key_no_val;
            }
            vec[oad->index] = refcount_ref(HEAD(arg));
        } else if (KEYWORDP(arg) && !func->allow_other_keys && NILP(rest)) {
            goto unknown_key;
        } else if (NILP(func->rest_arg)) {
            goto too_many;
        } else if (NILP(rest)) {
            rest = Fpair(arg, Qnil);
            rest_end = rest;
        } else {
            LispVal *new_end = Fpair(arg, Qnil);
            Fsettail(rest_end, new_end);
            refcount_unref(new_end);
            rest_end = new_end;
        }
        args = TAIL(args);
    }
    if (have_count < func->n_req) {
        goto too_few;
    }
    if (!NILP(func->rest_arg)) {
        vec[raw_count - 1] = rest;
    }
    for (size_t i = 0; i < raw_count; ++i) {
        if (!vec[i]) {
            vec[i] = Qnil;
        }
    }
    return vec;
    // TODO different messages
key_no_val:
too_many:
multikey:
unknown_key:
too_few:
    refcount_unref(rest);
    for (size_t i = 0; i < raw_count; ++i) {
        if (vec[i]) {
            refcount_unref(vec[i]);
        }
    }
    lisp_free(vec);
    Fthrow(Qargument_error, Fpair(fname, Qnil));
    return NULL;
}

static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args,
                             LispVal *args_lexenv) {
    // builtin macros inherit their parents lexenv
    if (func->is_macro) {
        the_stack->lexenv = refcount_ref(args_lexenv);
    }
    size_t nargs;
    LispVal **arg_vec = process_builtin_args(name, func, args, &nargs);
    struct UnrefListData cleanup_data = {.vals = arg_vec, .len = nargs};
    void *cl = register_cleanup(&unref_free_list_double_ptr, &cleanup_data);
    LispVal *retval;
    switch (nargs) {
    case 0:
        retval = ((LispVal * (*) (void) ) func->builtin)();
        break;
    case 1:
        retval = ((LispVal * (*) (LispVal *) ) func->builtin)(arg_vec[0]);
        break;
    case 2:
        retval = ((LispVal * (*) (LispVal *, LispVal *) )
                      func->builtin)(arg_vec[0], arg_vec[1]);
        break;
    case 3:
        retval = ((LispVal * (*) (LispVal *, LispVal *, LispVal *) )
                      func->builtin)(arg_vec[0], arg_vec[1], arg_vec[2]);
        break;
    case 4:
        retval =
            ((LispVal * (*) (LispVal *, LispVal *, LispVal *, LispVal *) )
                 func->builtin)(arg_vec[0], arg_vec[1], arg_vec[2], arg_vec[3]);
        break;
    case 5:
        retval =
            ((LispVal
              * (*) (LispVal *, LispVal *, LispVal *, LispVal *, LispVal *) )
                 func->builtin)(arg_vec[0], arg_vec[1], arg_vec[2], arg_vec[3],
                                arg_vec[4]);
        break;
    case 6:
        retval = ((LispVal
                   * (*) (LispVal *, LispVal *, LispVal *, LispVal *, LispVal *,
                          LispVal *) ) func->builtin)(arg_vec[0], arg_vec[1],
                                                      arg_vec[2], arg_vec[3],
                                                      arg_vec[4], arg_vec[5]);
        break;
    default:
        fprintf(stderr,
                "Builtin functions cannot have more than 6 arguments!\n");
        abort();
    }
    cancel_cleanup(cl);
    refcount_ref(retval);
    unref_free_list_double_ptr(&cleanup_data);
    return retval;
}

static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
                              LispVal **lexenv) {
    LispVal *added_kwds = make_lisp_hashtable(Qnil, Qnil);
    void *cl_handle = register_cleanup(&refcount_unref_as_callback, added_kwds);
    enum { REQ, OPT, KEY, REST } mode = REQ;
    LispVal *rargs = func->rargs;
    LispVal *oargs = func->oargs;
    while (!NILP(args)) {
        LispVal *arg = HEAD(args);
        switch (mode) {
        case REQ: {
            if (NILP(rargs)) {
                mode = OPT;
                continue; // skip increment
            }
            push_to_lexenv(lexenv, HEAD(rargs), arg);
            rargs = TAIL(rargs);
        } break;
        case OPT: {
            if (NILP(oargs)) {
                mode = KEY;
                continue; // skip increment
            }
            struct OptArgDesc *oad = USERPTR(struct OptArgDesc, HEAD(oargs));
            push_to_lexenv(lexenv, oad->name, arg);
            if (!NILP(oad->pred_var)) {
                push_to_lexenv(lexenv, oad->pred_var, Qt);
            }
            oargs = TAIL(oargs);
        } break;
        case KEY:
            if (!KEYWORDP(arg)) {
                mode = REST;
                continue; // skip increment
            }
            LispVal *desc_lv = gethash(func->kwargs, arg, Qnil);
            if (NILP(desc_lv)) {
                if (!func->allow_other_keys) {
                    goto unknown_key;
                }
                mode = REST;
                continue; // skip increment
            }
            struct OptArgDesc *oad = USERPTR(struct OptArgDesc, desc_lv);
            args = TAIL(args);
            if (NILP(args)) {
                goto missing_value;
            }
            LispVal *value = HEAD(args);
            puthash(added_kwds, oad->name, Qt);
            push_to_lexenv(lexenv, oad->name, value);
            if (!NILP(oad->pred_var)) {
                push_to_lexenv(lexenv, oad->pred_var, Qt);
            }
            break;
        case REST:
            if (NILP(func->rest_arg)) {
                if (KEYWORDP(arg)) {
                    args = TAIL(args);
                    if (NILP(args)) {
                        goto missing_value;
                    }
                    args = TAIL(args);
                    continue; // skip increment
                } else {
                    goto too_many_args;
                }
            }
            push_to_lexenv(lexenv, func->rest_arg, args);
            // done processing
            goto done_adding;
        }
        args = TAIL(args);
    }
    if (!NILP(rargs)) {
        goto missing_required;
    }
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wunused-variable"
    HASHTABLE_FOREACH(arg, desc_lv, func->kwargs, {
        struct OptArgDesc *oad = USERPTR(struct OptArgDesc, desc_lv);
        // only check the current function's lexenv and not its parents'
        if (NILP(gethash(added_kwds, oad->name, Qnil))) {
            LispVal *eval_res = Feval(oad->default_form);
            push_to_lexenv(lexenv, oad->name, eval_res);
            refcount_unref(eval_res);
            if (!NILP(oad->pred_var)) {
                push_to_lexenv(lexenv, oad->pred_var, Qnil);
            }
        }
    });
#pragma GCC diagnostic pop
    FOREACH(arg, oargs) {
        struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg);
        LispVal *default_val = Feval(oad->default_form);
        push_to_lexenv(lexenv, oad->name, default_val);
        refcount_unref(default_val);
        if (!NILP(oad->pred_var)) {
            push_to_lexenv(lexenv, oad->pred_var, Qnil);
        }
    }
    if (!NILP(func->rest_arg)) {
        push_to_lexenv(lexenv, func->rest_arg, Qnil);
    }
done_adding:
    cancel_cleanup(cl_handle);
    refcount_unref(added_kwds);
    return;
    // TODO different messages
missing_required:
too_many_args:
missing_value:
unknown_key:
    cancel_cleanup(cl_handle);
    refcount_unref(added_kwds);
    Fthrow(Qargument_error, Fpair(fname, Qnil));
}

static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
                                   LispVal *args, LispVal *args_lexenv) {
    the_stack->lexenv = refcount_ref(func->lexenv);
    process_lisp_args(name, func, args, &the_stack->lexenv);
    if (func->is_macro) {
        if (!the_stack->next) {
            abort();
        }
        LispVal *expansion = Fprogn(func->body);
        LispVal *retval = Qnil;
        // disable internal handlers
        the_stack->enable_handlers = false;
        WITH_CLEANUP(expansion, {
            // eval in the outer lexenv
            retval = Feval_in_env(expansion, args_lexenv);
        });
        the_stack->enable_handlers = true; // just in case
        return retval;
    } else {
        return Fprogn(func->body);
    }
}

STATIC_DEFUN(set_for_return, "set-for-return",
             (LispVal * entry, LispVal *dest)) {
    LispVal *retval = HEAD(TAIL(HEAD(entry)));
    Fsethead(dest, retval);
    return Qnil;
}

static inline void setup_return_handler(LispVal *tag, LispVal *dest) {
    LispVal *err_var = INTERN_STATIC("e");
    LispVal *quoted_dest = const_list(false, 2, Qquote, dest);
    LispVal *handler =
        const_list(true, 4, err_var, Qset_for_return, err_var, quoted_dest);
    refcount_unref(quoted_dest);
    puthash(the_stack->handlers, tag, handler);
    refcount_unref(handler);
}

static LispVal *call_function(LispVal *func, LispVal *args,
                              LispVal *args_lexenv, bool eval_args,
                              bool allow_macro) {
    LispFunction *fobj = (LispFunction *) Qnil;
    if (FUNCTIONP(func)) {
        fobj = (LispFunction *) refcount_ref(func);
    } else if (SYMBOLP(func)) {
        fobj = (LispFunction *) Fsymbol_function(func, Qt);
    } else {
        Fthrow(Qinvalid_function_error, Fpair(func, Qnil));
    }
    void *cl_handle = register_cleanup(refcount_unref_as_callback, fobj);
    if (LISPVAL(fobj) == Qunbound) {
        Fthrow(Qvoid_function_error, const_list(true, 1, func));
    } else if (!FUNCTIONP(fobj)) {
        Fthrow(Qinvalid_function_error, Fpair(LISPVAL(fobj), Qnil));
    } else if (!allow_macro && fobj->is_macro) {
        Fthrow(Qtype_error, Qnil);
    }
    if (!fobj->is_macro && eval_args) {
        args = eval_function_args(args, args_lexenv);
    }
    LispVal *retval = Qnil;
    LispVal *return_ptr = Fpair(Qnil, Qnil);
    void *return_cl_handle =
        register_cleanup(refcount_unref_as_callback, return_ptr);
    refcount_ref(args);
    WITH_CLEANUP(args, {
        WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(
            refcount_ref(fobj->name), refcount_ref(args),
            false, // make sure the lexenv is nil
            {
                the_stack->hidden = false;
                if (!NILP(fobj->return_tag)) {
                    the_stack->return_tag = refcount_ref(fobj->return_tag);
                    setup_return_handler(fobj->return_tag, return_ptr);
                }
                if (fobj->is_builtin) {
                    retval = call_builtin(func, fobj, args, args_lexenv);
                } else {
                    retval = call_lisp_function(func, fobj, args, args_lexenv);
                }
            },
            {
                retval = refcount_ref(HEAD(return_ptr)); //
            });
    });
    cancel_cleanup(return_cl_handle);
    refcount_unref(return_ptr);
    cancel_cleanup(cl_handle);
    return retval;
}

DEFUN(eval_in_env, "eval-in-env", (LispVal * form, LispVal *lexenv)) {
    switch (TYPEOF(form)) {
    case TYPE_STRING:
    case TYPE_FUNCTION:
    case TYPE_INTEGER:
    case TYPE_FLOAT:
    case TYPE_HASHTABLE:
    case TYPE_USER_POINTER:
        // the above all are self-evaluating
        return refcount_ref(form);
    case TYPE_SYMBOL:
        if (KEYWORDP(form)) {
            return refcount_ref(form);
        } else {
            // this refs its return value
            return symbol_value_in_lexenv(lexenv, form);
        }
    case TYPE_VECTOR: {
        LispVector *vec = (LispVector *) form;
        LispVal **elts = lisp_malloc(sizeof(LispVal *) * vec->length);
        if (elts) { // in case length is 0
            memset(elts, 0, sizeof(LispVal *) * vec->length);
        }
        WITH_PUSH_FRAME(Qnil, Qnil, true, {
            struct UnrefListData uld;
            uld.vals = elts;
            uld.len = vec->length;
            void *cl_handler =
                register_cleanup(&unref_free_list_double_ptr, &uld);
            for (size_t i = 0; i < vec->length; ++i) {
                elts[i] = Feval_in_env(vec->data[i], lexenv);
            }
            cancel_cleanup(cl_handler);
        });
        // does not ref its arguments
        return make_lisp_vector(elts, vec->length);
    }
    case TYPE_PAIR: {
        LispPair *pair = (LispPair *) form;
        return call_function(pair->head, pair->tail, lexenv, true, true);
    }
    default:
        abort();
    }
}

DEFUN(eval, "eval", (LispVal * form)) {
    return Feval_in_env(form, LISPVAL(the_stack->lexenv));
}

DEFUN(funcall, "funcall", (LispVal * function, LispVal *rest)) {
    return call_function(function, rest, Qnil, false, false);
}

DEFUN(copy_tree, "copy-tree", (LispVal * tree)) {
    if (NILP(tree)) {
        return Qnil;
    }
    CHECK_TYPE(TYPE_PAIR, tree);
    LispPair *tortise = (LispPair *) tree;
    LispPair *hare = (LispPair *) tortise->tail;
    LispVal *copy = Qnil;
    LispVal *copy_end;
    WITH_PUSH_FRAME(Qnil, Qnil, true, {
        void *cl_handle = register_cleanup(&unref_double_ptr, &copy);
        while (!NILP(tortise)) {
            if (!LISTP(LISPVAL(tortise))) {
                break;
            } else if (tortise == hare) {
                refcount_unref(copy);
                Fthrow(Qcircular_error, Qnil);
            }
            LispVal *elt = tortise->head;
            if (PAIRP(elt)) {
                elt = Fcopy_tree(elt);
            } else {
                refcount_ref(elt);
            }
            if (NILP(copy)) {
                copy = Fpair(elt, Qnil);
                copy_end = copy;
            } else {
                LispVal *new_end = Fpair(elt, Qnil);
                Fsettail(copy_end, new_end);
                refcount_unref(new_end);
                copy_end = new_end;
            }
            refcount_unref(elt);
            tortise = (LispPair *) tortise->tail;
            if (PAIRP(hare)) {
                if (PAIRP(((LispPair *) hare)->tail)) {
                    hare = (LispPair *) ((LispPair *) hare->tail)->tail;
                } else if (NILP(((LispPair *) hare)->tail)) {
                    hare = (LispPair *) Qnil;
                }
            }
        }
        cancel_cleanup(cl_handle);
    });
    return copy;
}

static LispVal *lookup_lexical_macro(LispVal *name, LispVal *lexical_macros) {
    if (!SYMBOLP(name)) {
        return Qunbound;
    }
    LispVal *res = Fplist_get(lexical_macros, name, Qunbound, Qnil);
    if (FUNCTIONP(res)) {
        return res;
    }
    refcount_unref(res);
    return Qunbound;
}

static inline LispVal *expand_function_as_macro(LispFunction *fobj,
                                                LispVal *args) {
    return Ffuncall((LispVal *) fobj, args);
}

DEFUN(macroexpand_1, "macroexpand-1",
      (LispVal * form, LispVal *lexical_macros)) {
    if (PAIRP(form)) {
        LispVal *lex_res = lookup_lexical_macro(HEAD(form), lexical_macros);
        LispFunction *fobj = (LispFunction *) Qunbound;
        if (lex_res != Qunbound) {
            return expand_function_as_macro((LispFunction *) lex_res,
                                            TAIL(form));
        } else if (FUNCTIONP(HEAD(form))) {
            fobj = refcount_ref(HEAD(form));
        } else {
            fobj = (LispFunction *) Fsymbol_function(HEAD(form), Qt);
        }
        if (!FUNCTIONP(fobj) || fobj->is_builtin || !fobj->is_macro) {
            refcount_unref(fobj);
            return refcount_ref(form);
        }
        LispVal *expansion = Qnil;
        LispVal *return_ptr = Fpair(Qnil, Qnil);
        WITH_CLEANUP(return_ptr, {
            WITH_CLEANUP(fobj, {
                WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(
                    refcount_ref(HEAD(form)), refcount_ref(TAIL(form)), false,
                    {
                        the_stack->hidden = false;
                        if (!NILP(fobj->return_tag)) {
                            the_stack->return_tag =
                                refcount_ref(fobj->return_tag);
                            setup_return_handler(fobj->return_tag, return_ptr);
                        }
                        the_stack->lexenv = refcount_ref(fobj->lexenv);
                        process_lisp_args(Fhead(form), fobj, Ftail(form),
                                          &the_stack->lexenv);
                        expansion = Fprogn(fobj->body);
                    },
                    {
                        expansion = refcount_ref(HEAD(return_ptr)); //
                    });
            });
        });
        return expansion;
    } else {
        return refcount_ref(form);
    }
}

DEFUN(macroexpand_toplevel, "macroexpand-toplevel",
      (LispVal * form, LispVal *lexical_macros)) {
    if (PAIRP(form)) {
        LispVal *out = refcount_ref(form);
        void *cl_handler = register_cleanup(&unref_double_ptr, &out);
        while (PAIRP(out) && !NILP(Fmacrop(HEAD(out), lexical_macros))) {
            LispVal *new_out = Fmacroexpand_1(out, lexical_macros);
            refcount_unref(out);
            out = new_out;
        }
        cancel_cleanup(cl_handler);
        return out;
    } else {
        return refcount_ref(form);
    }
}

static LispVal *filter_body_form(LispVal *form,
                                 LispVal *(*func)(LispVal *body,
                                                  void *user_data),
                                 void *user_data);

#define EXPAND_HEAD(form)                                                   \
    {                                                                       \
        LispVal *expansion = filter_body_form(HEAD(form), func, user_data); \
        WITH_CLEANUP(expansion, { Fsethead(form, expansion); });            \
    }
static void expand_lambda_list(LispVal *list,
                               LispVal *(*func)(LispVal *body, void *user_data),
                               void *user_data) {
    bool enable_extended = false;
    FOREACH_TAIL(entry, list) {
        if (enable_extended && PAIRP(HEAD(entry))) {
            LispVal *copy = Fcopy_list(HEAD(entry));
            Fsethead(entry, copy);
            refcount_unref(copy);
            if (PAIRP(TAIL(copy))) {
                EXPAND_HEAD(TAIL(copy));
            }
        } else if (HEAD(entry) == Qrest) {
            enable_extended = false;
        } else if (HEAD(entry) == Qopt || HEAD(entry) == Qkey) {
            enable_extended = true;
        }
    }
}

static void expand_builtin_macro(LispFunction *fobj, LispVal *args,
                                 LispVal *(*func)(LispVal *body,
                                                  void *user_data),
                                 void *user_data) {
    if (fobj->builtin == (lisp_function_ptr_t) Fquote) {
        return; // do nothing
    } else if (fobj->builtin == (lisp_function_ptr_t) Fsetq) {
        bool is_var = true;
        FOREACH_TAIL(form, args) {
            if (!is_var) {
                EXPAND_HEAD(form);
            }
            is_var = !is_var;
        }
    } else if (fobj->builtin == (lisp_function_ptr_t) Freturn_from) {
        if (PAIRP(args) && PAIRP(TAIL(args))) {
            EXPAND_HEAD(TAIL(args));
        }
    } else if (fobj->builtin == (lisp_function_ptr_t) Finternal_real_return) {
        if (PAIRP(args) && PAIRP(TAIL(args)) && PAIRP(TAIL(TAIL(args)))) {
            EXPAND_HEAD(TAIL(TAIL(args)));
        }
    } else if (fobj->builtin == (lisp_function_ptr_t) Fcondition_case) {
        if (PAIRP(args)) {
            EXPAND_HEAD(args);
            FOREACH_TAIL(entry_tail, TAIL(args)) {
                LispVal *copy = Fcopy_list(HEAD(entry_tail));
                Fsethead(entry_tail, copy);
                refcount_unref(copy);
                if (PAIRP(HEAD(entry_tail))) {
                    FOREACH_TAIL(form, TAIL(HEAD(entry_tail))) {
                        EXPAND_HEAD(form);
                    }
                }
            }
        }
    } else if (fobj->builtin == (lisp_function_ptr_t) Fdefmacro
               || fobj->builtin == (lisp_function_ptr_t) Fdefun
               || fobj->builtin == (lisp_function_ptr_t) Flambda) {
        if (!LISTP(args)) {
            return;
        }
        LispVal *expand_from = TAIL(args); // skip lambda list
        if (!LISTP(expand_from)) {
            return;
        }
        LispVal *lambda_list;
        if (fobj->builtin != (lisp_function_ptr_t) Flambda) {
            LispVal *copy = Fcopy_list(HEAD(expand_from));
            Fsethead(expand_from, copy);
            refcount_unref(copy);
            lambda_list = HEAD(expand_from);
            expand_from = TAIL(expand_from); // skip the name
            if (!LISTP(expand_from)) {
                return;
            }
        } else {
            LispVal *copy = Fcopy_list(HEAD(args));
            Fsethead(args, copy);
            refcount_unref(copy);
            lambda_list = HEAD(args);
        }
        expand_lambda_list(lambda_list, func, user_data);
        LispVal *first_form = HEAD(expand_from);
        if (PAIRP(first_form) && HEAD(first_form) == Qdeclare) {
            expand_from = TAIL(expand_from); // declare statement
            if (!LISTP(expand_from)) {
                return;
            }
        }
        FOREACH_TAIL(form, expand_from) {
            EXPAND_HEAD(form);
        }
    } else {
        FOREACH_TAIL(form, args) {
            EXPAND_HEAD(form);
        }
    }
}
#undef EXPAND_HEAD

// func should ref its return value
static LispVal *filter_body_form(LispVal *form,
                                 LispVal *(*func)(LispVal *body,
                                                  void *user_data),
                                 void *user_data) {
    LispVal *toplevel_orig = func(form, user_data);
    if (PAIRP(toplevel_orig)) {
        LispVal *toplevel;
        WITH_CLEANUP(toplevel_orig, {
            toplevel = Fcopy_list(toplevel_orig); //
        });
        WITH_PUSH_FRAME(Qnil, Qnil, true, {
            void *cl_handler = register_cleanup(&unref_double_ptr, &toplevel);
            if (PAIRP(toplevel)) {
                LispFunction *fobj = NULL;
                if (FUNCTIONP(HEAD(toplevel))) {
                    fobj = refcount_ref(HEAD(toplevel));
                } else if (SYMBOLP(HEAD(toplevel))) {
                    fobj =
                        (LispFunction *) Fsymbol_function(HEAD(toplevel), Qt);
                }
                if (fobj) {
                    WITH_CLEANUP(fobj, {
                        if (fobj->is_builtin && fobj->is_macro) {
                            expand_builtin_macro(fobj, TAIL(toplevel), func,
                                                 user_data);
                        } else {
                            FOREACH_TAIL(tail, TAIL(toplevel)) {
                                Fsethead(tail,
                                         filter_body_form(HEAD(tail), func,
                                                          user_data));
                            }
                        }
                    });
                }
            }
            cancel_cleanup(cl_handler);
        });
        return toplevel;
    } else {
        return toplevel_orig;
    }
    return Qnil;
}

static LispVal *filter_body_tree(LispVal *body,
                                 LispVal *(*func)(LispVal *body,
                                                  void *user_data),
                                 void *user_data) {
    LispVal *start = Qnil;
    LispVal *end;
    FOREACH(form, body) {
        LispVal *filtered = filter_body_form(form, func, user_data);
        if (NILP(start)) {
            start = Fpair(filtered, Qnil);
            end = start;
        } else {
            LispVal *new_end = Fpair(filtered, Qnil);
            Fsettail(end, new_end);
            refcount_unref(new_end);
            end = new_end;
        }
        refcount_unref(filtered);
    }
    return start;
}

static LispVal *macroexpand_toplevel_as_callback(LispVal *form,
                                                 void *lexical_macros) {
    return Fmacroexpand_toplevel(form, lexical_macros);
}

DEFUN(macroexpand_all, "macroexpand-all",
      (LispVal * form, LispVal *lexical_macros)) {
    return filter_body_form(form, macroexpand_toplevel_as_callback,
                            lexical_macros);
}

DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
    LispVal *args = Qnil;
    LispVal *end;
    while (!NILP(rest) && !NILP(((LispPair *) rest)->tail)) {
        if (NILP(args)) {
            args = Fpair(((LispPair *) rest)->head, Qnil);
            end = args;
        } else {
            LispVal *new_end = Fpair(((LispPair *) rest)->head, Qnil);
            Fsettail(end, new_end);
            refcount_unref(new_end);
            end = new_end;
        }
        rest = ((LispPair *) rest)->tail;
    }
    if (LISTP(HEAD(rest))) {
        // ensure the list is not circular
        refcount_ref(args);
        WITH_CLEANUP(args, {
            list_length(Fhead(rest)); //
        });
        if (NILP(args)) {
            args = HEAD(rest);
        } else {
            Fsettail(end, HEAD(rest));
        }
    } else {
        if (NILP(args)) {
            args = Fpair(((LispPair *) rest)->head, Qnil);
            end = args;
        } else {
            LispVal *new_end = Fpair(((LispPair *) rest)->head, Qnil);
            Fsettail(end, new_end);
            refcount_unref(new_end);
            end = new_end;
        }
    }
    LispVal *retval;
    WITH_CLEANUP_DOUBLE_PTR(args, {
        retval = Ffuncall(function, args); //
    });
    return retval;
}

DEFUN(head, "head", (LispVal * list)) {
    return refcount_ref(HEAD(list));
}

DEFUN(tail, "tail", (LispVal * list)) {
    return refcount_ref(TAIL(list));
}

DEFUN(exit, "exit", (LispVal * code)) {
    if (!NILP(code) && !INTEGERP(code)) {
        Fthrow(Qtype_error, Qnil);
    }
    Fthrow(Qshutdown_signal, const_list(true, 1, code));
}

DEFMACRO(quote, "'", (LispVal * form)) {
    return refcount_ref(form);
}

DEFUN(print, "print", (LispVal * obj)) {
    debug_dump(stdout, obj, false);
    return Qnil;
}

DEFUN(println, "println", (LispVal * obj)) {
    debug_dump(stdout, obj, true);
    return Qnil;
}

DEFUN(not, "not", (LispVal * obj)) {
    return NILP(obj) ? Qt : Qnil;
}

DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil)) {
    LispVal *res = Feval(cond);
    LispVal *retval = Qnil;
    WITH_PUSH_FRAME(Qnil, Qnil, true, {
        if (!NILP(res)) {
            retval = Feval(t);
        } else {
            retval = Fprogn(nil);
        }
    });
    return retval;
}

DEFUN(num_eq, "=", (LispVal * n1, LispVal *n2)) {
    if (INTEGERP(n1) && INTEGERP(n2)) {
        return LISP_BOOL(((LispInteger *) n1)->value
                         == ((LispInteger *) n2)->value);
    } else if (INTEGERP(n1) && FLOATP(n2)) {
        return LISP_BOOL(((LispInteger *) n1)->value
                         == ((LispFloat *) n2)->value);
    } else if (FLOATP(n1) && INTEGERP(n2)) {
        return LISP_BOOL(((LispFloat *) n1)->value
                         == ((LispInteger *) n2)->value);
    } else if (FLOATP(n1) && FLOATP(n2)) {
        return LISP_BOOL(((LispFloat *) n1)->value
                         == ((LispFloat *) n2)->value);
    } else {
        Fthrow(Qtype_error, Qnil);
    }
}

DEFUN(num_gt, ">", (LispVal * n1, LispVal *n2)) {
    if (INTEGERP(n1) && INTEGERP(n2)) {
        return LISP_BOOL(((LispInteger *) n1)->value
                         > ((LispInteger *) n2)->value);
    } else if (INTEGERP(n1) && FLOATP(n2)) {
        return LISP_BOOL(((LispInteger *) n1)->value
                         > ((LispFloat *) n2)->value);
    } else if (FLOATP(n1) && INTEGERP(n2)) {
        return LISP_BOOL(((LispFloat *) n1)->value
                         > ((LispInteger *) n2)->value);
    } else if (FLOATP(n1) && FLOATP(n2)) {
        return LISP_BOOL(((LispFloat *) n1)->value > ((LispFloat *) n2)->value);
    } else {
        Fthrow(Qtype_error, Qnil);
    }
}

#define ONE_MATH_OPERAION(oper, out, n1, n2)                              \
    if (INTEGERP(n1) && INTEGERP(n2)) {                                   \
        out = make_lisp_integer(                                          \
            ((LispInteger *) n1)->value oper((LispInteger *) n2)->value); \
    } else if (INTEGERP(n1) && FLOATP(n2)) {                              \
        out = make_lisp_float(                                            \
            ((LispInteger *) n1)->value oper((LispFloat *) n2)->value);   \
    } else if (FLOATP(n1) && INTEGERP(n2)) {                              \
        out = make_lisp_float(                                            \
            ((LispFloat *) n1)->value oper((LispInteger *) n2)->value);   \
    } else if (FLOATP(n1) && FLOATP(n2)) {                                \
        out = make_lisp_float(                                            \
            ((LispFloat *) n1)->value oper((LispFloat *) n2)->value);     \
    } else {                                                              \
        Fthrow(Qtype_error, Qnil);                                        \
    }

static inline LispVal *copy_number(LispVal *v) {
    if (FLOATP(v)) {
        return make_lisp_float(((LispFloat *) v)->value);
    } else if (INTEGERP(v)) {
        return make_lisp_integer(((LispInteger *) v)->value);
    } else {
        abort();
    }
}

DEFUN(add, "+", (LispVal * args)) {
    if (NILP(args)) {
        return make_lisp_integer(0);
    }
    LispVal *out = copy_number(Fhead(args));
    FOREACH(arg, Ftail(args)) {
        LispVal *old_out = out;
        WITH_CLEANUP_DOUBLE_PTR(old_out, {
            ONE_MATH_OPERAION(+, out, out, arg); //
        });
    }
    return out;
}

DEFUN(sub, "-", (LispVal * args)) {
    if (NILP(args)) {
        return make_lisp_integer(0);
    }
    LispVal *out = copy_number(Fhead(args));
    FOREACH(arg, Ftail(args)) {
        LispVal *old_out = out;
        WITH_CLEANUP_DOUBLE_PTR(old_out, {
            ONE_MATH_OPERAION(-, out, out, arg); //
        });
    }
    return out;
}

static void set_symbol_in_lexenv(LispVal *key, LispVal *newval,
                                 LispVal *lexenv) {
    LispVal *lexval = Fplist_assoc(lexenv, key, Qnil);
    if (PAIRP(lexval)) {
        Fsethead(TAIL(lexval), newval);
    } else {
        refcount_ref(newval);
        refcount_unref(((LispSymbol *) key)->value);
        ((LispSymbol *) key)->value = newval;
    }
}

DEFMACRO(setq, "setq", (LispVal * args)) {
    size_t len = list_length(args);
    if (!len || len % 2) {
        Fthrow(Qargument_error, Fpair(Qsetq, Qnil));
    }
    LispVal *retval = Qnil;
    FOREACH_TAIL(tail, args) {
        CHECK_TYPE(TYPE_SYMBOL, HEAD(tail));
        LispVal *name = HEAD(tail);
        tail = TAIL(tail);
        retval = Feval(HEAD(tail));
        set_symbol_in_lexenv(name, retval, the_stack->lexenv);
    }
    return retval;
}

DEFMACRO(progn, "progn", (LispVal * forms)) {
    LispVal *retval = Qnil;
    FOREACH(form, forms) {
        refcount_unref(retval);
        retval = Feval(form);
    }
    return retval;
}

DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func)) {
    CHECK_TYPE(TYPE_SYMBOL, sym);
    LispSymbol *sobj = ((LispSymbol *) sym);
    // TODO make sure this is not constant
    refcount_ref(new_func);
    refcount_unref(sobj->function);
    sobj->function = new_func;
    return refcount_ref(new_func);
}

// clang-format off
DEFMACRO(condition_case, "condition-case", (LispVal * form, LispVal *rest)) {
    bool success = false;
    LispVal *success_form = Qunbound;
    LispVal *finally_form = Qunbound;
    LispVal *retval = Qnil;
    WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(Qnil, Qnil, true, {
        void *cl_handler = register_cleanup(&unref_double_ptr, &success_form);
        void *cl_handler2 = register_cleanup(&unref_double_ptr, &finally_form);
        FOREACH(entry, rest) {
            if (HEAD(entry) == Qsuccess) {
                if (success_form != Qunbound) {
                    Fthrow(Qmalformed_lambda_list_error, Qnil);
                }
                success_form = Fpair(Qprogn, TAIL(entry));
            } else if (HEAD(entry) == Qfinally) {
                if (finally_form != Qunbound) {
                    Fthrow(Qmalformed_lambda_list_error, Qnil);
                }
                finally_form = Fpair(Qprogn, TAIL(entry));
            } else {
                LispVal *var = HEAD(HEAD(entry)); LispVal *types = HEAD(TAIL(HEAD(entry)));
                if (!PAIRP(types)) {
                    types = const_list(true, 1, types);
                } else {
                    types = refcount_ref(types);
                }
                WITH_CLEANUP(types, {
                    FOREACH(type, types) {
                        LispVal *handler = push_many(TAIL(entry), 2,
                                                     Qprogn, var);
                        puthash(the_stack->handlers, type, handler);
                        refcount_unref(handler);
                    }
                });
            }
        }
        cancel_cleanup(cl_handler2);
        if (finally_form != Qunbound) {
            the_stack->unwind_form = finally_form;
        }
        retval = Feval(form);
        cancel_cleanup(cl_handler);
        success = true;
    }, {
        retval = refcount_ref(stack_return);
    });
    // call this out here so it is not covered by the handlers
    if (success && success_form != Qunbound) {
        void *cl_handler = register_cleanup(&refcount_unref_as_callback, retval);
        WITH_CLEANUP(success_form, {
            refcount_unref(Feval(success_form));
        });
        cancel_cleanup(cl_handler);
    }
    return retval;
}
// clang-format on

// true if the form was a declare form
static bool parse_function_declare(LispVal *form, LispVal **name_ptr) {
    if (PAIRP(form) && HEAD(form) == Qdeclare) {
        FOREACH(elt, TAIL(form)) {
            if (name_ptr && PAIRP(elt) && HEAD(elt) == Qname
                && PAIRP(TAIL(elt))) {
                *name_ptr = HEAD(TAIL(elt));
            }
        }
        return true;
    }
    return false;
}

struct NameAndReturnTag {
    LispVal *name;
    LispVal *return_tag;
};

static LispVal *expand_function_body_callback(LispVal *body, void *data) {
    struct NameAndReturnTag *name_and_return_tag = data;
    LispVal *expansion = Fmacroexpand_toplevel(body, Qnil);
    // this mess checks that the call is exactly one of
    //  - (return-from 'symbol)
    //  - (return-from 'symbol val)
    if (PAIRP(expansion) && HEAD(expansion) == Qreturn_from
        && PAIRP(TAIL(expansion)) && LISTP(TAIL(TAIL(expansion)))
        && NILP(TAIL(TAIL(TAIL(expansion)))) && SYMBOLP(HEAD(TAIL(expansion)))
        && HEAD(TAIL(expansion)) == name_and_return_tag->name) {
        LispVal *retval = Qnil;
        if (!NILP(TAIL(TAIL(expansion)))) {
            retval = refcount_ref(HEAD(TAIL(TAIL(expansion))));
        }
        refcount_unref(expansion);
        return const_list(false, 4, Qinternal_real_return,
                          refcount_ref(name_and_return_tag->name),
                          refcount_ref(name_and_return_tag->return_tag),
                          retval);
    } else if (PAIRP(expansion) && HEAD(expansion) == Qinternal_real_return
               && list_length(expansion) == 4
               && HEAD(TAIL(expansion)) == name_and_return_tag->name
               && HEAD(TAIL(TAIL(expansion)))
                      != name_and_return_tag->return_tag) {
        Fsethead(TAIL(TAIL(expansion)), name_and_return_tag->return_tag);
    }
    return expansion;
}

static inline LispVal *expand_function_body(LispVal *name, LispVal *return_tag,
                                            LispVal *body) {
    return filter_body_tree(
        body, expand_function_body_callback,
        &(struct NameAndReturnTag) {.name = name, .return_tag = return_tag});
}

static LispVal *macroexpand_all_as_callback(LispVal *form, void *ignored) {
    return Fmacroexpand_all(form, Qnil);
}

static inline void expand_lambda_list_for_toplevel(LispVal *list) {
    expand_lambda_list(list, macroexpand_all_as_callback, NULL);
}

DEFMACRO(defun, "defun", (LispVal * name, LispVal *args, LispVal *body)) {
    CHECK_TYPE(TYPE_SYMBOL, name);
    if (parse_function_declare(HEAD(body), NULL)) {
        body = TAIL(body);
    }
    LispVal *return_tag =
        make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name));
    LispVal *func = Qnil;
    WITH_CLEANUP(return_tag, {
        LispVal *exp_args = Fcopy_list(args);
        WITH_CLEANUP(exp_args, {
            expand_lambda_list_for_toplevel(exp_args);
            LispVal *expanded_body =
                expand_function_body(name, return_tag, body);
            WITH_CLEANUP(expanded_body, {
                func =
                    make_lisp_function(name, return_tag, exp_args,
                                       the_stack->lexenv, expanded_body, false);
            });
        });
    });
    refcount_unref(Ffset(name, func));
    return func;
}

DEFMACRO(defmacro, "defmacro", (LispVal * name, LispVal *args, LispVal *body)) {
    CHECK_TYPE(TYPE_SYMBOL, name);
    if (parse_function_declare(HEAD(body), NULL)) {
        body = TAIL(body);
    }
    LispVal *return_tag =
        make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name));
    LispVal *func = Qnil;
    WITH_CLEANUP(return_tag, {
        LispVal *exp_args = Fcopy_list(args);
        WITH_CLEANUP(exp_args, {
            expand_lambda_list_for_toplevel(exp_args);
            LispVal *expanded_body =
                expand_function_body(name, return_tag, body);
            WITH_CLEANUP(expanded_body, {
                func =
                    make_lisp_function(name, return_tag, exp_args,
                                       the_stack->lexenv, expanded_body, true);
            });
        });
    });
    refcount_unref(Ffset(name, func));
    return func;
}

DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) {
    LispVal *name = Qunbound;
    if (parse_function_declare(HEAD(body), &name)) {
        body = TAIL(body);
    }
    LispVal *return_tag;
    LispVal *tag_name;
    if (name == Qunbound) {
        name = Qlambda;
        tag_name = Qnil;
        return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) Qnil)->name));
    } else {
        CHECK_TYPE(TYPE_SYMBOL, name);
        return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name));
        tag_name = name;
    }
    LispVal *func = Qnil;
    WITH_CLEANUP(return_tag, {
        LispVal *expanded_body =
            expand_function_body(tag_name, return_tag, body);
        LispVal *exp_args = Fcopy_list(args);
        WITH_CLEANUP(exp_args, {
            expand_lambda_list_for_toplevel(exp_args);
            WITH_CLEANUP(expanded_body, {
                func =
                    make_lisp_function(name, return_tag, args,
                                       the_stack->lexenv, expanded_body, false);
            });
        });
    });
    return func;
}

DEFMACRO(while, "while", (LispVal * cond, LispVal *body)) {
    LispVal *evaled_cond;
    while (!NILP(evaled_cond = Feval(cond))) {
        refcount_unref(evaled_cond);
        refcount_unref(Fprogn(body));
    }
    return Qnil;
}

DEFUN(make_symbol, "make-symbol", (LispVal * name)) {
    return make_lisp_symbol(name);
}

DEFUN(stringp, "stringp", (LispVal * val)) {
    return LISP_BOOL(STRINGP(val));
}

DEFUN(symbolp, "symbolp", (LispVal * val)) {
    return LISP_BOOL(SYMBOLP(val));
}

DEFUN(pairp, "pairp", (LispVal * val)) {
    return LISP_BOOL(PAIRP(val));
}

DEFUN(integerp, "integerp", (LispVal * val)) {
    return LISP_BOOL(INTEGERP(val));
}

DEFUN(floatp, "floatp", (LispVal * val)) {
    return LISP_BOOL(FLOATP(val));
}

DEFUN(vectorp, "vectorp", (LispVal * val)) {
    return LISP_BOOL(VECTORP(val));
}

DEFUN(functionp, "functionp", (LispVal * val)) {
    if (FUNCTIONP(val) && !((LispFunction *) val)->is_macro) {
        return Qt;
    } else if (SYMBOLP(val)) {
        LispVal *res = Fsymbol_function(val, Qt);
        LispVal *retval =
            LISP_BOOL(FUNCTIONP(res) && !((LispFunction *) res)->is_macro);
        refcount_unref(res);
        return retval;
    }
    return Qnil;
}

DEFUN(macrop, "macrop", (LispVal * val, LispVal *lexical_macros)) {
    if (FUNCTIONP(val) && !((LispFunction *) val)->is_builtin
        && ((LispFunction *) val)->is_macro) {
        return Qt;
    } else if (SYMBOLP(val)) {
        if (lookup_lexical_macro(val, lexical_macros) != Qunbound) {
            return Qt;
        }
        LispVal *res = Fsymbol_function(val, Qt);
        LispVal *retval =
            LISP_BOOL(FUNCTIONP(res) && !((LispFunction *) res)->is_builtin
                      && ((LispFunction *) res)->is_macro);
        refcount_unref(res);
        return retval;
    }
    return Qnil;
}

DEFUN(builtinp, "builtinp", (LispVal * val)) {
    if (FUNCTIONP(val) && ((LispFunction *) val)->is_builtin
        && !((LispFunction *) val)->is_macro) {
        return Qt;
    } else if (SYMBOLP(val)) {
        LispVal *res = Fsymbol_function(val, Qt);
        LispVal *retval =
            LISP_BOOL(FUNCTIONP(res) && ((LispFunction *) res)->is_builtin
                      && !((LispFunction *) res)->is_macro);
        refcount_unref(res);
        return retval;
    }
    return Qnil;
}

DEFUN(special_form_p, "special-form-p", (LispVal * val)) {
    if (FUNCTIONP(val) && ((LispFunction *) val)->is_builtin
        && ((LispFunction *) val)->is_macro) {
        return Qt;
    } else if (SYMBOLP(val)) {
        LispVal *res = Fsymbol_function(val, Qt);
        LispVal *retval =
            LISP_BOOL(FUNCTIONP(res) && ((LispFunction *) res)->is_builtin
                      && ((LispFunction *) res)->is_macro);
        refcount_unref(res);
        return retval;
    }
    return Qnil;
}

DEFUN(hashtablep, "hashtablep", (LispVal * val)) {
    return LISP_BOOL(HASHTABLEP(val));
}

DEFUN(user_pointer_p, "user-pointer-p", (LispVal * val)) {
    return LISP_BOOL(USER_POINTER_P(val));
}

DEFUN(atom, "atom", (LispVal * val)) {
    return LISP_BOOL(ATOM(val));
}

DEFUN(listp, "listp", (LispVal * val)) {
    return LISP_BOOL(LISTP(val));
}

DEFUN(keywordp, "keywordp", (LispVal * val)) {
    return LISP_BOOL(KEYWORDP(val));
}

DEFUN(numberp, "numberp", (LispVal * val)) {
    return LISP_BOOL(NUMBERP(val));
}

DEFUN(list_length, "list-length", (LispVal * list)) {
    return make_lisp_integer(list_length(list));
}

DEFUN(copy_list, "copy-list", (LispVal * list)) {
    if (NILP(list)) {
        return Qnil;
    }
    CHECK_TYPE(TYPE_PAIR, list);
    LispVal *copy = Qnil;
    LispVal *copy_end;
    WITH_PUSH_FRAME(Qnil, Qnil, true, {
        void *cl_cleanup = register_cleanup(&unref_double_ptr, &copy);
        FOREACH(elt, list) {
            if (NILP(copy)) {
                copy = Fpair(elt, Qnil);
                copy_end = copy;
            } else {
                LispVal *new_end = Fpair(elt, Qnil);
                Fsettail(copy_end, new_end);
                refcount_unref(new_end);
                copy_end = new_end;
            }
        }
        cancel_cleanup(cl_cleanup);
    });
    return copy;
}

DEFMACRO(and, "and", (LispVal * rest)) {
    LispVal *retval = Qnil;
    FOREACH(cond, rest) {
        LispVal *nc;
        WITH_CLEANUP_DOUBLE_PTR(retval, {
            nc = Feval(cond); //
        });
        if (NILP(nc)) {
            return Qnil;
        }
        retval = nc;
    }
    return retval;
}

DEFMACRO(or, "or", (LispVal * rest)) {
    FOREACH(cond, rest) {
        LispVal *nc = Feval(cond);
        if (!NILP(nc)) {
            return nc;
        }
    }
    return Qnil;
}

DEFUN(type_of, "type-of", (LispVal * obj)) {
    if (obj->type < 0 || obj->type >= N_LISP_TYPES) {
        return Qnil;
    }
    LispVal *name =
        make_lisp_string((char *) LISP_TYPE_NAMES[obj->type].name,
                         LISP_TYPE_NAMES[obj->type].len, true, true);
    LispVal *sym = Fintern(name);
    refcount_unref(name);
    return sym;
}

DEFUN(function_docstr, "function-docstr", (LispVal * func)) {
    if (FUNCTIONP(func)) {
        return ((LispFunction *) func)->doc;
    }
    LispFunction *fobj = (LispFunction *) Fsymbol_function(func, Qt);
    CHECK_TYPE(TYPE_FUNCTION, fobj);
    LispVal *retval = refcount_ref(fobj->doc);
    refcount_unref(fobj);
    return retval;
}

static bool call_eq_pred(LispVal *pred, LispVal *v1, LispVal *v2) {
    if (NILP(pred)) {
        return !NILP(Feq(v1, v2));
    } else {
        LispVal *fcall_args = const_list(true, 2, v1, v2);
        bool res = false;
        WITH_CLEANUP(fcall_args, {
            LispVal *lvpr = Ffuncall(pred, fcall_args); //
            res = !NILP(lvpr);
            refcount_unref(lvpr);
        });
        return res;
    }
}

DEFUN(plist_get, "plist-get",
      (LispVal * plist, LispVal *key, LispVal *def, LispVal *pred)) {
    for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) {
        if (call_eq_pred(pred, key, HEAD(cur))) {
            if (NILP(TAIL(cur))) {
                return refcount_ref(def);
            }
            return refcount_ref(HEAD(TAIL(cur)));
        }
    }
    return refcount_ref(def);
}

DEFUN(plist_set, "plist-set",
      (LispVal * plist, LispVal *key, LispVal *value, LispVal *pred)) {
    for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) {
        if (call_eq_pred(pred, key, HEAD(cur))) {
            if (NILP(TAIL(cur))) {
                break;
            }
            Fsethead(TAIL(cur), value);
            return refcount_ref(plist);
        }
    }
    return push_many(plist, 2, value, key);
}

DEFUN(plist_rem, "plist-rem", (LispVal * plist, LispVal *key, LispVal *pred)) {
    for (LispVal *prev = Qnil, *cur = plist; !NILP(cur);
         prev = cur, cur = TAIL(TAIL(cur))) {
        if (call_eq_pred(pred, key, HEAD(cur))) {
            if (NILP(prev)) {
                return refcount_ref(TAIL(TAIL(plist)));
            } else {
                Fsettail(TAIL(prev), TAIL(TAIL(cur)));
                return refcount_ref(plist);
            }
        }
    }
    return refcount_ref(plist);
}

DEFUN(plist_assoc, "plist-assoc",
      (LispVal * plist, LispVal *key, LispVal *pred)) {
    for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) {
        if (call_eq_pred(pred, key, HEAD(cur))) {
            return cur;
        }
    }
    return Qnil;
}

static void debug_dump_real(FILE *stream, void *obj, bool first) {
    switch (TYPEOF(obj)) {
    case TYPE_STRING: {
        LispString *str = (LispString *) obj;
        // TODO actually quote
        fputc('"', stream);
        fwrite(str->data, 1, str->length, stream);
        fputc('"', stream);
    } break;
    case TYPE_SYMBOL: {
        LispSymbol *sym = (LispSymbol *) obj;
        fwrite(sym->name->data, 1, sym->name->length, stream);
    } break;
    case TYPE_PAIR: {
        LispPair *pair = (LispPair *) obj;
        if (first) {
            fputc('(', stream);
        } else {
            fputc(' ', stream);
        }
        debug_dump_real(stream, pair->head, true);
        if (NILP(pair->tail)) {
            fputc(')', stream);
        } else if (PAIRP(pair->tail)) {
            debug_dump_real(stream, pair->tail, false);
        } else {
            fprintf(stream, " . ");
            debug_dump_real(stream, pair->tail, false);
            fputc(')', stream);
        }
    } break;
    case TYPE_INTEGER:
        fprintf(stream, "%jd", (intmax_t) ((LispInteger *) obj)->value);
        break;
    case TYPE_FLOAT:
        fprintf(stream, "%Lf", ((LispFloat *) obj)->value);
        break;
    case TYPE_VECTOR: {
        LispVector *vec = (LispVector *) obj;
        fputc('[', stream);
        for (size_t i = 0; i < vec->length; ++i) {
            if (i) {
                fputc(' ', stream);
            }
            debug_dump_real(stream, vec->data[i], true);
        }
        fputc(']', stream);
    } break;
    case TYPE_FUNCTION: {
        LispVal *name = ((LispFunction *) obj)->name;
        if (((LispFunction *) obj)->is_builtin) {
            fprintf(stream, "<builtin ");
        } else {
            if (name == Qlambda) {
                fprintf(stream, "<lambda"); // no space!
                name = NULL;
            } else {
                fprintf(stream, "<function ");
            }
        }
        if (name) {
            debug_dump_real(stream, name, false);
        }
        fprintf(stream, " at %#jx>", (uintmax_t) obj);
    } break;
    case TYPE_HASHTABLE: {
        LispHashtable *tbl = (LispHashtable *) obj;
        fprintf(stream, "<hashtable size=%zu count=%zu at %#jx>",
                tbl->table_size, tbl->count, (uintmax_t) obj);
    } break;
    case TYPE_USER_POINTER: {
        LispUserPointer *ptr = (LispUserPointer *) obj;
        fprintf(stream, "<user-pointer ptr=%#jx at %#jx>",
                (uintmax_t) ptr->data, (uintmax_t) obj);
    } break;
    default:
        fprintf(stream, "<object type=%ju at %#jx>",
                (uintmax_t) LISPVAL(obj)->type, (uintmax_t) obj);
        break;
    }
}

void debug_dump(FILE *stream, void *obj, bool newline) {
    debug_dump_real(stream, obj, true);
    if (newline) {
        fputc('\n', stream);
    }
}

void debug_print_hashtable(FILE *stream, LispVal *table) {
    debug_dump(stream, table, true);
    HASHTABLE_FOREACH(key, val, table, {
        fprintf(stream, "- ");
        debug_dump(stream, key, false);
        fprintf(stream, " = ");
        debug_dump(stream, val, true);
    });
}

static bool debug_print_tree_callback(void *obj, const RefcountList *trail,
                                      void *stream_raw) {
    FILE *stream = stream_raw;
    size_t depth = refcount_list_length(trail);
    for (size_t i = 0; i < depth; ++i) {
        fprintf(stream, " ");
    }
    fprintf(stream, "- ");
    debug_dump(stream, obj, true);
    return false;
}

void debug_print_tree(FILE *stream, void *obj) {
    refcount_debug_walk_tree(obj, debug_print_tree_callback, stream);
}