#include "lisp.h"

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

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

// TODO switch to stdio
#include <unistd.h>

// used to fix up some indentation or syntax highlighting problems
#define IGNORE() struct __ignored_struct

LispVal *LISP_TYPE_SYMS[N_LISP_TYPES] = {NULL};

// #######################
// # nil, unbound, and t #
// #######################
DEF_STATIC_STRING(_Qnil_name, "nil");
LispSymbol _Qnil = {
    .type = TYPE_SYMBOL,
    .name = &_Qnil_name,
    .package = Qnil,
    .plist = Qnil,
    .function = Qnil,
    .value = Qnil,
    .value_doc = Qnil,
    .is_const_value = true,
    .is_const_func = false,
    .is_special_var = true,
};

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

DEF_STATIC_STRING(_Qt_name, "t");
LispSymbol _Qt = {
    .type = TYPE_SYMBOL,
    .name = &_Qt_name,
    .package = Qnil,
    .plist = Qnil,
    .function = Qnil,
    .value = Qt,
    .value_doc = Qnil,
    .is_const_value = true,
    .is_const_func = true,
    .is_special_var = true,
};

// ###########################
// # Other important symbols #
// ###########################
DEF_STATIC_SYMBOL(backquote, "`");
DEF_STATIC_SYMBOL(comma, ",");
DEF_STATIC_SYMBOL(comma_at, ",@");
DEF_STATIC_SYMBOL(macro, "macro");
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");
DEF_STATIC_SYMBOL(no_backtrace, "no-backtrace");

DEF_STATIC_SYMBOL(symbol, "symbol");
DEF_STATIC_SYMBOL(integer, "integer");
DEF_STATIC_SYMBOL(float, "float");
DEF_STATIC_SYMBOL(function, "function");
DEF_STATIC_SYMBOL(hash_table, "hash_table");
DEF_STATIC_SYMBOL(user_pointer, "user_pointer");
DEF_STATIC_SYMBOL(package, "package");
DEF_STATIC_SYMBOL(record, "record");

// ############################
// # Global Package Variables #
// ############################
LispVal *package_table = Qnil;
LispVal *system_package = Qnil;
LispVal *keyword_package = Qnil;
LispVal *current_package = Qnil;

// #############################
// # Allocation and references #
// #############################
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 *lisp_malloc0(size_t size) {
    void *ptr = lisp_malloc(size);
    if (ptr && size) {
        memset(ptr, 0, size);
    }
    return ptr;
}

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

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);
        *held = refcount_list_push(*held, ((LispSymbol *) obj)->value_doc);
        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: {
        LispHashtable *ht = obj;
        HT_FOREACH_VALID_INDEX(obj, i) {
            *held = refcount_list_push(*held, HASH_KEY(obj, i));
            *held = refcount_list_push(*held, HASH_VALUE(obj, i));
        }
        if (ht->eq_fn != Qstrings_equal) {
            *held = refcount_list_push(*held, ht->eq_fn);
        }
        if (ht->hash_fn != Qhash_string) {
            *held = refcount_list_push(*held, ht->hash_fn);
        }
        return true;
    }
    case TYPE_FUNCTION: {
        LispFunction *fn = obj;
        *held = refcount_list_push(*held, fn->name);
        *held = refcount_list_push(*held, fn->props);
        *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;
    }
    case TYPE_PACKAGE: {
        LispPackage *pkg = obj;
        *held = refcount_list_push(*held, pkg->name);
        *held = refcount_list_push(*held, pkg->imported);
        *held = refcount_list_push(*held, pkg->obarray);
        *held = refcount_list_push(*held, pkg->exported_sym_table);
        return true;
    }
    case TYPE_RECORD: {
        LispRecord *rec = obj;
        *held = refcount_list_push(*held, rec->record_type);
        for (size_t i = 0; i < rec->length; ++i) {
            *held = refcount_list_push(*held, rec->data[i]);
        }
        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 *ht = obj;
        lisp_free(ht->key_vals);
    } break;
    case TYPE_FUNCTION:
    case TYPE_SYMBOL:
    case TYPE_PAIR:
    case TYPE_INTEGER:
    case TYPE_FLOAT:
    case TYPE_PACKAGE:
    case TYPE_RECORD:
        // no internal data to free
        break;
    default:
        abort();
    }
    lisp_free(obj);
}

// ################
// # Constructors #
// ################
#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 *make_lisp_symbol(LispVal *name) {
    CHECK_TYPE(TYPE_STRING, name);
    CONSTRUCT_OBJECT(self, LispSymbol, TYPE_SYMBOL);
    self->name = (LispString *) refcount_ref(name);
    self->package = Qnil;
    self->plist = Qnil;
    self->function = Qnil;
    self->value = Qunbound;
    self->value_doc = Qnil;
    self->is_const_value = false;
    self->is_const_func = false;
    self->is_special_var = 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);
}

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;
}

LispVal *make_lisp_function(LispVal *name, LispVal *return_tag, LispVal *args,
                            LispVal *lexenv, LispVal *body, LispVal *doc,
                            bool is_macro, LispVal *props) {
    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);
    self->doc = refcount_ref(doc);
    self->body = refcount_ref(body);
    self->props = refcount_ref(props);
    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->key_vals =
        lisp_malloc0(sizeof(struct HashtableEntry) * self->table_size);
    self->count = 0;
    // needed during early initialization
    if (eq_fn == Qstrings_equal) {
        self->eq_fn = eq_fn;
    } else {
        self->eq_fn = refcount_ref(eq_fn);
    }
    if (hash_fn == Qhash_string) {
        self->hash_fn = hash_fn;
    } else {
        self->hash_fn = refcount_ref(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);
}

LispVal *make_lisp_package(LispVal *name) {
    CHECK_TYPE(TYPE_STRING, name);
    CONSTRUCT_OBJECT(self, LispPackage, TYPE_PACKAGE);
    self->name = refcount_ref(name);
    self->obarray = make_lisp_hashtable(Qstrings_equal, Qhash_string);
    self->exported_sym_table = make_lisp_hashtable(Qnil, Qnil);
    self->imported = Qnil;
    return LISPVAL(self);
}

LispVal *make_lisp_record(LispVal *type, size_t length) {
    CONSTRUCT_OBJECT(self, LispRecord, TYPE_RECORD);
    self->record_type = refcount_ref(type);
    self->function = Qnil;
    self->data = lisp_malloc(sizeof(LispVal *) * length);
    for (size_t i = 0; i < length; ++i) {
        self->data[i] = Qnil;
    }
    self->length = length;
    return LISPVAL(self);
}

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 Qhash_table_p;
    case TYPE_USER_POINTER:
        return Quser_pointer_p;
    case TYPE_PACKAGE:
        return Qpackagep;
    case TYPE_RECORD:
        return Qrecordp;
    default:
        abort();
    }
}

// ###############################
// # Initialization and Shutdown #
// ###############################

static void register_symbols_and_functions(void);

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;

    REGISTER_SYMBOL_NOINTERN(unbound);
    REGISTER_SYMBOL_NOINTERN(nil);
    REGISTER_SYMBOL_NOINTERN(t);

    LISP_TYPE_SYMS[TYPE_STRING] = Qstring;
    LISP_TYPE_SYMS[TYPE_SYMBOL] = Qsymbol;
    LISP_TYPE_SYMS[TYPE_PAIR] = Qpair;
    LISP_TYPE_SYMS[TYPE_INTEGER] = Qinteger;
    LISP_TYPE_SYMS[TYPE_FLOAT] = Qfloat;
    LISP_TYPE_SYMS[TYPE_VECTOR] = Qvector;
    LISP_TYPE_SYMS[TYPE_FUNCTION] = Qfunction;
    LISP_TYPE_SYMS[TYPE_HASHTABLE] = Qhash_table;
    LISP_TYPE_SYMS[TYPE_USER_POINTER] = Quser_pointer;
    LISP_TYPE_SYMS[TYPE_PACKAGE] = Qpackage;
    LISP_TYPE_SYMS[TYPE_RECORD] = Qrecord;

    package_table = make_lisp_hashtable(Qstrings_equal, Qhash_string);
    LispVal *sys_package_name = STATIC_STRING("sys");
    system_package = make_lisp_package(sys_package_name);
    refcount_unref(Fregister_package(system_package));
    refcount_unref(sys_package_name);
    LispVal *kw_package_name = STATIC_STRING("kw");
    keyword_package = make_lisp_package(kw_package_name);
    refcount_unref(Fregister_package(keyword_package));
    refcount_unref(kw_package_name);
    current_package = refcount_ref(system_package);

    register_symbols_and_functions();
}

void lisp_shutdown(void) {
    garbage_collect();

    refcount_unref(current_package);
    refcount_unref(system_package);
    refcount_unref(package_table);

    refcount_context_destroy(refcount_default_context);
    refcount_default_context = NULL;
}

// ###############################
// # General and Misc. Functions #
// ###############################
DEFUN(exit, "exit", (LispVal * code), "(&opt code)",
      "Exit with CODE, defaulting to zero.") {
    if (!NILP(code) && !INTEGERP(code)) {
        Fthrow(Qtype_error, Qnil);
    }
    Fthrow(Qshutdown_signal, const_list(true, 1, code));
}

DEFUN(id, "id", (LispVal * obj), "(obj)",
      "Return a number identifying OBJ uniquely among all currently live "
      "objects.") {
    return make_lisp_integer((int64_t) obj);
}

DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)",
      "Return non-nil if OBJ1 and OBJ2 are the same object. Objects which are "
      "eq also have the same id.") {
    return LISP_BOOL(obj1 == obj2);
}

static bool pairs_equal_internal(LispVal *obj1, LispVal *obj2) {
    while (PAIRP(obj1) && PAIRP(obj2)
           && !NILP(Fequal(HEAD(obj1), HEAD(obj2)))) {
        obj1 = TAIL(obj1);
        obj2 = TAIL(obj2);
    }
    return !PAIRP(obj1) && !NILP(Fequal(obj1, obj2));
}

DEFUN(equal, "equal", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)",
      "Return non-nil if OBJ1 and OBJ2 are structurally equal.") {
    if (obj1 == obj2) {
        return Qt;
    } else if (TYPEOF(obj1) != TYPEOF(obj2)) {
        return Qnil;
    }
    switch (TYPEOF(obj1)) {
    case TYPE_SYMBOL:
    case TYPE_FUNCTION:
    case TYPE_PACKAGE:
        // only if they are the same object (checked above)
        return Qnil;
    case TYPE_PAIR:
        return LISP_BOOL(pairs_equal_internal(obj1, obj2));
    case TYPE_USER_POINTER:
        return LISP_BOOL(USERPTR(void *, obj1) == USERPTR(void *, obj2));
    case TYPE_STRING:
        return Fstrings_equal(obj1, obj2);
    case TYPE_INTEGER:
        return LISP_BOOL(((LispInteger *) obj1)->value
                         == ((LispInteger *) obj2)->value);
    case TYPE_FLOAT:
        return LISP_BOOL(((LispFloat *) obj1)->value
                         == ((LispFloat *) obj2)->value);
    case TYPE_VECTOR: {
        LispVector *v1 = (LispVector *) obj1;
        LispVector *v2 = (LispVector *) obj2;
        if (v1->length != v2->length) {
            return Qnil;
        }
        for (size_t i = 0; i < v1->length; ++i) {
            if (!Fequal(v1->data[i], v2->data[i])) {
                return Qnil;
            }
        }
        return Qt;
    }
    case TYPE_HASHTABLE: {
        LispHashtable *t1 = (LispHashtable *) obj1;
        LispHashtable *t2 = (LispHashtable *) obj2;
        if (t1->count != t2->count || NILP(Fequal(t1->eq_fn, t2->eq_fn))
            || NILP(Fequal(t1->hash_fn, t2->hash_fn))) {
            return Qnil;
        }
        HT_FOREACH_VALID_INDEX(t1, i) {
            if (NILP(Fequal(HASH_VALUE(t1, i),
                            gethash(obj2, HASH_KEY(t1, i), Qunbound)))) {
                return Qnil;
            }
        }
        return Qt;
    }
    case TYPE_RECORD: {
        // TODO implement this
        return Qnil;
    }
    default:
        abort();
    }
}

static void breakpoint(int64_t id) {}
DEFUN(breakpoint, "breakpoint", (LispVal * id), "(&opt id)", "Do nothing.") {
    if (NILP(id)) {
        breakpoint(0);
    } else {
        CHECK_TYPE(TYPE_INTEGER, id);
        breakpoint(((LispInteger *) id)->value);
    }
    return Qnil;
}

DEFUN(not, "not", (LispVal * obj), "(obj)",
      "Return t if OBJ is nil, otherwise, return nil.") {
    return NILP(obj) ? Qt : Qnil;
}

