simple-lisp/src/lisp.c

#include "lisp.h"

#include "read.h"

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

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

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

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

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

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

void _internal_lisp_delete_object(LispVal *val) {
    switch (TYPEOF(val)) {
    case TYPE_INTEGER:
    case TYPE_FLOAT:
        lisp_free(val);
        break;
    case TYPE_STRING: {
        LispString *str = (LispString *) val;
        if (!str->is_static) {
            lisp_free(str->data);
        }
        lisp_free(val);
    } break;
    case TYPE_SYMBOL: {
        LispSymbol *sym = (LispSymbol *) val;
        lisp_unref(sym->name);
        lisp_unref(sym->plist);
        lisp_unref(sym->function);
        lisp_unref(sym->value);
        lisp_free(val);
    } break;
    case TYPE_PAIR:
        lisp_unref(((LispPair *) val)->head);
        lisp_unref(((LispPair *) val)->tail);
        lisp_free(val);
        break;
    case TYPE_VECTOR: {
        LispVector *vec = (LispVector *) val;
        for (size_t i = 0; i < vec->length; ++i) {
            lisp_unref(vec->data[i]);
        }
        lisp_free(vec->data);
        lisp_free(val);
    } break;
    case TYPE_FUNCTION: {
        LispFunction *fn = (LispFunction *) val;
        lisp_unref(fn->doc);
        lisp_unref(fn->args);
        lisp_unref(fn->kwargs);
        if (!fn->is_builtin) {
            lisp_unref(fn->body);
        }
        lisp_unref(fn->lexenv);
        lisp_free(val);
    } break;
    case TYPE_HASHTABLE: {
        LispHashtable *tbl = (LispHashtable *) val;
        for (size_t i = 0; i < tbl->table_size; ++i) {
            struct HashtableBucket *cur = tbl->data[i];
            while (cur) {
                lisp_unref(cur->key);
                lisp_unref(cur->value);
                struct HashtableBucket *next = cur->next;
                lisp_free(cur);
                cur = next;
            }
        }
        lisp_free(tbl->data);
        lisp_unref(tbl->eq_fn);
        lisp_unref(tbl->hash_fn);
        lisp_free(val);
    } break;
    default:
        abort();
    };
}

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

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

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

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

LispVal *make_lisp_symbol(LispVal *name) {
    LispSymbol *self = lisp_malloc(sizeof(LispSymbol));
    self->type = TYPE_SYMBOL;
    self->ref_count = 0;
    self->name = (LispString *) lisp_ref(name);
    self->plist = Qnil;
    self->function = Qunbound;
    self->value = Qunbound;
    self->is_constant = false;
    return LISPVAL(self);
}

LispVal *make_lisp_pair(LispVal *head, LispVal *tail) {
    LispPair *self = lisp_malloc(sizeof(LispPair));
    self->type = TYPE_PAIR;
    self->ref_count = 0;
    self->head = lisp_ref(head);
    self->tail = lisp_ref(tail);
    return LISPVAL(self);
}

LispVal *make_lisp_integer(intmax_t value) {
    LispInteger *self = lisp_malloc(sizeof(LispInteger));
    self->type = TYPE_INTEGER;
    self->ref_count = 0;
    self->value = value;
    return LISPVAL(self);
}

LispVal *make_lisp_float(long double value) {
    LispFloat *self = lisp_malloc(sizeof(LispFloat));
    self->type = TYPE_FLOAT;
    self->ref_count = 0;
    self->value = value;
    return LISPVAL(self);
}

LispVal *make_lisp_vector(LispVal **data, size_t length) {
    LispVector *self = lisp_malloc(sizeof(LispVector));
    self->type = TYPE_VECTOR;
    self->ref_count = 0;
    self->data = data;
    self->length = length;
    return LISPVAL(self);
}

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