DEFUN(
    type_of, "type-of", (LispVal * obj), "(obj)",
    "Return a symbol that describes the type of OBJ. This is for informational "
    "purposes only, don't use this to test for objects of a specific type.") {
    if (TYPEOF(obj) != TYPE_RECORD) {
        return refcount_ref(LISP_TYPE_SYMS[TYPEOF(obj)]);
    } else {
        return refcount_ref(((LispRecord *) obj)->record_type);
    }
}

DEFUN(user_pointer_p, "user-pointer-p", (LispVal * val), "(obj)",
      "Return non-nil if OBJ is a user pointer.") {
    return LISP_BOOL(USER_POINTER_P(val));
}

DEFUN(callablep, "callablep", (LispVal * val), "(obj)",
      "Return non-nil if OBJ is callable.") {
    if (FUNCTIONP(val)) {
        return refcount_ref(val);
    } else if (SYMBOLP(val)) {
        return Fcallablep(Fsymbol_function(val, Qt));
    } else if (PAIRP(val) && HEAD(val) == Qlambda) {
        return refcount_ref(val);
    } else if (CALLABLE_RECORD_P(val)) {
        return Fcallablep(((LispRecord *) val)->function);
    }
    return Qnil;
}

DEFUN(native_type_p, "native-type-p", (LispVal * sym), "(sym)",
      "Return non-nil if SYM names a native type.") {
    CHECK_TYPE(TYPE_SYMBOL, sym);
    for (size_t i = 0; i < N_LISP_TYPES; ++i) {
        if (!NILP(Feq(LISP_TYPE_SYMS[i], sym))) {
            return Qt;
        }
    }
    return Qnil;
}

// ##################################
// # Evaluation and Macro Expansion #
// ##################################
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 = Qnil;
        FOREACH(elt, args) {
            if (NILP(final_args)) {
                final_args = Fpair(Feval(elt, lexenv), Qnil);
                refcount_unref(HEAD(final_args));
                end = final_args;
            } else {
                LispVal *new_end = Fpair(Feval(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_malloc0(sizeof(LispVal *) * raw_count);
    LispVal *rest = Qnil;
    LispVal *rest_end = Qnil;
    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(func->rest_arg)) {
            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] = func->distinguish_unpassed ? Qunbound : 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) {
        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 new_lexical_var(LispVal **lexenv, LispVal *name, LispVal *value) {
    if (SPECIALP(name)) {
        push_to_lexenv(&the_stack->dynenv, name, value);
    } else {
        push_to_lexenv(lexenv, name, value);
    }
}

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
            }
            new_lexical_var(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));
            new_lexical_var(lexenv, oad->name, arg);
            if (!NILP(oad->pred_var)) {
                new_lexical_var(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);
            new_lexical_var(lexenv, oad->name, value);
            if (!NILP(oad->pred_var)) {
                new_lexical_var(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;
                }
            }
            new_lexical_var(lexenv, func->rest_arg, args);
            // done processing
            goto done_adding;
        }
        args = TAIL(args);
    }
    if (!NILP(rargs)) {
        goto missing_required;
    }
    HT_FOREACH_VALID_INDEX(func->kwargs, i) {
        struct OptArgDesc *oad =
            USERPTR(struct OptArgDesc, HASH_VALUE(func->kwargs, i));
        // 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, the_stack->lexenv);
            new_lexical_var(lexenv, oad->name, eval_res);
            refcount_unref(eval_res);
            if (!NILP(oad->pred_var)) {
                new_lexical_var(lexenv, oad->pred_var, Qnil);
            }
        }
    }
    FOREACH(arg, oargs) {
        struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg);
        LispVal *default_val = Feval(oad->default_form, the_stack->lexenv);
        new_lexical_var(lexenv, oad->name, default_val);
        refcount_unref(default_val);
        if (!NILP(oad->pred_var)) {
            new_lexical_var(lexenv, oad->pred_var, Qnil);
        }
    }
    if (!NILP(func->rest_arg)) {
        new_lexical_var(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(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),
             "(entry dest)", "Internal function.") {
    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", system_package);
    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 *) Fcallablep(func);
    if (PAIRP(fobj)) {
        LispVal *real_fobj = Feval(LISPVAL(fobj), args_lexenv);
        refcount_unref(fobj);
        fobj = (LispFunction *) real_fobj;
    }
    void *cl_handle = register_cleanup(refcount_unref_as_callback, fobj);
    if (NILP(fobj)) {
        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), 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);
    refcount_unref(fobj);
    return retval;
}

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

static inline LispVal *find_dynamic_value_on_stack(LispVal *key) {
    if (!the_stack) {
        return Qunbound;
    }
    return Fplist_get(the_stack->dynenv, key, Qunbound, Qnil);
}

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

DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv), "(eval &opt lexenv)",
      "Evaluate FORM in the lexical environment LEXENV.") {
    switch (TYPEOF(form)) {
    case TYPE_STRING:
    case TYPE_FUNCTION:
    case TYPE_INTEGER:
    case TYPE_FLOAT:
    case TYPE_HASHTABLE:
    case TYPE_USER_POINTER:
    case TYPE_PACKAGE:
    case TYPE_RECORD:
        // the above all are self-evaluating
        return refcount_ref(form);
    case TYPE_SYMBOL:
        if (KEYWORDP(form)) {
            return refcount_ref(form);
        } else {
            return symbol_value_in_lexenv(lexenv, form);
        }
    case TYPE_VECTOR: {
        LispVector *vec = (LispVector *) form;
        LispVal **elts = lisp_malloc0(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(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(funcall, "funcall", (LispVal * function, LispVal *rest),
      "(function &rest args)", "Call FUNCTION with ARGS as its arguments.") {
    return call_function(function, rest, Qnil, false, false);
}

DEFUN(apply, "apply", (LispVal * function, LispVal *rest),
      "(function &rest args)",
      "Call FUNCTION with ARGS as its arguments. If the last element of ARGS "
      "is a list, use its elements as arguments as well.") {
    LispVal *args = Qnil;
    LispVal *end = Qnil;
    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;
}

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),
      "(form &opt lexical-macros)",
      "Expand the toplevel macro one time in FORM. LEXICAL-MACROS is a plist "
      "of symbols and functions that are considered to be addition macros to "
      "expand. LEXICAL-MACROS take priority over global 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 if (PAIRP(HEAD(form)) && HEAD(HEAD(form)) == Qlambda) {
            fobj = (LispFunction *) Feval(HEAD(form), the_stack->lexenv);
            assert(FUNCTIONP(fobj));
        } 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(fobj), 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), "(form &opt lexical-macros)",
      "Expand the toplevel of FORM until it is no longer a macro. "
      "LEXICAL-MACROS is the same as for macroexpand-1.") {
    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_DEFMACRO(internal_real_return, "internal-real-return",
                (LispVal * name, LispVal *tag, LispVal *value),
                "(name tag value)", " Internal function.") {
    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, the_stack->lexenv)));
        }
    }
    Fthrow(Qreturn_frame_error, const_list(false, 2, refcount_ref(name),
                                           Feval(value, the_stack->lexenv)));
}

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) Flambda) {
        if (!LISTP(args)) {
            return;
        }
        LispVal *expand_from = TAIL(args); // skip lambda list
        if (!LISTP(expand_from)) {
            return;
        }
        LispVal *copy = Fcopy_list(HEAD(args));
        Fsethead(args, copy);
        refcount_unref(copy);
        expand_lambda_list(HEAD(args), 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 && FUNCTIONP(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 = Qnil;
    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), "(form &opt lexical-macros)",
      "Expand all macros in the toplevel and arguments of FORM. LEXICAL-MACROS "
      "is as it is for macroexpand-1.") {
    return filter_body_form(form, macroexpand_toplevel_as_callback,
                            lexical_macros);
}

// #################
// # Special Forms #
// #################
DEFMACRO(quote, "'", (LispVal * form), "(form)", "Return FORM.") {
    return refcount_ref(form);
}

DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil),
         "(cond then &rest else)",
         "If COND evaluates to a non-nil value, evaluate THEN, otherwise, "
         "evaluate each form in ELSE.") {
    LispVal *res = Feval(cond, the_stack->lexenv);
    LispVal *retval = Qnil;
    WITH_PUSH_FRAME(Qnil, Qnil, true, {
        if (!NILP(res)) {
            retval = Feval(t, the_stack->lexenv);
        } else {
            retval = Fprogn(nil);
        }
    });
    return retval;
}

static void set_symbol_in_lexenv(LispVal *key, LispVal *newval,
                                 LispVal *lexenv) {
    if (VALUE_CONSTANTP(key)) {
        Fthrow(Qconstant_value_error, Fpair(key, Qnil));
    }
    LispVal *val_pair = Qnil;
    if (SPECIALP(key)) {
        val_pair = Fplist_assoc(the_stack->dynenv, key, Qnil);
    } else {
        val_pair = Fplist_assoc(lexenv, key, Qnil);
    }
    if (PAIRP(val_pair)) {
        Fsethead(TAIL(val_pair), newval);
    } else {
        refcount_unref(((LispSymbol *) key)->value);
        ((LispSymbol *) key)->value = refcount_ref(newval);
    }
}

DEFMACRO(
    setq, "setq", (LispVal * args), "(&rest args)",
    "ARGS is a plist of symbols and values. Set each of the symbols to their "
    "respective value. Return the last value. Each symbol is set lexically if "
    "a lexical binding exists. Otherwise the symbol's value is altered.") {
    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), the_stack->lexenv);
        WITH_CLEANUP(retval, {
            set_symbol_in_lexenv(name, retval, the_stack->lexenv); //
        });
    }
    return retval;
}

DEFMACRO(progn, "progn", (LispVal * forms), "(&rest forms)",
         "Evaluate each of FORMS.") {
    LispVal *retval = Qnil;
    FOREACH(form, forms) {
        refcount_unref(retval);
        retval = Feval(form, the_stack->lexenv);
    }
    return retval;
}

DEFMACRO(
    condition_case, "condition-case", (LispVal * form, LispVal *rest),
    "(form &rest handlers)",
    "Evaluate FORM. If an exception is thrown, evaluate the corresponding "
    "handler.\n"
    "Each handler is HANDLERS is a list with the head being a list of a "
    "variable followed by a symbol or a list of symbols and the tail "
    "being any number of forms. Each symbol is an error to catch. During "
    "the executing of the following forms, the variable will be bound to "
    "information about the exception.\n"
    "Optionally, the symbols :success or :finally can be used in place of an "
    "error or list of errors. :finally forms will be weather or not an error "
    "is caught after FORM is done being evaluated. :success forms will be run "
    "if the evaluation of FORM finished with no errors.") {
    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) == Qkw_success) {
                    if (success_form != Qunbound) {
                        Fthrow(Qmalformed_lambda_list_error, Qnil);
                    }
                    success_form = Fpair(Qprogn, TAIL(entry));
                } else if (HEAD(entry) == Qkw_finally) {
                    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, {
                        IGNORE(); // unconfuse clang-format
                        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, the_stack->lexenv);
            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, the_stack->lexenv)); //
        });
        cancel_cleanup(cl_handler);
    }
    return retval;
}

// true if the form was a declare form
static bool parse_function_declare(LispVal *form, LispVal **name_ptr,
                                   bool *is_macro_ptr, LispVal *props_ht) {
    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));
            } else if (is_macro_ptr
                       && (elt == Qmacro
                           || (PAIRP(elt) && HEAD(elt) == Qmacro))) {
                *is_macro_ptr = true;
            } else if (SYMBOLP(elt)) {
                puthash(props_ht, elt, Qt);
            } else if (PAIRP(elt) && SYMBOLP(HEAD(elt)) && LISTP(TAIL(elt))) {
                puthash(props_ht, HEAD(elt), 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(lambda, "lambda", (LispVal * args, LispVal *body), "(args &rest body)",
         "Return a new function.") {
    LispVal *doc = Qnil;
    if (STRINGP(HEAD(body))) {
        doc = HEAD(body);
        body = TAIL(body);
    }
    LispVal *name = Qunbound;
    bool is_macro = false;
    LispVal *props_ht = make_lisp_hashtable(Qnil, Qnil);
    if (parse_function_declare(HEAD(body), &name, &is_macro, props_ht)) {
        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 {
        if (!SYMBOLP(name)) {
            refcount_unref(props_ht);
            CHECK_TYPE(TYPE_SYMBOL, name);
        }
        return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name));
        tag_name = name;
    }
    LispVal *func = Qnil;
    WITH_CLEANUP(props_ht, {
        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,
                                              doc, is_macro, props_ht);
                });
            });
        });
    });
    return func;
}

DEFMACRO(while, "while", (LispVal * cond, LispVal *body), "(cond &rest body)",
         "Evaluate COND, if its result is non-nil evaluate BODY. Repeat this "
         "until COND returns nil. Then return nil.") {
    LispVal *evaled_cond;
    while (!NILP(evaled_cond = Feval(cond, the_stack->lexenv))) {
        refcount_unref(evaled_cond);
        refcount_unref(Fprogn(body));
    }
    return Qnil;
}

DEFMACRO(and, "and", (LispVal * rest), "(&rest rest)",
         "Evaluate the first argument in REST. If its result is non-nil "
         "evaluate the next argument. Otherwise, return nil. Repeat this until "
         "one argument returns nil or there are no arguments left. If no "
         "argument returned nil, return the result of the last argument.") {
    LispVal *retval = Qnil;
    FOREACH(cond, rest) {
        LispVal *nc;
        WITH_CLEANUP(retval, {
            nc = Feval(cond, the_stack->lexenv); //
        });
        if (NILP(nc)) {
            return Qnil;
        }
        retval = nc;
    }
    return retval;
}

DEFMACRO(or, "or", (LispVal * rest), "(&rest rest)",
         "Evaluate the first argument in REST. If it returns non-nil, return "
         "its value. Oterwise, evaluate the next argument. Repeat this until "
         "there are no more arguments at which time nil is returned.") {
    FOREACH(cond, rest) {
        LispVal *nc = Feval(cond, the_stack->lexenv);
        if (!NILP(nc)) {
            return nc;
        }
    }
    return Qnil;
}

DEFMACRO(in_package, "in-package", (LispVal * package), "(package)",
         "Set the current package to PACKAGE.") {
    return Fset_current_package(package);
}

DEFMACRO(return_from, "return-from", (LispVal * name, LispVal *value),
         "(name &opt value)", "Return VALUE from the function named NAME.") {
    Fthrow(Qreturn_frame_error, const_list(false, 2, refcount_ref(name),
                                           Feval(value, the_stack->lexenv)));
}

// ######################
// # Function Functions #
// ######################
DEFUN(functionp, "functionp", (LispVal * val), "(obj)",
      "Return non-nil if OBJ is a non-macro function object or a symbol whose "
      "value as a function resolves to a non-macro function object.") {
    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),
      "(obj &opt lexical-macros)",
      "Return non-nil if OBJ is a macro object, a symbol whose value as a "
      "function resolves to a macro object, or a symbol with a definition in "
      "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), "(obj)",
      "Return non-nil if OBJ is a built-in function or a symbol whose value as "
      "a function resolves to a built-in function.") {
    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), "(obj)",
      "Return non-nil if OBJ is a special-function (built-in macro) or a "
      "symbol whose value as a function resolves to such a function.") {
    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(function_docstr, "function-docstr", (LispVal * func), "(func)",
      "Return the documentation string for FUNC, or nil if it has no "
      "documentation string.") {
    if (FUNCTIONP(func)) {
        return ((LispFunction *) func)->doc;
    }
    LispFunction *fobj = (LispFunction *) Fsymbol_function(func, Qt);
    if (!FUNCTIONP(fobj)) {
        refcount_unref(fobj);
        CHECK_TYPE(TYPE_FUNCTION, fobj);
    }
    LispVal *retval = refcount_ref(fobj->doc);
    refcount_unref(fobj);
    return retval;
}

DEFUN(function_properties, "function-properties", (LispVal * func), "(func)",
      "Return the property hash table of FUNC.") {
    CHECK_TYPE(TYPE_FUNCTION, func);
    return refcount_ref(((LispFunction *) func)->props);
}

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);
}

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 = Qnil;
    LispVal *oargs_end = Qnil;

    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, Qnil, Qnil);
                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));
}

// ###########################
// # Pair and List Functions #
// ###########################
DEFUN(pairp, "pairp", (LispVal * val), "(obj)",
      "Return non-nil if OBJ is a pair.") {
    return LISP_BOOL(PAIRP(val));
}

DEFUN(atom, "atom", (LispVal * val), "(obj)",
      "Return non-nil if OBJ is not a pair. Nil is not a pair.") {
    return LISP_BOOL(ATOM(val));
}

DEFUN(pair, "pair", (LispVal * head, LispVal *tail), "(head tail)",
      "Construct a new pair from HEAD and TAIL.") {
    return make_lisp_pair(head, tail);
}

DEFUN(head, "head", (LispVal * list), "(list)",
      "Return the first element in LIST.") {
    return refcount_ref(HEAD(list));
}

DEFUN(tail, "tail", (LispVal * list), "(list)",
      "Return everything but the first element in LIST.") {
    return refcount_ref(TAIL(list));
}

DEFUN(sethead, "sethead", (LispVal * pair, LispVal *head), "(pair head)",
      "Set the head of PAIR to 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), "(pair tail)",
      "Set the tail of PAIR to TAIL.") {
    CHECK_TYPE(TYPE_PAIR, pair);
    refcount_unref(((LispPair *) pair)->tail);
    ((LispPair *) pair)->tail = refcount_ref(tail);
    return Qnil;
}

// lists
DEFUN(listp, "listp", (LispVal * val), "(obj)",
      "Return non-nil if OBJ is a pair or nil.") {
    return LISP_BOOL(LISTP(val));
}

DEFUN(list_length, "list-length", (LispVal * list), "(list)",
      "Return the length of LIST. Throw an error if LIST is circular.") {
    return make_lisp_integer(list_length(list));
}

DEFUN(copy_list, "copy-list", (LispVal * list), "(list)",
      "Return a shallow copy of 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;
}

DEFUN(copy_tree, "copy-tree", (LispVal * tree), "(tree)",
      "Return a copy of TREE and each sub-tree of 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;
}

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;
}

// plists
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),
      "(plist key &opt def pred)",
      "Find and return the value associated with KEY in PLIST. If it is not "
      "found, return DEF. Keys are compared with 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),
      "(plist key value &opt pred)",
      "Set the value associated with KEY in PLIST to VALUE. Keys are compared "
      "with PRED. Return the modified PLIST.") {
    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),
      "(plist key &rest pred)",
      "Removed KEY and its associated value from PLIST. Keys are compared with "
      "PRED. Return the modified PLIST.") {
    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), "(plist key &rest pred)",
      "Return the sub-list starting with KEY from PLIST. Keys are compared "
      "with PRED.") {
    for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) {
        if (call_eq_pred(pred, key, HEAD(cur))) {
            return cur;
        }
    }
    return Qnil;
}

// #####################
// # Package Functions #
// #####################
static LispVal *normalize_package(LispVal *arg) {
    if (STRINGP(arg) || SYMBOLP(arg)) {
        LispVal *found = Ffind_package(arg);
        if (!PACKAGEP(found)) {
            refcount_unref(found);
            Fthrow(Qunknown_package_error, const_list(true, 1, arg));
        }
        return found;
    } else if (PACKAGEP(arg)) {
        return refcount_ref(arg);
    } else {
        Fthrow(Qtype_error, Qnil);
    }
}

DEFUN(packagep, "packagep", (LispVal * val), "(obj)",
      "Return non-nil if OBJ is a package object.") {
    return LISP_BOOL(PACKAGEP(val));
}

DEFUN(make_package, "make-package", (LispVal * name), "(name)",
      "Return a new un-registed package object called NAME.") {
    if (SYMBOLP(name)) {
        name = Fsymbol_name(name);
    } else {
        name = refcount_ref(name);
    }
    LispVal *np = make_lisp_package(name);
    refcount_unref(name);
    return np;
}

DEFUN(package_name, "package-name", (LispVal * package), "(package)",
      "Return the name of PACKAGE.") {
    CHECK_TYPE(TYPE_PACKAGE, package);
    return LISPVAL(((LispPackage *) package)->name);
}

DEFUN(register_package, "register-package", (LispVal * package), "(package)",
      "Register PACKAGE with the reader.") {
    if (STRINGP(package)) {
        package = make_lisp_package(package);
    } else if (SYMBOLP(package)) {
        package = make_lisp_package(LISPVAL(((LispSymbol *) package)->name));
    } else {
        CHECK_TYPE(TYPE_PACKAGE, package);
        package = refcount_ref(package);
    }
    LispVal *found = Ffind_package(package);
    if (!NILP(found)) {
        refcount_unref(package);
        Fthrow(Qpackage_exists_error, const_list(true, 1, package));
    }
    puthash(package_table, LISPVAL(((LispPackage *) package)->name), package);
    return package;
}

DEFUN(current_package, "current-package", (void), "()",
      "Return the current package.") {
    return refcount_ref(current_package);
}

DEFUN(set_current_package, "set-current-package", (LispVal * package),
      "(package)", "Set the current package.") {
    LispVal *new = normalize_package(package);
    LispVal *old = current_package;
    current_package = new;
    refcount_unref(old);
    return refcount_ref(current_package);
}

DEFUN(mapsymbols, "mapsymbols", (LispVal * func, LispVal *package),
      "(func &opt package)",
      "Call FUNC for each symbol in PACKAGE, defaulting to the current "
      "package.") {
    LispPackage *pkg;
    if (NILP(package)) {
        pkg = refcount_ref(current_package);
    } else {
        pkg = (LispPackage *) normalize_package(package);
    }
    WITH_CLEANUP(pkg, {
        IGNORE();
        HT_FOREACH_VALID_INDEX(pkg->obarray, i) {
            LispVal *args = const_list(true, 1, HASH_VALUE(pkg->obarray, i));
            refcount_unref(Ffuncall(func, args));
        }
    });
    return Qnil;
}

DEFUN(export_symbol, "export-symbol", (LispVal * symbol), "(symbol)",
      "Mark SYMBOL as exported from its package. If SYMBOL is not interned in "
      "any package, throw and error.") {
    if (SYMBOLP(symbol)) {
        LispSymbol *sym = (LispSymbol *) symbol;
        LispPackage *pkg = (LispPackage *) sym->package;
        if (NILP(pkg)) {
            Fthrow(Qtype_error, Qnil);
        }
        puthash(pkg->exported_sym_table, symbol, Qt);
    } else if (LISTP(symbol)) {
        FOREACH(cur, symbol) {
            CHECK_TYPE(TYPE_SYMBOL, cur);
            Fexport_symbol(cur);
        }
    } else {
        Fthrow(Qtype_error,
               const_list(false, 2, const_list(false, 2, Qlistp, Qsymbolp),
                          symbol));
    }
    return Qnil;
}

// recursively search all imports of SOURCE, looking for TARGET
static bool check_recursive_import(LispVal *source, LispVal *target) {
    FOREACH(entry, ((LispPackage *) source)->imported) {
        if (HEAD(entry) == target
            || check_recursive_import(HEAD(entry), target)) {
            return true;
        }
    }
    return false;
}

DEFUN_DISTINGUISHED(import_package, "import-package",
                    (LispVal * source, LispVal *names, LispVal *target),
                    "(source names &opt target)",
                    "Import each symbol with a name in NAMES from SOURCE into "
                    "TARGET. TARGET defaults to the current package. If NAMES "
                    "is t, import every symbol exported by SOURCE.") {
    LispPackage *target_pkg;
    if (target == Qunbound || NILP(target)) {
        target_pkg = refcount_ref(current_package);
    } else {
        target_pkg = (LispPackage *) normalize_package(target);
    }
    if (!PACKAGEP(target_pkg)) {
        refcount_unref(target_pkg);
        Fthrow(Qimport_error, Qnil);
    }
    if (names == Qunbound) {
        names = Qt; // all symbols
    }
    FOREACH(entry, target_pkg->imported) {
        if (HEAD(entry) == source) {
            if (names == Qt) {
                Fsettail(HEAD(entry), Qt);
            } else {
                LispVal *imported = TAIL(entry);
                // if we have already imported everything, do nothing
                if (imported == Qt) {
                    goto done;
                }
                FOREACH(name, names) {
                    if (SYMBOLP(name)) {
                        name = LISPVAL(((LispSymbol *) name)->name);
                    } else if (!STRINGP(name)) {
                        refcount_unref(target_pkg);
                        CHECK_TYPE(TYPE_STRING, name);
                    }
                    puthash(imported, name, Qt);
                }
            }
            goto done;
        }
    }
    // we didn't find any existing imports, so add a new entry
    if (check_recursive_import(source, LISPVAL(target_pkg))) {
        refcount_unref(target_pkg);
        Fthrow(Qimport_error, Qnil);
    }
    LispVal *lasttail = Qnil;
    FOREACH_TAIL(tail, target_pkg->imported) {
        if (NILP(TAIL(tail))) {
            lasttail = tail;
            break;
        }
    }
    if (LISTP(names)) {
        LispVal *norm_names = make_lisp_hashtable(Qstrings_equal, Qhash_string);
        FOREACH(name, names) {
            if (SYMBOLP(name)) {
                name = LISPVAL(((LispSymbol *) name)->name);
            } else if (!STRINGP(name)) {
                refcount_unref(target_pkg);
                refcount_unref(norm_names);
                CHECK_TYPE(TYPE_STRING, name);
            }
            puthash(norm_names, name, Qt);
        }
        names = norm_names;
    }
    if (NILP(lasttail)) {
        target_pkg->imported = const_list(false, 1, Fpair(source, names));
    } else {
        Fsettail(lasttail, const_list(false, 1, Fpair(source, names)));
    }
    refcount_unref(names);
done:
    refcount_unref(target_pkg);
    return Qnil;
}