void set_function_args(LispFunction *func, LispVal *args) {
    // in case func is static
    if (func->args) {
        lisp_unref(func->args);
    }
    if (func->kwargs) {
        lisp_unref(func->kwargs);
    }
    int mode = 0; // required
    bool has_opt = false; // mode 1
    bool has_key = false; // mode 2
    bool has_rest = false; // mode 3
    func->n_req = 0;
    func->n_opt = 0;
    func->has_rest = false;
    size_t n_kw = 0;
    func->kwargs = lisp_ref(make_lisp_hashtable(Qnil, Qnil));
    func->allow_other_keys = false;
    FOREACH(arg, args) {
        if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg)) {
            goto malformed;
        } else if (arg == Qopt) {
            if (has_opt || mode == 3) {
                goto malformed;
            }
            has_opt = true;
            mode = 1;
        } else if (arg == Qkey) {
            if (has_key || mode == 3) {
                goto malformed;
            }
            has_key = true;
            mode = 2;
        } else if (arg == Qrest) {
            if (has_rest) {
                goto malformed;
            }
            has_rest = true;
            mode = 3;
        } else if (arg == Qallow_other_keys) {
            if (func->allow_other_keys || mode != 2) {
                goto malformed;
            }
            func->allow_other_keys = true;
            mode = -1;
        } else {
            switch (mode) {
            case 0:
                ++func->n_req;
                break;
            case 1:
                ++func->n_opt;
                break;
            case 2: {
                LispString *sn = ((LispSymbol *) arg)->name;
                char kns[sn->length + 2];
                kns[0] = ':';
                memcpy(kns + 1, sn->data, sn->length);
                kns[sn->length + 1] = '\n';
                LispVal *kn =
                    make_lisp_string(kns, sn->length + 1, false, false);
                lisp_ref(kn);
                Fputhash(func->kwargs, Fintern(kn), make_lisp_integer(n_kw));
                lisp_unref(kn);
            } break;
            case 3:
                if (func->has_rest) {
                    goto malformed;
                }
                func->has_rest = true;
                mode = -1;
                break;
            case -1:
                goto malformed;
            }
        }
    }
    // do this last
    func->args = lisp_ref(args);
    return;
malformed:
    lisp_unref(func->kwargs);
    Fthrow(Qmalformed_lambda_list_error, Fpair(args, Qnil));
}

LispVal *make_lisp_function(LispVal *args, LispVal *doc, LispVal *lexenv,
                            LispVal *body, bool is_macro) {
    LispFunction *self = lisp_malloc(sizeof(LispFunction));
    self->type = TYPE_FUNCTION;
    self->ref_count = 0;
    self->is_builtin = false;
    self->is_macro = is_macro;
    self->args = Qnil;
    self->kwargs = Qnil;
    void *cl = register_cleanup(&free_double_ptr, &self);
    set_function_args(self, args);
    cancel_cleanup(cl);

    // do these after the potential throw
    self->doc = lisp_ref(doc);
    self->lexenv = lisp_ref(lexenv);
    self->body = lisp_ref(body);
    return LISPVAL(self);
}

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

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

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

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

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

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

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

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