DEFUN(find_package, "find-package", (LispVal * name), "(name)",
      "Return the package named NAME registered with the reader, if one "
      "exists.") {
    if (STRINGP(name)) {
        return Fgethash(package_table, name, Qnil);
    } else if (SYMBOLP(name)) {
        return Fgethash(package_table, LISPVAL(((LispSymbol *) name)->name),
                        Qnil);
    } else if (PACKAGEP(name)) {
        LispPackage *pkg = (LispPackage *) name;
        LispVal *found = Fgethash(package_table, LISPVAL(pkg->name), Qnil);
        if (found == LISPVAL(pkg)) {
            return found;
        } else {
            refcount_unref(found);
            return Qnil;
        }
    } else {
        Fthrow(Qtype_error, Qnil);
    }
}

LispVal *find_package(const char *name, size_t length) {
    LispVal *sobj = make_lisp_string(name, length, false, false);
    LispVal *pkg = Ffind_package(sobj);
    refcount_unref(sobj);
    return pkg;
}

// ####################
// # Symbol Functions #
// ####################
DEFUN(symbolp, "symbolp", (LispVal * val), "(obj)",
      "Return non-nil if OBJ is a symbol.") {
    return LISP_BOOL(SYMBOLP(val));
}

DEFUN(keywordp, "keywordp", (LispVal * val), "(obj)",
      "Return non-nil if OBJ is a symbol interned in the kw package.") {
    return LISP_BOOL(KEYWORDP(val));
}

DEFUN(const_value_p, "const-value-p", (LispVal * val), "(obj)",
      "Return non-nil if OBJ's value is constant.") {
    CHECK_TYPE(TYPE_SYMBOL, val);
    return LISP_BOOL(VALUE_CONSTANTP(val));
}

DEFUN(const_func_p, "const-func-p", (LispVal * val), "(obj)",
      "Return non-nil if OBJ's value as a function is constant.") {
    CHECK_TYPE(TYPE_SYMBOL, val);
    return LISP_BOOL(FUNC_CONSTANTP(val));
}

DEFUN(specialp, "specialp", (LispVal * val), "(obj)",
      "Return non-nil if OBJ is a special variable.") {
    CHECK_TYPE(TYPE_SYMBOL, val);
    return LISP_BOOL(SPECIALP(val));
}

DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)",
      "Return a new uninterned symbol named NAME.") {
    return make_lisp_symbol(name);
}

DEFUN(make_symbol_special, "make-symbol-special", (LispVal * sym), "(sym)",
      "Make it so that SYM is a special symbol, that is, it is dynamically "
      "bound.") {
    CHECK_TYPE(TYPE_SYMBOL, sym);
    if (VALUE_CONSTANTP(sym)) {
        Fthrow(Qconstant_value_error, Fpair(sym, Qnil));
    }
    ((LispSymbol *) sym)->is_special_var = true;
    return refcount_ref(sym);
}

DEFUN(symbol_package, "symbol-package", (LispVal * symbol), "(symbol)",
      "Return the package of SYMBOL.") {
    CHECK_TYPE(TYPE_SYMBOL, symbol);
    return refcount_ref(((LispSymbol *) symbol)->package);
}

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

DEFUN(symbol_function, "symbol-function", (LispVal * symbol, LispVal *resolve),
      "(symbol &opt resolve)",
      "Return the value as a function of SYMBOL. If RESOLVE is non-nil and the "
      "value is also a non-nil symbol, repeat this process.") {
    CHECK_TYPE(TYPE_SYMBOL, symbol);
    if (NILP(resolve)) {
        return refcount_ref(((LispSymbol *) symbol)->function);
    }
    while (SYMBOLP(symbol) && !NILP(symbol)) {
        symbol = ((LispSymbol *) symbol)->function;
    }
    return refcount_ref(symbol);
}

DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func), "(symbol func)",
      "Set the value as a function of SYMBOL to FUNC.") {
    CHECK_TYPE(TYPE_SYMBOL, sym);
    LispSymbol *sobj = ((LispSymbol *) sym);
    if (FUNC_CONSTANTP(sobj)) {
        Fthrow(Qconstant_function_error, Fpair(sym, Qnil));
    }
    refcount_ref(new_func);
    refcount_unref(sobj->function);
    sobj->function = new_func;
    return refcount_ref(new_func);
}

DEFUN(symbol_value, "symbol-value", (LispVal * symbol, LispVal *default_only),
      "(symbol &opt default-only)", "Return the global value of SYMBOL.") {
    CHECK_TYPE(TYPE_SYMBOL, symbol);
    if (KEYWORDP(symbol)) {
        return refcount_ref(symbol);
    } else if (SPECIALP(symbol) && NILP(default_only)) {
        LispVal *dynenv_entry = Fplist_assoc(the_stack->dynenv, symbol, Qnil);
        if (!NILP(dynenv_entry)) {
            return refcount_ref(HEAD(TAIL(dynenv_entry)));
        }
    }
    return refcount_ref(((LispSymbol *) symbol)->value);
}

DEFUN(set, "set", (LispVal * symbol, LispVal *value, LispVal *default_only),
      "(symbol value &opt default-only)",
      "Set the global value of SYMBOL to VALUE.") {
    CHECK_TYPE(TYPE_SYMBOL, symbol);
    if (VALUE_CONSTANTP(symbol)) {
        Fthrow(Qconstant_value_error, Fpair(symbol, Qnil));
    }
    if (SPECIALP(symbol) && NILP(default_only)) {
        LispVal *dynenv_entry = Fplist_assoc(the_stack->dynenv, symbol, Qnil);
        if (!NILP(dynenv_entry)) {
            Fsethead(TAIL(dynenv_entry), value);
            return refcount_ref(value);
        }
    }
    LispSymbol *sobj = (LispSymbol *) symbol;
    refcount_unref(sobj->value);
    sobj->value = refcount_ref(value);
    return refcount_ref(value);
}

DEFUN(symbol_value_docstr, "symbol-value-docstr", (LispVal * symbol),
      "(symbol)", "Return the documentation for SYMBOL's value.") {
    CHECK_TYPE(TYPE_SYMBOL, symbol);
    return refcount_ref(((LispSymbol *) symbol)->value_doc);
}

DEFUN(set_symbol_value_docstr, "set-symbol-value-docstr",
      (LispVal * symbol, LispVal *docstr), "(symbol value)",
      "Set the documentation for SYMBOL's value.") {
    CHECK_TYPE(TYPE_SYMBOL, symbol);
    if (VALUE_CONSTANTP(symbol)) {
        Fthrow(Qconstant_value_error, Fpair(symbol, Qnil));
    }
    LispSymbol *sobj = (LispSymbol *) symbol;
    refcount_unref(sobj->value_doc);
    sobj->value_doc = refcount_ref(docstr);
    return refcount_ref(docstr);
}

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

DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist),
      "(symbol plist)", "Set the plist of SYMBOL to PLIST.") {
    CHECK_TYPE(TYPE_SYMBOL, symbol);
    LispSymbol *real = (LispSymbol *) symbol;
    refcount_unref(real->plist);
    real->plist = refcount_ref(plist);
    return Qnil;
}

DEFUN(exported_symbol_p, "exported-symbol-p", (LispVal * symbol), "(symbol)",
      "Return non-nil if SYMBOL is exported by its package.") {
    CHECK_TYPE(TYPE_SYMBOL, symbol);
    LispSymbol *sym = (LispSymbol *) symbol;
    if (NILP(sym->package)) {
        return Qnil;
    } else if (KEYWORDP(symbol)) {
        return Qt;
    }
    LispPackage *pkg = (LispPackage *) sym->package;
    return Fgethash(pkg->exported_sym_table, LISPVAL(sym), Qnil);
}

DEFUN(intern_soft, "intern-soft",
      (LispVal * name, LispVal *def, LispVal *package, LispVal *included_too),
      "(name &opt def package included-too)",
      "If a symbol named NAME is interned in PACKAGE, return it. Otherwise, "
      "return DEF. If INCLUDED-TOO is non-nil also check symbol imported by "
      "PACKAGE.") {
    LispPackage *real_pkg;
    if (NILP(package)) {
        real_pkg = refcount_ref(current_package);
    } else {
        real_pkg = (LispPackage *) normalize_package(package);
    }
    LispVal *cur = gethash(real_pkg->obarray, name, Qunbound);
    if (cur != Qunbound) {
        refcount_unref(real_pkg);
        return refcount_ref(cur);
    }
    if (!NILP(included_too)) {
        FOREACH(entry, real_pkg->imported) {
            if (TAIL(entry) != Qt) {
                LispVal *sub = HEAD(entry);
                LispVal *imported = TAIL(entry);
                if (!NILP(gethash(imported, name, Qnil))) {
                    refcount_unref(real_pkg);
                    // we import it from this package, so don't keep searching
                    // if the intern fails
                    return Fintern_soft(name, def, sub, Qt);
                }
                // otherwise, keep looking in a different package
            } else {
                cur = Fintern_soft(name, Qunbound, HEAD(entry), Qt);
                if (cur != Qunbound) {
                    refcount_unref(real_pkg);
                    return cur;
                }
            }
        }
    }
    refcount_unref(real_pkg);
    return refcount_ref(def);
}

DEFUN(intern, "intern",
      (LispVal * name, LispVal *package, LispVal *included_too),
      "(name &opt package included-too)",
      "If a SYMBOL named NAME is interned in PACKAGE, return it, otherwise, "
      "intern a new symbol into PACKAGE. If INCLUDED-TOO is non-nil, also "
      "search imported symbols of PACKAGE.") {
    CHECK_TYPE(TYPE_STRING, name);
    LispPackage *real_pkg;
    if (NILP(package)) {
        real_pkg = refcount_ref(current_package);
    } else {
        real_pkg = (LispPackage *) normalize_package(package);
    }
    LispVal *cur = Fintern_soft(name, Qunbound, package, included_too);
    if (cur != Qunbound) {
        return cur;
    }
    LispVal *sym = make_lisp_symbol(name);
    ((LispSymbol *) sym)->package = refcount_ref(real_pkg);
    puthash(real_pkg->obarray, name, sym);
    refcount_unref(real_pkg);
    return sym;
}

DEFUN(quote_symbol_name, "quote-symbol-name", (LispVal * name), "(name)",
      "Quote NAME such that it could be read back by the reader as a symbol "
      "called NAME.") {
    CHECK_TYPE(TYPE_STRING, name);
    LispString *str = (LispString *) name;
    size_t out_len = str->length;
    char *out = lisp_malloc(str->length + 1);
    for (size_t i = 0, oi = 0; i < str->length; ++i, ++oi) {
        char c = str->data[i];
        if (c == ':' || c == '`' || c == ',' || c == '\'' || c == '"'
            || isspace(c) || c == '(' || c == ')' || c == '[' || c == ']') {
            out = lisp_realloc(out, ++out_len + 1);
            out[oi++] = '\\';
        }
        out[oi] = str->data[i];
    }
    out[out_len] = '\0';
    return make_lisp_string(out, out_len, true, false);
}

DEFUN(symbol_accessible_p, "symbol-accessible-p",
      (LispVal * symbol, LispVal *package), "(symbol &opt package)",
      "Return non-nil if SYMBOL is interned in PACKAGE or transiently imported "
      "into it.") {
    LispVal *name = Fsymbol_name(symbol);
    LispVal *found;
    WITH_CLEANUP(name, {
        found = Fintern_soft(name, Qunbound, package, Qt); //
    });
    bool res = found == symbol;
    refcount_unref(found);
    return LISP_BOOL(res);
}

DEF_STATIC_SYMBOL(kw_as_needed, "as-needed");
DEFUN(quote_symbol_for_read, "quote-symbol-for-read",
      (LispVal * target, LispVal *include_package, LispVal *from),
      "(target &opt include-package from)",
      "Quote TARGET, as symbol, such that a symbol with the same name as it "
      "will read by the reader. If INCLUDE-PACKAGE is :as-needed, add the "
      "package if it would be required to read back from the package FROM. If "
      "it is any other non-nil value, add the package regardless.") {
    CHECK_TYPE(TYPE_SYMBOL, target);
    LispSymbol *sym = (LispSymbol *) target;
    LispString *sym_name =
        (LispString *) Fquote_symbol_name(LISPVAL(sym->name));
    if (KEYWORDP(target)) {
        size_t size = sym_name->length + 1;
        char *new_name = lisp_malloc(size + 1);
        snprintf(new_name, size + 1, ":%s", sym_name->data);
        refcount_unref(sym_name);
        return make_lisp_string(new_name, size, true, false);
    } else if (NILP(include_package)) {
        return LISPVAL(sym_name);
    } else if (include_package == Qkw_as_needed) {
        void *cl_handler =
            register_cleanup(&refcount_unref_as_callback, sym_name);
        bool accessible = !NILP(Fsymbol_accessible_p(LISPVAL(sym), from));
        cancel_cleanup(cl_handler);
        if (accessible) {
            return LISPVAL(sym_name);
        }
        // otherwise, go on to print the package
    }
    if (NILP(sym->package)) {
        size_t size = sym_name->length + 2;
        char *new_name = lisp_malloc(size + 1);
        snprintf(new_name, size + 1, "::%s", sym_name->data);
        refcount_unref(sym_name);
        return make_lisp_string(new_name, size, true, false);
    }
    LispString *pkg_name = (LispString *) Fquote_symbol_name(
        LISPVAL(((LispPackage *) sym->package)->name));
    if (NILP(Fexported_symbol_p(LISPVAL(sym)))) {
        size_t size = pkg_name->length + sym_name->length + 2;
        char *new_name = lisp_malloc(size + 1);
        snprintf(new_name, size + 1, "%s::%s", pkg_name->data, sym_name->data);
        refcount_unref(pkg_name);
        refcount_unref(sym_name);
        return make_lisp_string(new_name, size, true, false);
    } else {
        size_t size = pkg_name->length + sym_name->length + 1;
        char *new_name = lisp_malloc(size + 1);
        snprintf(new_name, size + 1, "%s:%s", pkg_name->data, sym_name->data);
        refcount_unref(pkg_name);
        refcount_unref(sym_name);
        return make_lisp_string(new_name, size, true, false);
    }
}

LispVal *intern(const char *name, size_t length, bool take, LispVal *package,
                bool included_too) {
    if (!NILP(package)) {
        CHECK_TYPE(TYPE_PACKAGE, package);
    }
    LispVal *name_obj = make_lisp_string((char *) name, length, take, false);
    LispVal *sym = Fintern(name_obj, package, LISP_BOOL(included_too));
    refcount_unref(name_obj);
    return sym;
}

// ########################
// # Hash Table Functions #
// ########################
DEFUN(hash_table_p, "hash-table-p", (LispVal * val), "(obj)",
      "Return non-nil if OBJ is a hash table.") {
    return LISP_BOOL(HASHTABLEP(val));
}

DEFUN(make_hash_table, "make-hash-table", (LispVal * hash_fn, LispVal *eq_fn),
      "(&opt hash-fn eq-fn)",
      "Create a new hash table with hash function HASH-FN, defaulting to id, "
      "and equality test EQ-FN, defaulting to eq.") {
    return make_lisp_hashtable(eq_fn, hash_fn);
}

DEFUN(copy_hash_table, "copy-hash-table", (LispVal * table), "(table)",
      "Return a copy of TABLE.") {
    CHECK_TYPE(TYPE_HASHTABLE, table);
    LispHashtable *src = (LispHashtable *) table;
    CONSTRUCT_OBJECT(copy, LispHashtable, TYPE_HASHTABLE);
    copy->table_size = src->table_size;
    copy->count = src->count;
    copy->eq_fn = refcount_ref(src->eq_fn);
    copy->hash_fn = refcount_ref(src->hash_fn);
    copy->key_vals =
        lisp_malloc0(sizeof(struct HashtableEntry) * copy->table_size);
    HT_FOREACH_VALID_INDEX(src, i) {
        copy->key_vals[i].key = refcount_ref(src->key_vals[i].key);
        copy->key_vals[i].hash = src->key_vals[i].hash;
        copy->key_vals[i].value = refcount_ref(src->key_vals[i].value);
    }
    return LISPVAL(copy);
}

DEFUN(hash_table_count, "hash-table-count", (LispVal * table), "(table)",
      "Return the number of entries in TABLE.") {
    CHECK_TYPE(TYPE_HASHTABLE, table);
    return make_lisp_integer(((LispHashtable *) table)->count);
}

DEFUN(maphash, "maphash", (LispVal * func, LispVal *table), "(func table)",
      "Call FUNC for each key-value pair in TABLE. FUNC may modify table only "
      "by altering the current entry.") {
    HT_FOREACH_VALID_INDEX(table, i) {
        LispVal *args =
            const_list(true, 2, HASH_KEY(table, i), HASH_VALUE(table, i));
        WITH_CLEANUP(args, {
            refcount_unref(Ffuncall(func, args)); //
        });
    }
    return Qnil;
}

DEFUN(
    puthash, "puthash", (LispVal * table, LispVal *key, LispVal *value),
    "(table key value)",
    "Associate VALUE with KEY in TABLE, overriding any current association.") {
    return refcount_ref(puthash(table, key, value));
}

DEFUN(gethash, "gethash", (LispVal * table, LispVal *key, LispVal *def),
      "(table key &opt def)",
      "Return the VALUE associated with KEY in table, or DEF is no such "
      "mapping exists.") {
    return refcount_ref(gethash(table, key, def));
}