static bool hash_table_eq(LispHashtable *self, LispVal *v1, LispVal *v2) {
    if (NILP(self->eq_fn)) {
        return v1 == v2;
    } else if (self->eq_fn == Qstrings_equal) {
        return !NILP(Fstrings_equal(v1, v2));
    } else {
        LispVal *eq_obj;
        LispVal *args = const_list(2, v1, v2);
        WITH_CLEANUP(args, {
            eq_obj = Ffuncall(self->eq_fn, args); //
        });
        lisp_ref(eq_obj);
        bool result = !NILP(eq_obj);
        lisp_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;
        UNREF_INPLACE(hash_obj);
        return hash;
    } else {
        LispVal *hash_obj;
        LispVal *args = const_list(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 struct HashtableBucket *
find_hash_table_bucket(LispHashtable *self, LispVal *key, uint64_t hash) {
    struct HashtableBucket *cur = self->data[hash % self->table_size];
    while (cur) {
        if (hash_table_eq(self, key, cur->key)) {
            return cur;
        }
        cur = cur->next;
    }
    return NULL;
}

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

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

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

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

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

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

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

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

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

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

StackFrame *the_stack = NULL;
DEF_STATIC_SYMBOL(toplevel, "toplevel");
DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv");

void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
    StackFrame *frame = lisp_malloc(sizeof(StackFrame));
    frame->name = lisp_ref(name);
    frame->hidden = false;
    frame->detail = lisp_ref(detail);
    frame->lexenv = lisp_ref(make_lisp_hashtable(Qnil, Qnil));
    if (inherit && the_stack) {
        Fputhash(LISPVAL(frame->lexenv), Qparent_lexenv,
                 LISPVAL(the_stack->lexenv));
    }
    frame->enable_handlers = true;
    frame->handlers = lisp_ref(make_lisp_hashtable(Qnil, Qnil));
    frame->unwind_forms = 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;
    lisp_unref(frame->name);
    lisp_unref(frame->detail);
    lisp_unref(frame->lexenv);
    lisp_unref(frame->handlers);
    FOREACH(elt, frame->unwind_forms) {
        WITH_PUSH_FRAME(Qnil, Qnil, false, {
            IGNORE_REF(Feval(elt)); //
        });
    }
    lisp_unref(frame->unwind_forms);
    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;
    }
    lisp_free(frame);
}

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) {
    free(*(void **) ptr);
}

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

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

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

#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Winfinite-recursion"
DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
    CHECK_TYPE(TYPE_SYMBOL, signal);
    LispVal *error_arg = const_list(2, Fpair(signal, rest), Fbacktrace());
    for (; the_stack; stack_leave()) {
        if (!the_stack->enable_handlers) {
            continue;
        }
        LispVal *handler =
            Fgethash(LISPVAL(the_stack->handlers), signal, Qunbound);
        if (handler == Qunbound) {
            // handler for all exceptions
            handler = Fgethash(LISPVAL(the_stack->handlers), Qt, Qunbound);
        }
        if (handler != Qunbound) {
            the_stack->enable_handlers = false;
            LispVal *var = Fhead(handler);
            LispVal *form = Ftail(handler);
            WITH_PUSH_FRAME(Qnil, Qnil, true, {
                the_stack->hidden = true;
                if (!NILP(var)) {
                    // TODO make sure this isn't constant
                    Fputhash(the_stack->lexenv, var, error_arg);
                }
                WITH_CLEANUP(error_arg, {
                    IGNORE_REF(Feval(form)); //
                });
            });
            longjmp(the_stack->start, 1); // return a nonzero value
        }
    }
    // we never used it, so drop it
    lisp_unref(error_arg);
    fprintf(stderr,
            "ERROR: An exception has propogated 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...");
    abort();
}
#pragma GCC diagnostic pop

DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal");
DEF_STATIC_SYMBOL(type_error, "type-error");
DEF_STATIC_SYMBOL(read_error, "read-error");
DEF_STATIC_SYMBOL(eof_error, "eof-error");
DEF_STATIC_SYMBOL(void_variable_error, "void-variable-error");
DEF_STATIC_SYMBOL(void_function_error, "void-function-error");
DEF_STATIC_SYMBOL(circular_error, "circular-error");
DEF_STATIC_SYMBOL(malformed_lambda_list_error, "malformed-lambda-list-error");
DEF_STATIC_SYMBOL(argument_error, "argument-error");

LispVal *Vobarray = Qnil;