static bool hash_table_eq(LispVal *eq_fn, LispVal *v1, LispVal *v2) {
    if (NILP(eq_fn)) {
        return v1 == v2;
    } else if (eq_fn == Qstrings_equal) {
        return !NILP(Fstrings_equal(v1, v2));
    } else {
        LispVal *eq_obj;
        LispVal *args = const_list(true, 2, v1, v2);
        WITH_CLEANUP(args, {
            eq_obj = Ffuncall(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(args, {
            hash_obj = Ffuncall(self->hash_fn, args); //
        });
        uint64_t hash;
        WITH_CLEANUP(hash_obj, {
            CHECK_TYPE(TYPE_INTEGER, hash_obj);
            hash = ((LispInteger *) hash_obj)->value;
        });
        return hash;
    }
}

static ptrdiff_t hash_table_find_entry(struct HashtableEntry *entries,
                                       size_t size, LispVal *eq_fn,
                                       LispVal *key, uint64_t hash) {
    size_t i = hash % size;
    while (entries[i].key && !hash_table_eq(eq_fn, key, entries[i].key)) {
        i = (i + 1) % size;
    }
    return i;
}

DEFUN(remhash, "remhash", (LispVal * table, LispVal *key, LispVal *def),
      "(table key &opt def)",
      "Remove the value associated with KEY from TABLE. Return the removed "
      "value or DEF if no association was found.") {
    CHECK_TYPE(TYPE_HASHTABLE, table);
    LispHashtable *self = (LispHashtable *) table;
    uint64_t hash = hash_table_hash(self, key);
    ptrdiff_t i = hash_table_find_entry(self->key_vals, self->table_size,
                                        self->eq_fn, key, hash);
    if (HASH_SLOT_UNSET_P(self, i)) {
        return Qnil;
    }
    refcount_unref(self->key_vals[i].key);
    self->key_vals[i].key = NULL;
    LispVal *retval = self->key_vals[i].value;
    --self->count;
    // fixup the table
    for (size_t j = (i + 1) % self->table_size; !HASH_SLOT_UNSET_P(self, j);
         j = (j + 1) % self->table_size) {
        size_t k = HASH_HASH(self, j) % self->table_size;
        if ((i <= j && i < k && k <= j) || (i > j && (k <= j || i < k))) {
            // https://en.wikipedia.org/wiki/Open_addressing
            // test if the value actually should come before i or after j
            continue;
        }
        self->key_vals[i].hash = HASH_HASH(self, j);
        self->key_vals[i].key = HASH_KEY(self, j);
        self->key_vals[i].value = HASH_VALUE(self, j);
        self->key_vals[j].key = NULL;
        i = j;
    }
    return retval;
}

void free_hash_table_data_array(void *data) {
    struct HashtableDataArray *arr = data;
    for (size_t i = 0; i < arr->size; ++i) {
        refcount_unref(arr->entries[i].key);
        refcount_unref(arr->entries[i].value);
    }
    lisp_free(arr->entries);
}

// we assume the table is not full
// return true if we added a new entry, false otherwise
static bool puthash_to_array(LispVal *eq_fn, struct HashtableEntry *key_vals,
                             size_t table_size, LispVal *key, uint64_t hash,
                             LispVal *value) {
    ptrdiff_t i = hash_table_find_entry(key_vals, table_size, eq_fn, key, hash);
    if (!key_vals[i].key) {
        key_vals[i].key = refcount_ref(key);
        key_vals[i].hash = hash;
        key_vals[i].value = refcount_ref(value);
        return true;
    } else {
        refcount_unref(key_vals[i].key);
        key_vals[i].key = refcount_ref(key);
        refcount_unref(key_vals[i].value);
        key_vals[i].value = refcount_ref(value);
        return false;
    }
}

static void rehash_to(LispHashtable *self, size_t new_size) {
    struct HashtableEntry *new_data =
        lisp_malloc0(sizeof(struct HashtableEntry) * new_size);
    struct HashtableDataArray data_arr = {.size = new_size,
                                          .entries = new_data};
    void *cl_handler;
    if (the_stack) {
        cl_handler = register_cleanup(&free_hash_table_data_array, &data_arr);
    }
    size_t new_count = 0; // this should be the same, but just in case the user
                          // violates the rules of immutability
    HT_FOREACH_VALID_INDEX(self, i) {
        LispVal *key = HASH_KEY(self, i);
        uint64_t hash = HASH_HASH(self, i);
        LispVal *value = HASH_VALUE(self, i);
        if (puthash_to_array(self->eq_fn, new_data, new_size, key, hash,
                             value)) {
            ++new_count;
        }
    }
    if (the_stack) {
        cancel_cleanup(cl_handler);
    }
    free_hash_table_data_array(&(struct HashtableDataArray) {
        .size = self->table_size, .entries = self->key_vals});
    self->key_vals = new_data;
    self->table_size = new_size;
    self->count = new_count;
}

static inline void maybe_rehash(LispHashtable *self) {
    if (HASH_TABLE_LOAD_FACTOR(self) >= 0.5) {
        rehash_to(self, self->table_size * LISP_HASHTABLE_GROWTH_FACTOR);
    } /* else if (HASH_TABLE_LOAD_FACTOR(self) <= 0.1
               && self->table_size > LISP_HASHTABLE_INITIAL_SIZE) {
        rehash_to(self, self->table_size / LISP_HASHTABLE_GROWTH_FACTOR);
    } */
}

LispVal *puthash(LispVal *table, LispVal *key, LispVal *value) {
    CHECK_TYPE(TYPE_HASHTABLE, table);
    LispHashtable *self = (LispHashtable *) table;
    maybe_rehash(self);
    uint64_t hash = hash_table_hash(self, key);
    if (puthash_to_array(self->eq_fn, self->key_vals, self->table_size, key,
                         hash, value)) {
        ++self->count;
    }
    return value;
}

LispVal *gethash(LispVal *table, LispVal *key, LispVal *def) {
    CHECK_TYPE(TYPE_HASHTABLE, table);
    assert(HASH_TABLE_LOAD_FACTOR(table) < 0.95); // infinite loop otherwise
    LispHashtable *self = (LispHashtable *) table;
    uint64_t hash = hash_table_hash(self, key);
    ptrdiff_t i = hash_table_find_entry(self->key_vals, self->table_size,
                                        self->eq_fn, key, hash);
    if (HASH_SLOT_UNSET_P(self, i)) {
        return def;
    } else {
        return HASH_VALUE(self, i);
    }
}

void remhash(LispVal *table, LispVal *key) {
    refcount_unref(Fremhash(table, key, Qnil));
}

// #####################
// # Numeric Functions #
// #####################
DEFUN(integerp, "integerp", (LispVal * val), "(obj)",
      "Return non-nil of OBJ is an integer.") {
    return LISP_BOOL(INTEGERP(val));
}

DEFUN(floatp, "floatp", (LispVal * val), "(obj)",
      "Return non-nil if OBJ is a float.") {
    return LISP_BOOL(FLOATP(val));
}

DEFUN(num_eq, "=", (LispVal * n1, LispVal *n2), "(n1 n2)",
      "Return non-nil if N1 and N2 are numerically equal.") {
    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), "(n1 n2)",
      "Return non-nil if N1 is greater than 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 {
        Fthrow(Qtype_error, Qnil);
    }
}

DEFUN(add, "+", (LispVal * args), "(&rest nums)", "Return the sum of NUMS.") {
    if (NILP(args)) {
        return make_lisp_integer(0);
    }
    LispVal *out = copy_number(HEAD(args));
    FOREACH(arg, TAIL(args)) {
        LispVal *old_out = out;
        WITH_CLEANUP(old_out, {
            ONE_MATH_OPERAION(+, out, out, arg); //
        });
    }
    return out;
}

DEFUN(sub, "-", (LispVal * args), "(&rest nums)",
      "Subtract from the first number in NUMS each other number in NUMS.") {
    if (NILP(args)) {
        return make_lisp_integer(0);
    }
    LispVal *out = copy_number(HEAD(args));
    FOREACH(arg, TAIL(args)) {
        LispVal *old_out = out;
        WITH_CLEANUP(old_out, {
            ONE_MATH_OPERAION(-, out, out, arg); //
        });
    }
    return out;
}

DEFUN(mul, "*", (LispVal * args), "(nums)", "Return the product of NUMS.") {
    if (NILP(args)) {
        return make_lisp_integer(1);
    }
    LispVal *out = copy_number(HEAD(args));
    FOREACH(arg, TAIL(args)) {
        LispVal *old_out = out;
        WITH_CLEANUP(old_out, {
            ONE_MATH_OPERAION(*, out, out, arg); //
        });
    }
    return out;
}

DEFUN(div, "/", (LispVal * first, LispVal *rest), "(first &rest rest)",
      "If REST is nil, return the reciprocal of FIRST. Otherwise, return FIRST "
      "divided by the product of REST.") {
    if (NILP(rest)) {
        if (INTEGERP(first)) {
            return make_lisp_float(1.0 / ((LispInteger *) first)->value);
        } else if (FLOATP(first)) {
            return make_lisp_float(1.0 / ((LispFloat *) first)->value);
        } else {
            Fthrow(Qtype_error, Qnil);
        }
    }
    LispVal *out = copy_number(HEAD(rest));
    FOREACH(arg, TAIL(rest)) {
        LispVal *old_out = out;
        WITH_CLEANUP(old_out, {
            ONE_MATH_OPERAION(*, out, out, arg); //
        });
    }
    if (FLOATP(first)) {
        LispVal *old_out = out;
        ONE_MATH_OPERAION(/, out, first, out);
        refcount_unref(old_out);
    } else if (INTEGERP(first)) {
        LispVal *old_out = out;
        LispVal *ff = make_lisp_float(((LispInteger *) first)->value);
        ONE_MATH_OPERAION(/, out, ff, out);
        refcount_unref(ff);
        refcount_unref(old_out);
    } else {
        refcount_unref(out);
        Fthrow(Qtype_error, Qnil);
    }
    return out;
}

// ####################
// # Vector Functions #
// ####################
DEFUN(vectorp, "vectorp", (LispVal * val), "(obj)",
      "Return non-nil of OBJ is a vector.") {
    return LISP_BOOL(VECTORP(val));
}

DEFUN(make_vector, "make-vector",
      (LispVal * initial_size, LispVal *initial_elem),
      "(initial-size &opt initial-elem)",
      "Return a new vector of INITIAL-SIZE with each element being "
      "INITIAL-ELEM.") {
    CHECK_TYPE(TYPE_INTEGER, initial_size);
    int64_t size = ((LispInteger *) initial_size)->value;
    if (size < 0) {
        Fthrow(Qout_of_bounds_error, const_list(true, 1, initial_size));
    }
    LispVal **data = lisp_malloc(sizeof(LispVal *) * size);
    for (size_t i = 0; i < size; ++i) {
        data[i] = refcount_ref(initial_elem);
    }
    return make_lisp_vector(data, size);
}

DEFUN(vector, "vector", (LispVal * elems), "(&rest elems)",
      "Construct a vector form each of ELEMS.") {
    if (LISTP(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);
    } else if (STRINGP(elems)) {
        LispString *str = (LispString *) elems;
        LispVal **data = lisp_malloc(sizeof(LispVal *) * str->length);
        for (size_t i = 0; i < str->length; ++i) {
            data[i] = make_lisp_integer(str->data[i]);
        }
        return make_lisp_vector(data, str->length);
    } else if (VECTORP(elems)) {
        LispVector *vec = (LispVector *) elems;
        LispVal **data = lisp_malloc(sizeof(LispVal *) * vec->length);
        for (size_t i = 0; i < vec->length; ++i) {
            data[i] = refcount_ref(vec->data[i]);
        }
        return make_lisp_vector(data, vec->length);
    } else {
        Fthrow(Qtype_error,
               const_list(false, 3,
                          const_list(false, 2, Qvectorp, Qstringp, Qlistp),
                          refcount_ref(elems)));
    }
}

DEFUN(vector_length, "vector-length", (LispVal * vec), "(vec-or-str)",
      "Return the length of VEC-OR-STR, a vector or string.") {
    if (VECTORP(vec)) {
        return make_lisp_integer(((LispVector *) vec)->length);
    } else if (STRINGP(vec)) {
        return make_lisp_integer(((LispString *) vec)->length);
    } else {
        Fthrow(Qtype_error,
               const_list(false, 2, const_list(false, 2, Qvectorp, Qstringp),
                          refcount_ref(vec)));
    }
}

DEFUN(aref, "aref", (LispVal * vec, LispVal *index), "(vec-or-str index)",
      "Return the element numbered INDEX in VEC-OR-STR, starting from zero.") {
    CHECK_TYPE(TYPE_INTEGER, index);
    int64_t idx = ((LispInteger *) index)->value;
    if (idx < 0) {
        Fthrow(Qout_of_bounds_error, const_list(true, 1, index));
    }
    if (VECTORP(vec)) {
        LispVector *v = (LispVector *) vec;
        if (idx >= v->length) {
            Fthrow(Qout_of_bounds_error, const_list(true, 1, index));
        }
        return refcount_ref(v->data[idx]);
    } else if (STRINGP(vec)) {
        LispString *s = (LispString *) vec;
        if (idx >= s->length) {
            Fthrow(Qout_of_bounds_error, const_list(true, 1, index));
        }
        return make_lisp_integer(s->data[idx]);
    } else {
        Fthrow(Qtype_error,
               const_list(false, 2, const_list(false, 2, Qvectorp, Qstringp),
                          refcount_ref(vec)));
    }
}

DEFUN(aset, "aset", (LispVal * vec, LispVal *index, LispVal *elem),
      "(vec index elem)", "Set the element at INDEX in VEC to ELEM.") {
    CHECK_TYPE(TYPE_INTEGER, index);
    CHECK_TYPE(TYPE_VECTOR, vec);
    int64_t idx = ((LispInteger *) index)->value;
    if (idx < 0) {
        Fthrow(Qout_of_bounds_error, const_list(true, 1, index));
    }
    LispVector *v = (LispVector *) vec;
    if (idx >= v->length) {
        Fthrow(Qout_of_bounds_error, const_list(true, 1, index));
    }
    refcount_unref(v->data[idx]);
    v->data[idx] = refcount_ref(elem);
    return refcount_ref(elem);
}

DEFUN(subvector, "subvector", (LispVal * seq, LispVal *start, LispVal *end),
      "(vec-or-str &opt start end)",
      "Return a sub-vector or sub-string of VEC-OR-STR between START and END, "
      "defaulting to 0 and the length of VEC-OR-STR.") {
    if (!NILP(start)) {
        CHECK_TYPE(TYPE_INTEGER, start);
    }
    if (!NILP(end)) {
        CHECK_TYPE(TYPE_INTEGER, end);
    }
    size_t length;
    if (VECTORP(seq)) {
        length = ((LispVector *) seq)->length;
    } else if (STRINGP(seq)) {
        length = ((LispString *) seq)->length;
    } else {
        Fthrow(Qtype_error,
               const_list(false, 2, const_list(false, 2, Qstringp, Qvectorp),
                          seq));
    }
    int64_t si = 0;
    if (!NILP(start)) {
        si = ((LispInteger *) start)->value;
        if (si < 0 || si > length) {
            Fthrow(Qout_of_bounds_error, const_list(true, 1, start));
        }
    }
    int64_t se = 0;
    if (NILP(end)) {
        se = length;
    } else {
        se = ((LispInteger *) end)->value;
        if (se < 0 || se > length) {
            Fthrow(Qout_of_bounds_error, const_list(true, 1, end));
        } else if (si > se) {
            Fthrow(Qout_of_bounds_error, const_list(true, 1, start));
        }
    }
    if (VECTORP(seq)) {
        LispVector *vec = (LispVector *) seq;
        size_t subsize = se - si;
        LispVal **subarr = lisp_malloc(sizeof(LispVal *) * subsize);
        for (size_t i = si, sub_i = 0; i < se; ++i, ++sub_i) {
            subarr[sub_i] = refcount_ref(vec->data[i]);
        }
        return make_lisp_vector(subarr, subsize);
    } else {
        LispString *str = (LispString *) seq;
        size_t subsize = se - si;
        char *subarr = lisp_malloc(subsize);
        for (size_t i = si, sub_i = 0; i < se; ++i, ++sub_i) {
            subarr[sub_i] = str->data[i];
        }
        return make_lisp_string(subarr, subsize, true, false);
    }
}

// ####################
// # String Functions #
// ####################
DEFUN(stringp, "stringp", (LispVal * val), "(obj)",
      "Return non-nil if OBJ is a string.") {
    return LISP_BOOL(STRINGP(val));
}

DEFUN(string, "string", (LispVal * val), "(seq)",
      "Convert SEQ—a string, vector, or list—to a string.") {
    if (STRINGP(val)) {
        return refcount_ref(val);
    } else if (VECTORP(val)) {
        LispVector *vec = (LispVector *) val;
        char *new_chars = lisp_malloc(vec->length);
        void *cl_handler = register_cleanup(&lisp_free, new_chars);
        for (size_t i = 0; i < vec->length; ++i) {
            CHECK_TYPE(TYPE_INTEGER, vec->data[i]);
            LispInteger *elt = (LispInteger *) vec->data[i];
            if (elt->value < -128 || elt->value > 127) {
                Fthrow(Qtype_error, Qnil);
            }
            new_chars[i] = elt->value;
        }
        cancel_cleanup(cl_handler);
        return make_lisp_string(new_chars, vec->length, true, false);
    } else if (PAIRP(val)) {
        char *retval;
        size_t size = 0;
        WITH_PUSH_FRAME(Qnil, Qnil, true, {
            char *new_data = NULL;
            void *cl_handler = register_cleanup(&free_double_ptr, &new_data);
            FOREACH(elt, val) {
                CHECK_TYPE(TYPE_INTEGER, elt);
                LispInteger *i = (LispInteger *) elt;
                if (i->value < -128 || i->value > 127) {
                    Fthrow(Qtype_error, Qnil);
                }
                new_data = lisp_realloc(new_data, sizeof(char) * ++size);
                new_data[size - 1] = i->value;
            }
            cancel_cleanup(cl_handler);
            retval = new_data;
        });
        return make_lisp_string(retval, size, true, false);
    } else {
        Fthrow(Qtype_error,
               const_list(false, 2,
                          const_list(false, 3, Qvectorp, Qstringp, Qlistp),
                          refcount_ref(val)));
    }
}

DEFUN(hash_string, "hash-string", (LispVal * obj), "(str)",
      "Return the hash of STR.") {
    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),
      "(str1 str2)", "Return non-nil if STR1 and STR2 are equal.") {
    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);
}

DEFUN(string_to_vector, "string-to-vector", (LispVal * str), "(str)",
      "Convert STR to a vector.") {
    CHECK_TYPE(TYPE_STRING, str);
    LispString *s = (LispString *) str;
    LispVal **vdata = lisp_malloc(sizeof(LispVal *) * s->length);
    for (size_t i = 0; i < s->length; ++i) {
        vdata[i] = make_lisp_integer(s->data[i]);
    }
    return make_lisp_vector(vdata, s->length);
}

DEFUN(quote_string, "quote-string", (LispVal * target), "(target)",
      "Quote TARGET such that it can be read back by the reader.") {
    CHECK_TYPE(TYPE_STRING, target);
    LispString *str = (LispString *) target;
    size_t out_size = str->length + 2;
    char *out = lisp_malloc(out_size + 1);
    out[0] = '"';
    for (size_t i = 0, oi = 1; i < str->length; ++i, ++oi) {
        switch (str->data[i]) {
        case '\n':
            out = lisp_realloc(out, ++out_size + 1);
            out[oi++] = '\\';
            out[oi] = 'n';
            break;
        case '\t':
            out = lisp_realloc(out, ++out_size + 1);
            out[oi++] = '\\';
            out[oi] = 't';
            break;
        case '\r':
            out = lisp_realloc(out, ++out_size + 1);
            out[oi++] = '\\';
            out[oi] = 'r';
            break;
        case '\0':
            out = lisp_realloc(out, ++out_size + 1);
            out[oi++] = '\\';
            out[oi] = '0';
            break;
        case '"':
            out = lisp_realloc(out, ++out_size + 1);
            out[oi++] = '\\';
            out[oi] = '"';
            break;
        case '\\':
            out = lisp_realloc(out, ++out_size + 1);
            out[oi++] = '\\';
            out[oi] = '\\';
            break;
        default:
            out[oi] = str->data[i];
            break;
        }
    }
    out[out_size - 1] = '"';
    out[out_size] = '\0';
    return make_lisp_string(out, out_size, true, false);
}

DEFUN(concat, "concat", (LispVal * strings), "(&rest strings)",
      "Concatenate each string in STRINGS.") {
    LispVal *retval;
    WITH_PUSH_FRAME(Qnil, Qnil, true, {
        char *out = lisp_malloc(1);
        out[0] = '\0';
        size_t size = 0;
        void *cl_handler = register_cleanup(&free_double_ptr, &out);
        FOREACH(elt, strings) {
            if (NILP(elt)) {
                continue;
            }
            CHECK_TYPE(TYPE_STRING, elt);
            LispString *s = (LispString *) elt;
            size += s->length;
            out = lisp_realloc(out, size + 1);
            strncat(out, s->data, s->length);
        }
        cancel_cleanup(cl_handler);
        retval = make_lisp_string(out, size, true, false);
    });
    return retval;
}

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 - 1, true, false);
    va_end(args);
    return obj;
}

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;
}

// ####################
// # Record Functions #
// ####################
DEFUN(recordp, "recordp", (LispVal * val), "(obj)",
      "Return non-nil if OBJ is a record.") {
    return LISP_BOOL(RECORDP(val));
}

DEFUN_DISTINGUISHED(make_record, "make-record",
                    (LispVal * type, LispVal *length),
                    "(type length &opt native-backing)",
                    "Return a new record object of TYPE.") {
    CHECK_TYPE(TYPE_INTEGER, length);
    int64_t real_length = ((LispInteger *) length)->value;
    if (real_length < 0) {
        Fthrow(Qout_of_bounds_error, Qnil);
    }
    return make_lisp_record(type, real_length);
}

DEFUN(record_function, "record-function", (LispVal * record), "(record)",
      "Return the function associated with RECORD.") {
    CHECK_TYPE(TYPE_RECORD, record);
    return refcount_ref(((LispRecord *) record)->function);
}

DEFUN(set_record_function, "set-record-function",
      (LispVal * record, LispVal *value), "(record value)",
      "Set the function of RECORD to VALUE.") {
    CHECK_TYPE(TYPE_RECORD, record);
    LispRecord *rec = (LispRecord *) record;
    refcount_unref(rec->function);
    rec->function = refcount_ref(value);
    return refcount_ref(value);
}

DEFUN(record_length, "record-length", (LispVal * record), "(record)",
      "Return the length of RECORD.") {
    CHECK_TYPE(TYPE_RECORD, record);
    return make_lisp_integer(((LispRecord *) record)->length);
}

DEFUN(record_slot, "record-slot", (LispVal * record, LispVal *index),
      "(obj index)", "Return the INDEXth slot of RECORD.") {
    CHECK_TYPE(TYPE_RECORD, record);
    CHECK_TYPE(TYPE_INTEGER, index);
    LispRecord *rec = (LispRecord *) record;
    int64_t real_index = ((LispInteger *) index)->value;
    if (real_index < 0 || real_index > rec->length) {
        Fthrow(Qout_of_bounds_error, Fpair(index, Qnil));
    }
    return refcount_ref(rec->data[real_index]);
}

DEFUN(set_record_slot, "set-record-slot",
      (LispVal * record, LispVal *index, LispVal *value),
      "(record index value)", "Set the INDEXth slot of RECORD to VALUE.") {
    CHECK_TYPE(TYPE_RECORD, record);
    CHECK_TYPE(TYPE_INTEGER, index);
    LispRecord *rec = (LispRecord *) record;
    int64_t real_index = ((LispInteger *) index)->value;
    if (real_index < 0 || real_index > rec->length) {
        Fthrow(Qout_of_bounds_error, Fpair(index, Qnil));
    }
    refcount_unref(rec->data[real_index]);
    rec->data[real_index] = refcount_ref(value);
    return Qnil;
}

// ################
// # IO Functions #
// ################
static inline int CHECK_IO_RESULT(int res, int fd) {
    if (res < 0) {
        if (errno == EBADFD) {
            Fthrow(Qtype_error, const_list(false, 1, make_lisp_integer(fd)));
        } else {
            Fthrow(Qio_error, Qnil);
        }
    }
    return res;
}

static int64_t internal_print(void *obj, int64_t fd, bool readably,
                              bool first_in_list) {
    switch (TYPEOF(obj)) {
    case TYPE_STRING: {
        if (readably) {
            LispVal *quoted = Fquote_string(obj);
            int64_t rval = 0;
            WITH_CLEANUP(quoted, {
                rval = internal_print(quoted, fd, false, true); //
            });
            return rval;
        } else {
            LispString *str = obj;
            return CHECK_IO_RESULT(write(fd, str->data, str->length), fd);
        }
    }
    case TYPE_SYMBOL: {
        LispVal *name = Qnil;
        if (readably) {
            name = Fquote_symbol_for_read(obj, Qkw_as_needed, Qnil);
        } else {
            name = refcount_ref(((LispSymbol *) obj)->name);
        }
        int64_t np;
        WITH_CLEANUP(name, {
            np = internal_print(name, fd, false, true); //
        });
        return np;
    } break;
    case TYPE_PAIR: {
        if (HEAD(obj) == Qquote && PAIRP(TAIL(obj)) && NILP(TAIL(TAIL(obj)))) {
            int64_t np = CHECK_IO_RESULT(dprintf(fd, "'"), fd);
            np += internal_print(HEAD(TAIL(obj)), fd, readably, true);
            return np;
        }
        int64_t np;
        if (first_in_list) {
            np = CHECK_IO_RESULT(dprintf(fd, "("), fd);
        } else {
            np = CHECK_IO_RESULT(dprintf(fd, " "), fd);
        }
        np += internal_print(HEAD(obj), fd, readably, true);
        if (TAIL(obj) == Qnil) {
            np = CHECK_IO_RESULT(dprintf(fd, ")"), fd);
        } else {
            np += internal_print(TAIL(obj), fd, readably, false);
        }
        return np;
    }
    case TYPE_VECTOR: {
        LispVector *v = obj;
        int64_t np = CHECK_IO_RESULT(dprintf(fd, "["), fd);
        for (size_t i = 0; i < v->length; ++i) {
            np += internal_print(v->data[i], fd, readably, true);
            if (i != v->length - 1) {
                np += CHECK_IO_RESULT(dprintf(fd, " "), fd);
            }
        }
        np += CHECK_IO_RESULT(dprintf(fd, "]"), fd);
        return np;
    }
    case TYPE_INTEGER:
        return CHECK_IO_RESULT(
            dprintf(fd, "%ji", (intmax_t) ((LispInteger *) obj)->value), fd);
    case TYPE_FLOAT:
        return CHECK_IO_RESULT(dprintf(fd, "%Lf", ((LispFloat *) obj)->value),
                               fd);
    case TYPE_FUNCTION: {
        LispFunction *fn = obj;
        int64_t np;
        bool need_name = true;
        if (fn->is_builtin && fn->is_macro) {
            np = CHECK_IO_RESULT(dprintf(fd, "<special-form "), fd);
        } else if (fn->is_builtin) {
            np = CHECK_IO_RESULT(dprintf(fd, "<builtin "), fd);
        } else if (fn->is_macro && fn->name == Qlambda) {
            np = CHECK_IO_RESULT(dprintf(fd, "<lambda-macro "), fd);
            need_name = false;
        } else if (fn->is_macro) {
            np = CHECK_IO_RESULT(dprintf(fd, "<macro "), fd);
        } else if (fn->name == Qlambda) {
            np = CHECK_IO_RESULT(dprintf(fd, "<lambda "), fd);
            need_name = false;
        } else {
            np = CHECK_IO_RESULT(dprintf(fd, "<function "), fd);
        }
        if (need_name) {
            np += internal_print(fn->name, fd, readably, true);
            np += CHECK_IO_RESULT(dprintf(fd, " "), fd);
        }
        np += CHECK_IO_RESULT(dprintf(fd, "at %#jx>", (uintmax_t) obj), fd);
        return np;
    }
    case TYPE_HASHTABLE: {
        LispHashtable *ht = obj;
        LispVal *hash_fn = NILP(ht->hash_fn) ? Qid : ht->hash_fn;
        LispVal *eq_fn = NILP(ht->eq_fn) ? Qeq : ht->eq_fn;
        int64_t np = CHECK_IO_RESULT(
            dprintf(fd, "<hash-table size=%ju count=%ju eq-fn=",
                    (uintmax_t) ht->table_size, (uintmax_t) ht->count),
            fd);
        np += internal_print(eq_fn, fd, readably, true);
        np += CHECK_IO_RESULT(dprintf(fd, " hash-fn="), fd);
        np += internal_print(hash_fn, fd, readably, true);
        np += CHECK_IO_RESULT(dprintf(fd, " at %#jx>", (uintmax_t) obj), fd);
        return np;
    }
    case TYPE_USER_POINTER:
        return CHECK_IO_RESULT(dprintf(fd, "<user-pointer to %#jx at %#jx>",
                                       (uintmax_t) USERPTR(void *, obj),
                                       (uintmax_t) obj),
                               fd);
    case TYPE_PACKAGE: {
        LispPackage *pkg = obj;
        int64_t np = CHECK_IO_RESULT(dprintf(fd, "<package "), fd);
        LispVal *name_str = Fquote_string(LISPVAL(pkg->name));
        WITH_CLEANUP(name_str, {
            np += internal_print(name_str, fd, readably, true); //
        });
        np += CHECK_IO_RESULT(
            dprintf(fd, " interned=%ju at %#jx>",
                    (uintmax_t) ((LispHashtable *) pkg->obarray)->count,
                    (uintmax_t) obj),
            fd);
        return np;
    } break;
    case TYPE_RECORD: {
        // TODO implement
        LispRecord *rec = (LispRecord *) obj;
        int64_t np = CHECK_IO_RESULT(
            dprintf(fd,
                    "<%srecord type=", NILP(rec->function) ? "" : "callable-"),
            fd);
        np += internal_print(rec->record_type, fd, readably, true);
        np += CHECK_IO_RESULT(dprintf(fd, " length=%ju at %#jx>",
                                      (uintmax_t) rec->length, (uintmax_t) obj),
                              fd);
        return np;
    } break;
    default:
        abort();
    }
}

DEFUN_DISTINGUISHED(print, "print",
                    (LispVal * obj, LispVal *readably, LispVal *stream),
                    "(obj &opt readably stream)",
                    "Write a human readable representation of OBJ to STREAM, "
                    "defaulting to the standard output. With READABLY non-nil, "
                    "print OBJ in a way that it can be read back.") {
    int64_t fd;
    if (stream == Qunbound) {
        fd = 1;
    } else {
        CHECK_TYPE(TYPE_INTEGER, stream);
        fd = ((LispInteger *) stream)->value;
        if (fd < 0) {
            Fthrow(Qtype_error, const_list(true, 1, stream));
        }
    }
    bool readably_bool = readably != Qunbound && !NILP(readably);
    return make_lisp_integer(internal_print(obj, fd, readably_bool, true));
}

DEFUN_DISTINGUISHED(
    println, "println", (LispVal * obj, LispVal *readably, LispVal *stream),
    "(obj &opt readably stream)",
    "Call print with OBJ and STREAM, then write a newline to STREAM. With "
    "READABLY non-nil, print OBJ in a way that it can be read back.") {
    static char NEWLINE = '\n';
    int64_t fd;
    if (stream == Qunbound) {
        fd = 1;
    } else {
        CHECK_TYPE(TYPE_INTEGER, stream);
        fd = ((LispInteger *) stream)->value;
        if (fd < 0) {
            Fthrow(Qtype_error, const_list(true, 1, stream));
        }
    }
    int64_t np = 0;
    if (obj != Qunbound) {
        bool readably_bool = readably != Qunbound && !NILP(readably);
        np += internal_print(obj, fd, readably_bool, true);
    }
    np += CHECK_IO_RESULT(write(fd, &NEWLINE, 1), fd);
    fsync(fd);
    return make_lisp_integer(np);
}

// ########################
// # Lexenv and the Stack #
// ########################
DEF_STATIC_SYMBOL(kw_success, "success");
DEF_STATIC_SYMBOL(kw_finally, "finally");