void lisp_init() {
    Vobarray = lisp_ref(make_lisp_hashtable(Qstrings_equal, Qhash_string));

    REGISTER_SYMBOL(nil);
    REGISTER_SYMBOL(t);
    REGISTER_SYMBOL(opt);
    REGISTER_SYMBOL(allow_other_keys);
    REGISTER_SYMBOL(key);
    REGISTER_SYMBOL(rest);

    REGISTER_FUNCTION(pair, "(head tail)",
                      "Return a new pair with HEAD and TAIL.");
    REGISTER_FUNCTION(head, "(pair)", "Return the head of PAIR.");
    REGISTER_FUNCTION(tail, "(pair)", "Return the tail of PAIR.");
    REGISTER_FUNCTION(quote, "(form)", "Return FORM as read by the reader.");
    REGISTER_FUNCTION(exit, "(&opt code)",
                      "Exit with CODE, defaulting to zero.");
    REGISTER_FUNCTION(print, "(obj)",
                      "Print a human-readable representation of OBJ.");
    REGISTER_FUNCTION(
        println, "(obj)",
        "Print a human-readable representation of OBJ followed by a newline.");
    REGISTER_FUNCTION(not, "(obj)",
                      "Return t if OBJ is nil, otherwise return t.");
    REGISTER_FUNCTION(when, "(cond &rest body)",
                      "Evaluate BODY if COND is non-nil.");
    REGISTER_FUNCTION(add, "(&rest nums)", "Return the sun of NUMS.");
    REGISTER_FUNCTION(
        if, "(cond then &rest else)",
        "Evaluate THEN if COND is non-nil, otherwise evaluate ELSE.");
    REGISTER_FUNCTION(
        setq, "(&rest args)",
        "Set each of a number of variables to their respective values.");
    REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS.");
    REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", "");
    REGISTER_FUNCTION(fset, "(sym new-func)", "");
}

void lisp_shutdown() {
    UNREF_INPLACE(Vobarray);
}

void register_static_function(LispVal *func) {}

static LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) {
    while (HASHTABLEP(lexenv)) {
        LispVal *value = Fgethash(lexenv, key, Qunbound);
        if (value != Qunbound) {
            return value;
        }
        lexenv = Fgethash(lexenv, Qparent_lexenv, Qunbound);
    }
    return Qunbound;
}

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

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

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

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

static LispVal **process_builtin_args(LispFunction *func, LispVal *args,
                                      size_t *nargs) {
    size_t raw_count =
        (func->n_req + func->n_opt + ((LispHashtable *) func->kwargs)->count
         + (func->has_rest));
    *nargs = raw_count;
    LispVal **vec = lisp_malloc(sizeof(LispVal *) * raw_count);
    memset(vec, 0, sizeof(LispVal *) * raw_count);
    LispVal *rest = Qnil;
    LispVal *rest_end;
    size_t have_count = 0;
    LispVal *index;
    LispVal *arg = Qnil; // last arg processed
    while (!NILP(args)) {
        arg = Fhead(args);
        if (have_count < func->n_req + func->n_opt) {
            vec[have_count++] = lisp_ref(arg);
        } else if (KEYWORDP(arg)
                   && !NILP(index = Fgethash(func->kwargs, arg, Qnil))
                   && NILP(rest)) {
            LispInteger *n = (LispInteger *) index;
            if (vec[n->value]) {
                goto multikey;
            }
            args = Ftail(args);
            if (NILP(args)) {
                goto key_no_val;
            }
            vec[n->value] = lisp_ref(Fhead(arg));
        } else if (KEYWORDP(arg) && !func->allow_other_keys && NILP(rest)) {
            goto unknown_key;
        } else if (!func->has_rest) {
            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);
            rest_end = new_end;
        }
        args = Ftail(args);
    }
    if (have_count < func->n_req) {
        goto too_few;
    }
    if (func->has_rest) {
        vec[raw_count - 1] = lisp_ref(rest);
    }
    for (size_t i = 0; i < raw_count; ++i) {
        if (!vec[i]) {
            vec[i] = Qnil;
        }
    }
    return vec;
    // TODO different messages