DEFUN(backtrace, "backtrace", (void), "()", "Return a backtrace.") {
    LispVal *head = Qnil;
    LispVal *end = Qnil;
    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;
}

#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Winfinite-recursion"
DEFUN(throw, "throw", (LispVal * signal, LispVal *rest), "(signal &rest rest)",
      "Throw a signal SIGNAL with data 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, {
                WITH_CLEANUP(error_arg, {
                    if (!NILP(var)) {
                        CHECK_TYPE(TYPE_SYMBOL, var);
                        if (VALUE_CONSTANTP(var)) {
                            Fthrow(Qconstant_value_error, Fpair(var, Qnil));
                        }
                        push_to_lexenv(&the_stack->lexenv, var, error_arg);
                    }
                    stack_return = Feval(form, the_stack->lexenv); //
                });
            });
            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, the_stack->lexenv)); //
            });
            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

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->dynenv = the_stack ? refcount_ref(the_stack->dynenv) : Qnil;
    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->dynenv);
    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, the_stack->lexenv)); //
        })
    }
}

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;
        }
    }
}

// #########################
// # Errors and Conditions #
// #########################
DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal");
DEF_STATIC_SYMBOL(error, "error");
DEF_STATIC_SYMBOL(type_error, "type-error");
DEF_STATIC_SYMBOL(read_error, "read-error");
DEF_STATIC_SYMBOL(unclosed_error, "read-error");
DEF_STATIC_SYMBOL(constant_function_error, "constant-function-error");
DEF_STATIC_SYMBOL(constant_value_error, "constant-value-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");
DEF_STATIC_SYMBOL(package_exists_error, "package-exists-error");
DEF_STATIC_SYMBOL(import_error, "import-error");
DEF_STATIC_SYMBOL(unknown_package_error, "unknown-package-error");
DEF_STATIC_SYMBOL(out_of_bounds_error, "out-of-bounds-error");
DEF_STATIC_SYMBOL(io_error, "io-error");

// ###################
// # Debug Functions #
// ###################
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;
        if (KEYWORDP(obj)) {
            fputc(':', stream);
        } else if (NILP(sym->package)) {
            fprintf(stream, "::");
        } else if (sym->package != current_package) {
            LispPackage *pkg = (LispPackage *) sym->package;
            fwrite(pkg->name->data, 1, pkg->name->length, stream);
            fputc(':', stream);
            if (NILP(Fexported_symbol_p(obj))) {
                fputc(':', stream);
            }
        }
        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: {
        LispFunction *fobj = obj;
        LispVal *name = ((LispFunction *) obj)->name;
        if (fobj->is_builtin) {
            fprintf(stream, "<builtin ");
        } else {
            if (name == Qlambda) {
                fprintf(stream, "<lambda"); // no space!
                name = NULL;
            } else if (fobj->is_macro) {
                fprintf(stream, "<macro ");
            } 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;
    case TYPE_PACKAGE: {
        LispPackage *pkg = (LispPackage *) obj;
        fprintf(stream, "<package ");
        fwrite(pkg->name->data, 1, pkg->name->length, stream);
        fprintf(stream, " obarray-size=%zu at %#jx>",
                ((LispHashtable *) pkg->obarray)->count, (uintmax_t) obj);
    } break;
    case TYPE_RECORD: {
        LispRecord *rec = (LispRecord *) obj;
        fprintf(stream,
                "<%srecord type=", NILP(rec->function) ? "" : "callable-");
        debug_dump_real(stream, rec->record_type, true);
        fprintf(stream, " length=%ju at %#jx>", (uintmax_t) rec->length,
                (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);
    HT_FOREACH_VALID_INDEX(table, i) {
        fprintf(stream, "- ");
        debug_dump(stream, HASH_KEY(table, i), false);
        fprintf(stream, " = ");
        debug_dump(stream, HASH_VALUE(table, i), 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);
}

// ################
// # Registration #
// ################
static void register_symbols_and_functions(void) {
    // don't intern Qunbound!
    REGISTER_DO_INTERN(nil, system_package);
    REGISTER_DO_INTERN(t, system_package);

    REGISTER_SYMBOL(macro);
    REGISTER_SYMBOL(opt);
    REGISTER_SYMBOL(allow_other_keys);
    REGISTER_SYMBOL(key);
    REGISTER_SYMBOL(rest);
    REGISTER_SYMBOL(declare);
    REGISTER_SYMBOL(name);
    REGISTER_SYMBOL(no_backtrace);
    REGISTER_SYMBOL(comma);
    REGISTER_SYMBOL(comma_at);
    REGISTER_SYMBOL(backquote);
    REGISTER_SYMBOL(symbol);
    REGISTER_SYMBOL(integer);
    REGISTER_SYMBOL(float);
    REGISTER_SYMBOL(function);
    REGISTER_SYMBOL(hash_table);
    REGISTER_SYMBOL(user_pointer);
    REGISTER_SYMBOL(package);
    REGISTER_SYMBOL(record);
    REGISTER_KEYWORD(kw_success);
    REGISTER_KEYWORD(kw_finally);
    REGISTER_KEYWORD(kw_as_needed);
    REGISTER_SYMBOL(shutdown_signal);
    REGISTER_SYMBOL(error);
    REGISTER_SYMBOL(type_error);
    REGISTER_SYMBOL(read_error);
    REGISTER_SYMBOL(eof_error);
    REGISTER_SYMBOL(unclosed_error);
    REGISTER_SYMBOL(constant_function_error);
    REGISTER_SYMBOL(constant_value_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);
    REGISTER_SYMBOL(package_exists_error);
    REGISTER_SYMBOL(import_error);
    REGISTER_SYMBOL(unknown_package_error);
    REGISTER_SYMBOL(out_of_bounds_error);
    REGISTER_SYMBOL(io_error);
    REGISTER_SYMBOL(toplevel);

    // some functions that mustn't be user accessible
    REGISTER_STATIC_FUNCTION(set_for_return);
    REGISTER_STATIC_FUNCTION(internal_real_return);

    // ###############################
    // # General and Misc. Functions #
    // ###############################
    REGISTER_FUNCTION(exit);
    REGISTER_FUNCTION(id);
    REGISTER_FUNCTION(eq);
    REGISTER_FUNCTION(equal);
    REGISTER_FUNCTION(breakpoint);
    REGISTER_FUNCTION(not);
    REGISTER_FUNCTION(type_of);
    REGISTER_FUNCTION(user_pointer_p);
    REGISTER_FUNCTION(callablep);
    REGISTER_FUNCTION(native_type_p);

    // ##################################
    // # Evaluation and Macro Expansion #
    // ##################################
    REGISTER_FUNCTION(eval);
    REGISTER_FUNCTION(funcall);
    REGISTER_FUNCTION(apply);
    REGISTER_FUNCTION(macroexpand_1);
    REGISTER_FUNCTION(macroexpand_toplevel);
    REGISTER_FUNCTION(macroexpand_all);

    // #################
    // # Special Forms #
    // #################
    REGISTER_FUNCTION(quote);
    REGISTER_FUNCTION(if);
    REGISTER_FUNCTION(setq);
    REGISTER_FUNCTION(progn);
    REGISTER_FUNCTION(condition_case);
    REGISTER_FUNCTION(lambda);
    REGISTER_FUNCTION(while);
    REGISTER_FUNCTION(and);
    REGISTER_FUNCTION(or);
    REGISTER_FUNCTION(in_package);
    REGISTER_FUNCTION(return_from);

    // ######################
    // # Function Functions #
    // ######################
    REGISTER_FUNCTION(functionp);
    REGISTER_FUNCTION(macrop);
    REGISTER_FUNCTION(builtinp);
    REGISTER_FUNCTION(special_form_p);
    REGISTER_FUNCTION(function_docstr);
    REGISTER_FUNCTION(function_properties);

    // ###########################
    // # Pair and List Functions #
    // ###########################
    REGISTER_FUNCTION(pairp);
    REGISTER_FUNCTION(atom);
    REGISTER_FUNCTION(pair);
    REGISTER_FUNCTION(head);
    REGISTER_FUNCTION(tail);
    REGISTER_FUNCTION(sethead);
    REGISTER_FUNCTION(settail);

    // lists
    REGISTER_FUNCTION(listp);
    REGISTER_FUNCTION(list_length);
    REGISTER_FUNCTION(copy_list);
    REGISTER_FUNCTION(copy_tree);

    // plists
    REGISTER_FUNCTION(plist_get);
    REGISTER_FUNCTION(plist_set);
    REGISTER_FUNCTION(plist_rem);
    REGISTER_FUNCTION(plist_assoc);

    // #####################
    // # Package Functions #
    // #####################
    REGISTER_FUNCTION(packagep);
    REGISTER_FUNCTION(make_package);
    REGISTER_FUNCTION(package_name);
    REGISTER_FUNCTION(register_package);
    REGISTER_FUNCTION(current_package);
    REGISTER_FUNCTION(set_current_package);
    REGISTER_FUNCTION(mapsymbols);
    REGISTER_FUNCTION(export_symbol);
    REGISTER_FUNCTION(import_package);
    REGISTER_FUNCTION(find_package);

    // ####################
    // # Symbol Functions #
    // ####################
    REGISTER_FUNCTION(symbolp);
    REGISTER_FUNCTION(keywordp);
    REGISTER_FUNCTION(const_value_p);
    REGISTER_FUNCTION(const_func_p);
    REGISTER_FUNCTION(specialp);
    REGISTER_FUNCTION(make_symbol);
    REGISTER_FUNCTION(make_symbol_special);
    REGISTER_FUNCTION(symbol_package);
    REGISTER_FUNCTION(symbol_name);
    REGISTER_FUNCTION(symbol_function);
    REGISTER_FUNCTION(fset);
    REGISTER_FUNCTION(symbol_value);
    REGISTER_FUNCTION(set);
    REGISTER_FUNCTION(symbol_value_docstr);
    REGISTER_FUNCTION(set_symbol_value_docstr);
    REGISTER_FUNCTION(symbol_plist);
    REGISTER_FUNCTION(setplist);
    REGISTER_FUNCTION(exported_symbol_p);
    REGISTER_FUNCTION(intern_soft);
    REGISTER_FUNCTION(intern);
    REGISTER_FUNCTION(quote_symbol_name);
    REGISTER_FUNCTION(symbol_accessible_p);
    REGISTER_FUNCTION(quote_symbol_for_read);

    // ########################
    // # Hash Table Functions #
    // ########################
    REGISTER_FUNCTION(hash_table_p);
    REGISTER_FUNCTION(make_hash_table);
    REGISTER_FUNCTION(copy_hash_table);
    REGISTER_FUNCTION(hash_table_count);
    REGISTER_FUNCTION(maphash);
    REGISTER_FUNCTION(puthash);
    REGISTER_FUNCTION(gethash);
    REGISTER_FUNCTION(remhash);

    // #####################
    // # Numeric Functions #
    // #####################
    REGISTER_FUNCTION(integerp);
    REGISTER_FUNCTION(floatp);
    REGISTER_FUNCTION(num_eq);
    REGISTER_FUNCTION(num_gt);
    REGISTER_FUNCTION(add);
    REGISTER_FUNCTION(sub);
    REGISTER_FUNCTION(mul);
    REGISTER_FUNCTION(div);

    // ####################
    // # Vector Functions #
    // ####################
    REGISTER_FUNCTION(vectorp);
    REGISTER_FUNCTION(make_vector);
    REGISTER_FUNCTION(vector);
    REGISTER_FUNCTION(vector_length);
    REGISTER_FUNCTION(aref);
    REGISTER_FUNCTION(aset);
    REGISTER_FUNCTION(subvector);

    // ####################
    // # String Functions #
    // ####################
    REGISTER_FUNCTION(stringp);
    REGISTER_FUNCTION(string);
    REGISTER_FUNCTION(hash_string);
    REGISTER_FUNCTION(strings_equal);
    REGISTER_FUNCTION(string_to_vector);
    REGISTER_FUNCTION(quote_string);
    REGISTER_FUNCTION(concat);

    // ####################
    // # Record Functions #
    // ####################
    REGISTER_FUNCTION(recordp);
    REGISTER_FUNCTION(make_record);
    REGISTER_FUNCTION(record_function);
    REGISTER_FUNCTION(set_record_function);
    REGISTER_FUNCTION(record_length);
    REGISTER_FUNCTION(record_slot);
    REGISTER_FUNCTION(set_record_slot);

    // ################
    // # IO Functions #
    // ################
    REGISTER_FUNCTION(print);
    REGISTER_FUNCTION(println);

    // ########################
    // # Lexenv and the Stack #
    // ########################
    REGISTER_FUNCTION(backtrace);
    REGISTER_FUNCTION(throw);

    // ###############
    // # From read.c #
    // ###############
    register_reader_functions();
}