key_no_val:
too_many:
multikey:
unknown_key:
too_few:
    lisp_unref(rest);
    for (size_t i = 0; i < raw_count; ++i) {
        if (vec[i]) {
            lisp_unref(vec[i]);
        }
    }
    lisp_free(vec);
    Fthrow(Qargument_error, Qnil);
    return NULL;
}

static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args) {
    size_t nargs;
    LispVal **arg_vec = process_builtin_args(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 * (*) ()) 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);
    unref_free_list_double_ptr(&cleanup_data);
    return retval;
}

static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
                                   LispVal *args) {
    // TODO do this
    return Qnil;
}

static void check_args_for_function(LispFunction *fun, LispVal *args) {}

static LispVal *call_function(LispVal *func, LispVal *args,
                              LispVal *args_lexenv, bool eval_args) {
    LispFunction *fobj;
    if (FUNCTIONP(func)) {
        fobj = (LispFunction *) func;
    } else {
        fobj = (LispFunction *) Fsymbol_function(func, Qt);
    }
    if (LISPVAL(fobj) == Qunbound) {
        Fthrow(Qvoid_function_error, const_list(1, func));
    }
    CHECK_TYPE(TYPE_FUNCTION, fobj);
    if (!fobj->is_macro && eval_args) {
        args = eval_function_args(args, args_lexenv);
    }
    lisp_ref(args);
    LispVal *retval = Qnil;
    // builtin macros inherit their parents lexenv
    WITH_PUSH_FRAME(func, args, fobj->is_macro && fobj->is_builtin, {
        void *cl_handle = register_cleanup(
            (lisp_cleanup_func_t) &lisp_unref_double_ptr, &args);
        check_args_for_function(fobj, args);
        if (fobj->is_builtin) {
            retval = call_builtin(func, fobj, args);
        } else {
            retval = call_lisp_function(func, fobj, args);
        }
        cancel_cleanup(cl_handle);
    })
    lisp_unref(args);
    return retval;
}

DEFUN(eval_in_env, "eval-in-env", (LispVal * form, LispVal *lexenv)) {
    switch (TYPEOF(form)) {
    case TYPE_STRING:
    case TYPE_FUNCTION:
    case TYPE_INTEGER:
    case TYPE_FLOAT:
    case TYPE_HASHTABLE:
        // the above all are self-evaluating
        return form;
    case TYPE_SYMBOL:
        return symbol_value_in_lexenv(lexenv, form);
    case TYPE_VECTOR: {
        LispVector *vec = (LispVector *) form;
        LispVal **elts = lisp_malloc(sizeof(LispVal *) * vec->length);
        for (size_t i = 0; i < vec->length; ++i) {
            elts[i] = lisp_ref(Feval_in_env(vec->data[i], lexenv));
        }
        return make_lisp_vector(elts, vec->length);
    }
    case TYPE_PAIR: {
        LispPair *pair = (LispPair *) form;
        return call_function(pair->head, pair->tail, lexenv, true);
    }
    default:
        abort();
    }
}

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

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

DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
    LispVal *args = Qnil;
    LispVal *end;
    while (!NILP(rest) && !NILP(((LispPair *) rest)->tail)) {
        if (NILP(args)) {
            args = Fpair(((LispPair *) rest)->head, Qnil);
            end = args;
        } else {
            LispVal *new_end = Fpair(((LispPair *) rest)->head, Qnil);
            Fsettail(end, new_end);
            end = new_end;
        }
        rest = ((LispPair *) rest)->tail;
    }
    if (LISTP(((LispPair *) rest)->head)) {
        Fsettail(end, ((LispPair *) rest)->head);
    } else {
        LispVal *new_end = Fpair(((LispPair *) rest)->head, Qnil);

        Fsettail(end, new_end);
        end = new_end;
    }
    lisp_ref(args);
    void *cl_handle =
        register_cleanup((lisp_cleanup_func_t) &lisp_unref_double_ptr, &args);
    LispVal *retval = Ffuncall(function, args);
    cancel_cleanup(cl_handle);
    lisp_unref(args);
    return retval;
}

DEFUN(head, "head", (LispVal * list)) {
    if (NILP(list)) {
        return Qnil;
    }
    CHECK_TYPE(TYPE_PAIR, list);
    return ((LispPair *) list)->head;
}

DEFUN(tail, "tail", (LispVal * list)) {
    if (NILP(list)) {
        return Qnil;
    }
    CHECK_TYPE(TYPE_PAIR, list);
    return ((LispPair *) list)->tail;
}

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

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

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

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

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

DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil)) {
    LispVal *res = Feval(cond);
    LispVal *retval = Qnil;
    WITH_PUSH_FRAME(Qnil, Qnil, true, {
        the_stack->hidden = true;
        if (!NILP(res)) {
            retval = Feval(t);
        } else {
            LispVal *body = Fpair(Qprogn, nil);
            WITH_CLEANUP(body, {
                retval = Feval(body); //
            });
        }
    });
    return retval;
}

DEFMACRO(when, "when", (LispVal * cond, LispVal *t)) {
    LispVal *body = Fpair(Qprogn, t);
    LispVal *retval = Qnil;
    WITH_CLEANUP(body, {
        retval = Fif(cond, body, Qnil); //
    });
    return retval;
}

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

DEFMACRO(setq, "setq", (LispVal * name, LispVal *value)) {
    CHECK_TYPE(TYPE_SYMBOL, name);
    LispSymbol *sym = (LispSymbol *) name;
    LispVal *evaled = Feval(value);
    lisp_unref(sym->value);
    sym->value = lisp_ref(evaled);
    return evaled;
}

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

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

static void debug_dump_real(FILE *stream, void *obj, bool first) {
    switch (TYPEOF(obj)) {
    case TYPE_STRING: {
        LispString *str = (LispString *) obj;
        // TODO actually quote
        fputc('"', stream);
        fwrite(str->data, 1, str->length, stream);
        fputc('"', stream);
    } break;
    case TYPE_SYMBOL: {
        LispSymbol *sym = (LispSymbol *) obj;
        fwrite(sym->name->data, 1, sym->name->length, stream);
    } break;
    case TYPE_PAIR: {
        LispPair *pair = (LispPair *) obj;
        if (first) {
            fputc('(', stream);
        } else {
            fputc(' ', stream);
        }
        debug_dump_real(stream, pair->head, true);
        if (NILP(pair->tail)) {
            fputc(')', stream);
        } else if (PAIRP(pair->tail)) {
            debug_dump_real(stream, pair->tail, false);
        } else {
            fprintf(stream, " . ");
            debug_dump_real(stream, pair->tail, false);
            fputc(')', stream);
        }
    } break;
    case TYPE_INTEGER:
        fprintf(stream, "%jd", (intmax_t) ((LispInteger *) obj)->value);
        break;
    case TYPE_FLOAT:
        fprintf(stream, "%Lf", ((LispFloat *) obj)->value);
        break;
    case TYPE_VECTOR: {
        LispVector *vec = (LispVector *) obj;
        fputc('[', stream);
        for (size_t i = 0; i < vec->length; ++i) {
            if (i) {
                fputc(' ', stream);
            }
            debug_dump_real(stream, vec->data[i], true);
        }
        fputc(']', stream);
    } break;
    case TYPE_FUNCTION:
        if (((LispFunction *) obj)->builtin) {
            fprintf(stream, "<builtin at %#jx>", (uintmax_t) obj);
        } else {
            fprintf(stream, "<function 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;
    default:
        fprintf(stream, "<object type=%ju at %#jx>",
                (uintmax_t) LISPVAL(obj)->type, (uintmax_t) obj);
        break;
    }
}

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

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