simple-lisp/bootstrap/compile.c

#include "compile.h"

#include <stdlib.h>
#include <string.h>
#include <stdarg.h>

static ssize_t byte_compile_form_internal(CompileEnvironment *env,
                                          AstNode *form, LispReg *target,
                                          FILE *stream, CompileError **err);

static void push_error_raw(CompileError **list, CompileError *n) {
    if (list) {
        n->next = *list;
        *list = n;
    }
}

__attribute__((format(printf, 4, 5)))
static void push_error_at_ast(CompileError **list, AstNode *form,
                              CompileErrorType type, const char *fmt, ...) {
    if (list) {
        CompileError *err = malloc(sizeof(CompileError));
        err->type = type;
        err->context = ast_prin1_node_to_string(form, NULL);
        va_list args;
        va_start(args, fmt);
        err->message = NULL;
        vasprintf(&err->message, fmt, args);
        va_end(args);
        err->line = form->line;
        err->col = form->col;
        push_error_raw(list, err);
    }
}

__attribute__((format(printf, 4, 5)))
static void push_error_with_ctx(CompileError **list, const char *ctx,
                                CompileErrorType type, const char *fmt, ...) {
    if (list) {
        CompileError *err = malloc(sizeof(CompileError));
        err->type = type;
        if (ctx) {
            err->context = strdup(ctx);
        } else {
            err->context = NULL;
        }
        va_list args;
        va_start(args, fmt);
        err->message = NULL;
        vasprintf(&err->message, fmt, args);
        va_end(args);
        err->line = 0; // no position information
        err->col = 0;
        push_error_raw(list, err);
    }
}

CompileFormat COMPILE_FORMAT = COMPILE_FORMAT_BIN;

typedef enum {
    ARG_U8,
    ARG_U16,
    ARG_U32,
    ARG_U64,
    ARG_I8,
    ARG_I16,
    ARG_I32,
    ARG_I64,
    ARG_REG,
    ARG_STR,
    ARG_BYTES,
    ARG_DOUBLE,
} InstArgType;

static bool emit_next_arg_c(CompileError **err, FILE *stream,
                            va_list args) {
    InstArgType type = va_arg(args, InstArgType);
    if (type == ARG_STR || type == ARG_BYTES) {
        size_t len;
        if (type == ARG_BYTES) {
            len = va_arg(args, size_t);
        }
        const char *val = va_arg(args, const char *);
        if (type == ARG_STR) {
            len = strlen(val);
        }
        size_t escaped_len;
        char *escaped = ast_escape_string(val, len, &escaped_len);
        fputc('"', stream);
        fwrite(escaped, 1, escaped_len, stream);
        fputc('"', stream);
        free(escaped);
        return true;
    } else if (type == ARG_REG) {
        LispRegType type = va_arg(args, int); // LispRegType promotes to int
        if (type > N_REGISTTERS) {
            push_error_with_ctx(err, NULL, COMPILE_ERROR,
                                "unknown register type: %ju", (uintmax_t) type);
            return false;
        }
        uint32_t which = va_arg(args, uint32_t);
        fprintf(stream, "%s%ju", REGISTER_NAMES[type], (uintmax_t) which);
        return true;
    } else if (type == ARG_DOUBLE) {
        double value = va_arg(args, double);
        fprintf(stream, "%f", value);
        return true;
    }
    uint64_t val;
    const char *format;
    switch (type) {
    case ARG_U8: // promoted
    case ARG_U16: // promoted
    case ARG_U32:
        val = va_arg(args, uint32_t);
        format = "%ju";
        break;
    case ARG_U64:
        val = va_arg(args, uint64_t);
        format = "%ju";
        break;
    case ARG_I8:
    case ARG_I16:
    case ARG_I32:
        val = va_arg(args, uint32_t);
        format = "%jd";
        break;
    case ARG_I64:
        val = va_arg(args, uint64_t);
        format = "%jd";
        break;
    default:
        // shouldn't happen
        abort();
        break;
    }
    fprintf(stream, format, (uintmax_t) val);
    return true;
}

static bool emit_next_arg_bin(CompileError **err, FILE *stream,
                              va_list args) {
    InstArgType type = va_arg(args, InstArgType);
    if (type == ARG_STR || type == ARG_BYTES) {
        size_t len;
        if (type == ARG_BYTES) {
            len = va_arg(args, size_t);
        }
        const char *val = va_arg(args, const char *);
        if (type == ARG_STR) {
            len = strlen(val);
        }
        fwrite(&len, sizeof(len), 1, stream);
        fwrite(val, 1, len, stream);
        return true;
    } else if (type == ARG_REG) {
        LispRegType type = va_arg(args, int); // LispRegType promotes to int
        if (type > N_REGISTTERS) {
            push_error_with_ctx(err, NULL, COMPILE_ERROR,
                                "unknown register type: %ju", (uintmax_t) type);
            return false;
        }
        uint32_t which = va_arg(args, uint32_t);
        fwrite(&type, sizeof(type), 1, stream);
        fwrite(&which, sizeof(which), 1, stream);
        return true;
    } else if (type == ARG_DOUBLE) {
        double val = va_arg(args, double);
        fwrite(&val, sizeof(val), 1, stream);
        return true;
    }
    size_t size;
    uint64_t val;
    switch (type) {
    case ARG_U8:
    case ARG_I8:
        size = 8;
        val = va_arg(args, uint32_t);
        break;
    case ARG_U16:
    case ARG_I16:
        size = 16;
        val = va_arg(args, uint32_t);
        break;
    case ARG_U32:
    case ARG_I32:
        size = 32;
        val = va_arg(args, uint32_t);
        break;
    case ARG_U64:
    case ARG_I64:
        size = 64;
        val = va_arg(args, uint64_t);
        break;
    default:
        // shouldn't happen
        abort();
        break;
    }
    fwrite(((void *) &val) + sizeof(uint64_t) - size, size, 1, stream);
    return false;
}

// false on error, true on success
static bool emit_instruction(CompileError **err, FILE *stream,
                             LispInst inst, size_t nargs, ...) {
    if (inst > N_INSTRUCTIONS) {
        push_error_with_ctx(err, NULL, COMPILE_ERROR,
                            "unknown instruction: %ju", (intmax_t) inst);
        return false;
    }
    switch (COMPILE_FORMAT) {
    case COMPILE_FORMAT_ASM:
        fprintf(stream, "%s%s", INSTRUCTION_NAMES[inst],
                nargs ? " " : "");
        break;
    case COMPILE_FORMAT_BIN:
        fwrite(&inst, sizeof(inst), 1, stream);
        break;
    }
    bool success = true;
    va_list args;
    va_start(args, nargs);
    for (size_t i = 0; i < nargs; ++i) {
        switch (COMPILE_FORMAT) {
        case COMPILE_FORMAT_ASM:
            success = emit_next_arg_c(err, stream, args);
            if (i < nargs - 1) {
                fprintf(stream, ", ");
            }
            break;
        case COMPILE_FORMAT_BIN:
            success = emit_next_arg_bin(err, stream, args);
            break;
        }
        if (!success) {
            break;
        }
    }
    va_end(args);
    if (COMPILE_FORMAT == COMPILE_FORMAT_ASM) {
        fputc('\n', stream);
    }
    return success;
}

CompileError *compile_error_pop(CompileError **err) {
    CompileError *retval = *err;
    if (*err) {
        *err = (*err)->next;
    }
    return retval;
}

void compile_error_free_one(CompileError *err) {
    free(err->message);
    free(err->context);
    free(err);
}

void compile_error_free_all(CompileError **err) {
    while (*err) {
        CompileError *next = (*err)->next;
        compile_error_free_one(*err);
        *err = next;
    }
}

void compile_format_error(CompileError *err, const char *file, FILE *stream) {
    fprintf(stream, "error: ");
    if (file) {
        fprintf(stream, "%s: ", file);
    }
    if (err->line) {
        fprintf(stream, "%zu:%zu:", err->line, err->col);
    }
    fprintf(stream, "%s", err->message);
    if (err->context) {
        fprintf(stream, ":\n%s\n", err->context);
    } else {
        fputc('\n', stream);
    }
}

void destroy_function_entry(FunctionEntry *entry) {
    free(entry->name);
    free(entry->doc);
    for (size_t i = 0; i < entry->nkeys; ++i) {
        free(entry->keys[i]);
    }
    free(entry->keys);
}

void destroy_variable_entry(VariableEntry *entry) {
    free(entry->name);
    free(entry->doc);
}

void destroy_compile_lexenv(CompileLexenv *lexenv) {
    for (size_t i = 0; i < lexenv->nsymbols; ++i) {
        free(lexenv->symbols[i].name);
    }
    free(lexenv->symbols);
    for (size_t i = 0; i < lexenv->nvars; ++i) {
        free(lexenv->vars[i].name);
    }
    free(lexenv->vars);
    free(lexenv);
}

static void environment_enter_lexenv(CompileEnvironment *env, bool inherit) {
    CompileLexenv *n = malloc(sizeof(CompileLexenv));
    n->vars = NULL;
    n->nvars = 0;
    n->symbols = NULL;
    n->nsymbols = 0;
    n->first_avaiable_saved = 0;
    n->next = env->lexenv_stack;
    if (inherit && env->lexenv_stack) {
        n->first_avaiable_saved += env->lexenv_stack->first_avaiable_saved;
    }
    n->inherit = inherit;
    env->lexenv_stack = n;
}

static void environment_leave_lexenv(CompileEnvironment *env) {
    if (env->lexenv_stack) {
        CompileLexenv *next = env->lexenv_stack->next;
        destroy_compile_lexenv(env->lexenv_stack);
        env->lexenv_stack = next;
    }
}

CompileEnvironment *make_compile_environment() {
    CompileEnvironment *env = malloc(sizeof(CompileEnvironment));
    env->funcs = NULL;
    env->nfuncs = 0;
    env->vars = NULL;
    env->nvars = 0;
    env->lexenv_stack = NULL;
    environment_enter_lexenv(env, false); // toplevel lexenv
    return env;
}

void destroy_compile_environment(CompileEnvironment *env) {
    for (size_t i = 0; i < env->nfuncs; ++i) {
        destroy_function_entry(&env->funcs[i]);
    }
    for (size_t i = 0; i < env->nvars; ++i) {
        destroy_variable_entry(&env->vars[i]);
    }
    while (env->lexenv_stack) {
        CompileLexenv *next = env->lexenv_stack->next;
        destroy_compile_lexenv(env->lexenv_stack);
        env->lexenv_stack = next;
    }
    free(env);
}

static bool is_symbol_named(const char *name, AstNode *form) {
    return form->type == AST_TYPE_SYMBOL &&
           strcmp(name, ((AstSymbolNode *) form)->name) == 0;
}

static bool is_function_call(AstNode *form) {
    return form->type == AST_TYPE_LIST && ((AstListNode *) form)->nchildren;
}

static bool is_function_call_named(const char *name, AstNode *form) {
    return is_function_call(form) &&
           is_symbol_named(name, ((AstListNode *) form)->children[0]);
}

static FunctionEntry *lookup_function(CompileEnvironment *env,
                                      AstSymbolNode *name) {
    for (size_t i = 0; i < env->nfuncs; ++i) {
        FunctionEntry *cur = &env->funcs[i];
        if (cur->name_len == name->name_length &&
            strcmp(cur->name, name->name) == 0) {
            return cur;
        }
    }
    return NULL;
}

static VariableEntry *lookup_variable(CompileEnvironment *env,
                                      AstSymbolNode *name) {
    for (size_t i = 0; i < env->nvars; ++i) {
        VariableEntry *cur = &env->vars[i];
        if (cur->name_len == name->name_length &&
            strcmp(cur->name, name->name) == 0) {
            return cur;
        }
    }
    return NULL;
}

static bool is_property_symbol(AstNode *form) {
    return form->type == AST_TYPE_SYMBOL &&
           ((AstSymbolNode *) form)->is_property;
}

static char *copy_symbol_name(AstSymbolNode *sym) {
    char *buf = malloc(sym->name_length + 1);
    memcpy(buf, sym->name, sym->name_length + 1);
    return buf;
}

static bool function_key_ok(AstSymbolNode *key, FunctionEntry *func) {
    if (func->allow_other_keys) {
        return true;
    }
    for (size_t i = 0; i < func->nkeys; ++i) {
        if (strcmp(key->name, func->keys[i]) == 0) {
            return true;
        }
    }
    return false;
}

// return false only if there is an error (not a warning)
static bool function_arguments_ok(AstListNode *form, FunctionEntry *func,
                                  CompileError **err) {
    bool was_ok = true;
    size_t npositional = form->nchildren - 1;
    for (size_t i = 1; i < form->nchildren; ++i) {
        if (is_property_symbol(form->children[i])) {
            if (!function_key_ok((AstSymbolNode *) form->children[i], func)) {
                push_error_at_ast(err, form->children[i], COMPILE_WARNING,
                                  "unknown key for function %s", func->name);
            }
            if (i == form->nchildren - 1) {
                push_error_at_ast(err, form->children[i], COMPILE_ERROR,
                                  "no value provided to key");
                was_ok = false;
            }
            // skip next arg
            ++i;
            npositional -= 2;
        }
    }
    if (npositional < func->nrequired) {
        push_error_at_ast(err, (AstNode *) form, COMPILE_ERROR,
                          "function expects at least %zu argument(s), got %zu",
                          func->nrequired, npositional);
        was_ok = false;
    } else if (!func->has_rest && npositional > func->nrequired + func->noptional) {
        push_error_at_ast(err, (AstNode *)form, COMPILE_ERROR,
                          "function expects at most %zu argument(s), got %zu",
                          func->nrequired + func->noptional, npositional);
        was_ok = false;
    }
    return was_ok;
}

static void intern_in_lexenv(CompileLexenv *lexenv, const char *name,
                             LispReg *reg) {
    if (lexenv) {
        lexenv->symbols = realloc(lexenv->symbols, sizeof(*lexenv->symbols)
                                                   * ++(lexenv->nsymbols));
        lexenv->symbols[lexenv->nsymbols - 1].name = strdup(name);
        lexenv->symbols[lexenv->nsymbols - 1].reg = *reg;
    }
}

static LispReg *lookup_symbol_reg(CompileEnvironment *env, const char *name) {
    CompileLexenv *lexenv = env->lexenv_stack;
    while (lexenv) {
        for (size_t i = 0; i < lexenv->nsymbols; ++i) {
            if (strcmp(name, lexenv->symbols[i].name) == 0) {
                return &lexenv->symbols[i].reg;
            }
        }
        if (lexenv->inherit) {
            lexenv = lexenv->next;
        } else {
            lexenv = NULL;
        }
    }
    return NULL;
}

static LispReg *lookup_local_var(CompileEnvironment *env, const char *name) {
    CompileLexenv *lexenv = env->lexenv_stack;
    while (lexenv) {
        for (size_t i = 0; i < lexenv->nvars; ++i) {
            if (strcmp(name, lexenv->vars[i].name) == 0) {
                return &lexenv->vars[i].reg;
            }
        }
        if (lexenv->inherit) {
            lexenv = lexenv->next;
        } else {
            lexenv = NULL;
        }
    }
    return NULL;
}

static void next_open_saved_reg(CompileEnvironment *env, LispReg *out) {
    out->type = REG_SAVED;
    if (env->lexenv_stack) {
        out->which = env->lexenv_stack->first_avaiable_saved++;                 
    } else {
        out->which = 0;
    }
}

// return number of instructions emitted, or -1 on error
static ssize_t intern_to_register(CompileEnvironment *env, FILE *stream,
                                  const char *name, size_t name_len,
                                  LispReg *target, CompileError **err) {
    CompileLexenv *lexenv = env->lexenv_stack;
    LispReg *cur_reg = lookup_symbol_reg(env, name);
    if (cur_reg) {
        if (SAME_REG(cur_reg, target)) {
            return 0;
        }
        if (!emit_instruction(err, stream, INST_MOV, 2,
                              ARG_REG, target->type, target->which,
                              ARG_REG, cur_reg->type, cur_reg->which)) {
            return -1;
        }
    } else {
        if (!emit_instruction(err, stream, INST_INTERN_LIT, 2,
                              ARG_REG, target->type, target->which,
                              ARG_BYTES, name_len, name)) {
            return -1;
        }
        if (target->type == REG_SAVED) {
            intern_in_lexenv(lexenv, name, target);
        }
    }
    return 1;
}

static ssize_t intern_and_save(CompileEnvironment *env, FILE *stream,
                               const char *name, size_t name_len,
                               LispReg *reg, CompileError **err) {
    CompileLexenv *lexenv = env->lexenv_stack;
    LispReg *cur_reg = lookup_symbol_reg(env, name);
    if (cur_reg) {
        *reg = *cur_reg;
        return 0;
    } 
    next_open_saved_reg(env, reg);
    if (!emit_instruction(err, stream, INST_INTERN_LIT, 2,
                          ARG_REG, reg->type, reg->which,
                          ARG_BYTES, name_len, name)) {
        return -1;
    }
    intern_in_lexenv(lexenv, name, reg);
    return 1;
}

static FunctionEntry *get_or_make_function_entry(CompileEnvironment *env,
                                                 AstSymbolNode *name,
                                                 bool warn_on_redef,
                                                 CompileError **err,
                                                 AstNode *form) {
    for (size_t i = 0; i < env->nfuncs; ++i) {
        if (name->name_length == env->funcs[i].name_len &&
            strcmp(env->funcs[i].name, name->name) == 0) {
            if (warn_on_redef) {
                push_error_at_ast(err, form, COMPILE_WARNING,
                                  "function already defined");
            }
            return &env->funcs[i];
        }
    }
    env->funcs = realloc(env->funcs, sizeof(FunctionEntry) * ++env->nfuncs);
    FunctionEntry *ne = &env->funcs[env->nfuncs - 1];
    ne->name = strdup(name->name);
    ne->name_len = name->name_length;
    ne->line = form->line;
    ne->col = form->col;
    return ne;
}

// true on success, false on error
static bool parse_function_lambda_list(AstListNode *list, FunctionEntry *entry,
                                       CompileError **err) {
    entry->allow_other_keys = false;
    entry->keys = NULL;
    entry->nkeys = 0;
    entry->required = NULL;
    entry->nrequired = 0;
    entry->optional = NULL;
    entry->noptional = 0;
    if (list->parent.type == AST_TYPE_NULL) {
        return true;
    }
    bool found_opt = false;
    bool found_rest = false;
    bool found_key = false;
    bool found_allow_other_keys = false;
    // 0 = req, 1 = opt, 2 = key, 3 = rest
    int cur_mode = 0;
    for (size_t i = 0; i < list->nchildren; ++i) {
        if (list->children[i]->type != AST_TYPE_SYMBOL) {
            char *printed_rep = ast_prin1_node_to_string(list->children[i], NULL);
            push_error_at_ast(err, (AstNode *) list, COMPILE_ERROR,
                              "function argument not a symbol %s", printed_rep);
            free(printed_rep);
            return false;
        }
        AstSymbolNode *arg = (AstSymbolNode *) list->children[i];
        if (is_symbol_named("&optional", (AstNode *) arg)) {
            if (found_opt) {
                push_error_at_ast(err, (AstNode *) list, COMPILE_ERROR,
                                  "&optional appeared more than once");
                return false;
            }
            found_opt = true;
            cur_mode = 1;
        } else if (is_symbol_named("&rest", (AstNode *) arg)) {
            if (found_rest) {
                push_error_at_ast(err, (AstNode *) list, COMPILE_ERROR,
                                  "&rest appeared more than once");
                return false;
            }
            found_rest = true;
            cur_mode = 3;
        } else if (is_symbol_named("&key", (AstNode *) arg)) {
            if (found_key) {
                push_error_at_ast(err, (AstNode *) list, COMPILE_ERROR,
                                  "&key appeared more than once");
                return false;
            }
            found_key = true;
            cur_mode = 2;
        } else if (is_symbol_named("&allow-other-keys", (AstNode *) arg)) {
            if (found_allow_other_keys) {
                push_error_at_ast(err, (AstNode *) list, COMPILE_ERROR,
                                  "&allow-other-keys appeared more than once");
                return false;
            }
            found_allow_other_keys = true;
        } else if (cur_mode == 3) { // rest
            if (entry->has_rest) {
                push_error_at_ast(err, (AstNode *) list, COMPILE_ERROR,
                                  "there can only be 1 &rest variable");
                return false;
            }
            entry->has_rest = true;
            entry->rest = copy_symbol_name(arg);
        } else {
            size_t *target_len;
            char ***target_var;
            switch (cur_mode) {
            case 0: // req
                target_len = &entry->nrequired;
                target_var = &entry->required;
                break;
            case 1: // opt
                target_len = &entry->noptional;
                target_var = &entry->optional;
                break;
            case 2: // key
                target_len = &entry->nkeys;
                target_var = &entry->keys;
                break;
            }
            *target_var = realloc(*target_var, sizeof(char *) * ++(*target_len));
            (*target_var)[*target_len - 1] = copy_symbol_name(arg);
        }
    }
    if (!found_key && found_allow_other_keys) {
        push_error_at_ast(err, (AstNode *)list, COMPILE_WARNING,
                          "&allow-other-keys appeared without &key");
    }
    return true;
}

static FunctionEntry *parse_and_add_function(CompileEnvironment *env,
                                             AstListNode *form,
                                   CompileError **err) {
    if (form->nchildren < 2 || (form->children[2]->type != AST_TYPE_LIST &&
                                (form->children[2]->type != AST_TYPE_NULL))) {
        push_error_at_ast(err, (AstNode *) form, COMPILE_ERROR,
                          "invalid arguments to defun");
        return NULL;
    }
    AstSymbolNode *name = (AstSymbolNode *) form->children[1];
    FunctionEntry *entry = get_or_make_function_entry(env, name, true, err,
                                                      (AstNode *) form);
    if (!parse_function_lambda_list((AstListNode *) form->children[2],
                                    entry, err)) {
        return NULL;
    }
    if (form->nchildren >= 4 && form->children[3]->type == AST_TYPE_STRING) {
        AstStringNode *doc_node = (AstStringNode *) form->children[3];
        entry->doc_len = doc_node->length;
        entry->doc = malloc(doc_node->length + 1);
        memcpy(entry->doc, doc_node->value, doc_node->length + 1);
    }
    return entry;
}

static void add_variable_to_lexenv(CompileLexenv *lexenv, const char *name,
                                   LispReg *reg) {
    lexenv->vars = realloc(lexenv->vars, sizeof(*lexenv->vars) *
                                         ++lexenv->nvars);
    lexenv->vars[lexenv->nvars - 1].name = strdup(name);
    lexenv->vars[lexenv->nvars - 1].reg = *reg;
}

static ssize_t save_arg_register(CompileEnvironment *env, uint32_t which_arg,
                                 LispReg *target, FILE *stream, CompileError **err) {
    next_open_saved_reg(env, target);
    return emit_instruction(err, stream, INST_MOV, 2,
                            ARG_REG, target->type, target->which,
                            ARG_REG, REG_ARG, which_arg);
}

static ssize_t add_lambda_list_to_lexenv(CompileEnvironment *env,
                                         FunctionEntry *entry,
                                         FILE *stream,
                                         CompileError **err) {
    ssize_t total_int = 0;
    for (size_t i = 0; i < entry->nrequired; ++i) {
        LispReg target;
        ssize_t ec = save_arg_register(env, i, &target, stream, err);
        if (ec < 0) {
            return -1;
        }
        total_int += ec;
        add_variable_to_lexenv(env->lexenv_stack, entry->required[i], &target);
    }
    for (size_t i = 0; i < entry->noptional; ++i) {
        LispReg target;
        size_t pos = i + entry->nrequired;
        ssize_t ec = save_arg_register(env, pos, &target, stream, err);
        if (ec < 0) {
            return -1;
        }
        total_int += ec;
        add_variable_to_lexenv(env->lexenv_stack, entry->optional[i], &target);
    }
    for (size_t i = 0; i < entry->nkeys; ++i) {
        LispReg target;
        size_t pos = i + entry->nrequired + entry->noptional;
        ssize_t ec = save_arg_register(env, pos, &target, stream, err);
        if (ec < 0) {
            return -1;
        }
        total_int += ec;
        add_variable_to_lexenv(env->lexenv_stack, entry->keys[i], &target);
    }
    if (entry->rest) {
        LispReg target;
        size_t pos = entry->nrequired + entry->noptional + entry->nkeys;
        ssize_t ec = save_arg_register(env, pos, &target, stream, err);
        if (ec < 0) {
            return -1;
        }
        total_int += ec;
        add_variable_to_lexenv(env->lexenv_stack, entry->rest, &target);
    }
    return 0;
}

static ssize_t compile_defun_call(CompileEnvironment *env, AstListNode *form,
                                  LispReg *target, FILE *stream,
                                  CompileError **err) {
    AstSymbolNode *name = (AstSymbolNode *) form->children[1];
    FunctionEntry *entry = lookup_function(env, name);
    if (!entry && !(entry = parse_and_add_function(env, form, err))) {
        return -1;
    }
    size_t first_form = 3;
    if (form->nchildren >= 4 && form->children[3]->type == AST_TYPE_STRING) {
        ++first_form;
    }
    size_t internal_len = 0;
    char *internal_code = NULL;
    FILE *int_stream = open_memstream(&internal_code, &internal_len);
    environment_enter_lexenv(env, false);
    ssize_t int_nforms = add_lambda_list_to_lexenv(env, entry, int_stream, err);
    if (int_nforms < 0) {
        goto compile_error;
    }
    for (size_t i = first_form; i < form->nchildren; ++i) {
        ssize_t ec;
        if (i < form->nchildren - 1) {
            ec = byte_compile_form_internal(env, form->children[i], NULL,
                                            int_stream, err);
        } else {
            LispReg ret_reg = {
                .type = REG_RET,
                .which = 0,
            };
            ec = byte_compile_form_internal(env, form->children[i], &ret_reg,
                                            int_stream, err);
        }
        if (ec < 0) {
            goto compile_error;
        }
        int_nforms += ec;
    }
    environment_leave_lexenv(env);
    LispReg backup_target = {
        .type = REG_VAL,
        .which = env->first_available_var,
    };
    if (!target) {
        target = &backup_target;
    }
    ssize_t ec = emit_instruction(err, stream, INST_NEWFUNCTION_LIT, 2,
                                  ARG_REG, target->type, target->which,
                                  // account for the block and lexenv instructions
                                  ARG_U64, (uint64_t) int_nforms + 5);
    if (ec < 0) {
        goto compile_error;
    }
    ec = emit_instruction(err, stream, INST_ENTER_LEXENV, 0);
    if (ec < 0) {
        goto compile_error;
    }
    LispReg name_reg;
    ec = intern_and_save(env, stream, entry->name, entry->name_len, &name_reg, err);
    if (ec < 0) {
        goto compile_error;
    }
    ec = emit_instruction(err, stream, INST_ENTER_BLOCK, 2,
                          ARG_REG, name_reg.type, name_reg.which,
                          ARG_U64, (uint64_t) int_nforms + 1);
    if (ec < 0) {
        goto compile_error;
    }
    fclose(int_stream);
    fwrite(internal_code, 1, internal_len, stream);
    free(internal_code);
    ec = emit_instruction(err, stream, INST_LEAVE_BLOCK, 1,
                          ARG_REG, name_reg.type, name_reg.which);
    if (ec < 0) {
        return -1;
    }
    ec = emit_instruction(err, stream, INST_LEAVE_LEXENV, 0);
    if (ec < 0) {
        return -1;
    }
    return int_nforms + 5;
 compile_error:
    fclose(int_stream);
    free(internal_code);
    return -1;
}

static ssize_t compile_devar_call(CompileEnvironment *env, AstListNode *form,
                                  LispReg *target, FILE *stream,
                                  CompileError **err) {
    return 0;
}

static const struct {
    const char *name;
    ssize_t (*handler)(CompileEnvironment *env, AstListNode *form,
                       LispReg *target, FILE *stream, CompileError **err);
} NATIVE_FUNCTIONS[] = {
    {"defun", compile_defun_call},
    {"devar", compile_devar_call},
};
const size_t N_NATIVE_FUNCTIONS = sizeof(NATIVE_FUNCTIONS) /
                                  sizeof(NATIVE_FUNCTIONS[0]);

static ssize_t compile_string_node(CompileEnvironment *env, AstStringNode *form,
                                   LispReg *target, FILE *stream,
                                   CompileError **err) {
    return emit_instruction(err, stream, INST_STRING, 2,
                            ARG_REG, target->type, target->which,
                            ARG_BYTES, form->length, form->value) ? 1 : -1;
}

static ssize_t compile_int_node(CompileEnvironment *env, AstIntNode *form,
                                LispReg *target, FILE *stream,
                                CompileError **err) {

    return emit_instruction(err, stream, INST_INT, 2,
                            ARG_REG, target->type, target->which,
                            ARG_U64, form->value) ? 1 : -1;
}

static ssize_t compile_float_node(CompileEnvironment *env, AstFloatNode *form,
                                  LispReg *target, FILE *stream,
                                  CompileError **err) {

    return emit_instruction(err, stream, INST_FLOAT, 2,
                            ARG_REG, target->type, target->which,
                            ARG_DOUBLE, form->value) ? 1 : -1;
}

static ssize_t compile_null_node(CompileEnvironment *env, AstNode *form,
                                 LispReg *target, FILE *stream,
                                 CompileError **err) {
    return emit_instruction(err, stream, INST_NIL, 1,
                            ARG_REG, target->type, target->which) ? 1 : -1;
}

static ssize_t compile_symbol_node(CompileEnvironment *env, AstSymbolNode *form,
                                   LispReg *target, FILE *stream,
                                   CompileError **err) {
    if (strcmp(form->name, "t") == 0) {
        return emit_instruction(err, stream, INST_T, 1,
                                ARG_REG, target->type, target->which) ? 1 : -1;
    }
    LispReg *var_reg = lookup_local_var(env, form->name);
    if (var_reg) {
        if (SAME_REG(var_reg, target)) {
            return 0;
        }
        return emit_instruction(err, stream, INST_MOV, 2,
                                ARG_REG, target->type, target->which,
                                ARG_REG, var_reg->type, var_reg->which) ? 1 : -1;
    } else {
        // global variable
        if (!lookup_variable(env, form)) {
            // TODO add to queue to check later
        }
        LispReg sym_reg;
        ssize_t ec = intern_and_save(env, stream, form->name, form->name_length,
                                     &sym_reg, err);
        if (ec < 0) {
            return -1;
        }
        emit_instruction(err, stream, INST_GET_VALUE, 2,
                         ARG_REG, target->type, target->which,
                         ARG_REG, sym_reg.type, sym_reg.which);
        return ec + 1;
    }
}

static ssize_t compile_quoted_symbol_node(CompileEnvironment *env, AstSymbolNode *form,
                                          LispReg *target, FILE *stream,
                                          CompileError **err) {
    return emit_instruction(err, stream, INST_INTERN_LIT, 2,
                            ARG_REG, target->type, target->which,
                            ARG_BYTES, form->name_length, form->name) ? 1 : -1;
}

static ssize_t compile_quoted_quote_node(CompileEnvironment *env, AstQuoteNode *form,
                                         LispReg *target, FILE *stream,
                                         CompileError **err) {
    // return (quote internal-form)
    LispReg arg_reg = {
        .type = REG_ARG,
        .which = 1,
    };
    ssize_t ec = byte_compile_form_internal(env, (AstNode *) form->form,
                                            &arg_reg, stream, err);
    if (ec < 0) {
        return -1;
    }
    LispReg quote_sym_reg;
    ssize_t ec2 = intern_and_save(env, stream, "quote", sizeof("quote") - 1,
                                  &quote_sym_reg, err);
    if (ec2 < 0) {
        return -1;
    }
    if (!emit_instruction(err, stream, INST_MOV, 2,
                          ARG_REG, REG_ARG, (uint32_t) 0,
                          ARG_REG, quote_sym_reg.type, quote_sym_reg.which)) {
        return -1;
    }
    if (!emit_instruction(err, stream, INST_LIST, 2,
                          ARG_REG, target->type, target->which,
                          ARG_U64, (uint64_t) 2)) {
        return -1;
    }
    return ec + ec2 + 2;
}

static ssize_t compile_quote_node(CompileEnvironment *env, AstQuoteNode *form,
                                  LispReg *target, FILE *stream,
                                  CompileError **err) {
    switch (form->type) {
    case AST_QUOTE_NORM:
    case AST_QUOTE_BACK: {
        env->quote = form->type;
        size_t ec = byte_compile_form_internal(env, form->form, target,
                                               stream, err);
        env->quote = AST_QUOTE_NONE;
        return ec;
    }
    case AST_QUOTE_COMMA: {
        if (env->quote != AST_QUOTE_BACK) {
            push_error_at_ast(err, (AstNode *)form, COMPILE_ERROR,
                              "comma not inside backquote");
            return -1;
        }
        env->quote = AST_QUOTE_NONE;
        ssize_t ec = byte_compile_form_internal(env, form->form, target,
                                                stream, err);
        env->quote = AST_QUOTE_BACK;
        return ec;
    }
    case AST_QUOTE_SPLICE:
        // TODO handle this
        return 0;
    case AST_QUOTE_NONE:
        // shouldn't happen, do nothing
        return 0;
    }
}

static ssize_t compile_quoted_list_node(CompileEnvironment *env, AstListNode *form,
                                        LispReg *target, FILE *stream,
                                        CompileError **err) {
    LispReg arg_reg = {
        .type = REG_ARG,    
    };
    size_t total_emitted = 0;
    for (size_t i = 0; i < form->nchildren; ++i) {
        arg_reg.which = i;
        ssize_t ec = byte_compile_form_internal(env, form->children[i],
                                                &arg_reg, stream, err);
        if (ec < 0) {
            return -1;
        }
        total_emitted += ec;
    }
    if (!emit_instruction(err, stream, INST_LIST, 2,
                          ARG_REG, target->type, target->which,
                          ARG_U64, form->nchildren)) {
        return -1;
    }
    return total_emitted + 1;
}

static ssize_t compile_vector_node(CompileEnvironment *env, AstVectorNode *form,
                                   LispReg *target, FILE *stream,
                                   CompileError **err) {
    env->quote = AST_QUOTE_NORM;
    LispReg arg_reg = {
        .type = REG_ARG,    
    };
    size_t total_emitted = 0;
    for (size_t i = 0; i < form->nchildren; ++i) {
        arg_reg.which = i;
        ssize_t ec = byte_compile_form_internal(env, form->children[i],
                                                &arg_reg, stream, err);
        if (ec < 0) {
            return -1;
        }
        total_emitted += ec;
    }
    if (!emit_instruction(err, stream, INST_VECTOR, 2,
                          ARG_REG, target->type, target->which,
                          ARG_U64, form->nchildren)) {
        return -1;
    }
    env->quote = AST_QUOTE_NONE;
    return total_emitted + 1;
}

static ssize_t compile_atom_node(CompileEnvironment *env, AstNode *form,
                                 LispReg *target, FILE *stream,
                                 CompileError **err) {
    switch (form->type) {
    case AST_TYPE_INT:
        return compile_int_node(env, (AstIntNode *) form, target, stream, err);
    case AST_TYPE_FLOAT:
        return compile_float_node(env, (AstFloatNode *)form, target, stream, err);
    case AST_TYPE_STRING:
        return compile_string_node(env, (AstStringNode *) form, target, stream, err);
    case AST_TYPE_NULL:
        return compile_null_node(env, form, target, stream, err);
    case AST_TYPE_SYMBOL:
        if (env->quote == AST_QUOTE_NONE) {
            return compile_symbol_node(env, (AstSymbolNode *) form, target,
                                       stream, err);
        } else {
            return compile_quoted_symbol_node(env, (AstSymbolNode *) form,
                                              target, stream, err);
        }
    case AST_TYPE_QUOTE:
        if (env->quote == AST_QUOTE_NONE) {
            return compile_quote_node(env, (AstQuoteNode *) form, target, stream, err);
        } else {
            return compile_quoted_quote_node(env, (AstQuoteNode *) form, target,
                                             stream, err);
        }
    case AST_TYPE_VECTOR:
        return compile_vector_node(env, (AstVectorNode *)form, target,
                                   stream, err);
    case AST_TYPE_LIST:
        if (env->quote == AST_QUOTE_NONE) {
            return compile_quoted_list_node(env, (AstListNode *) form, target,
                                            stream, err);
        } else {
            // probably an error, don't do anything though
            return 0;
        }
    }
}

static ssize_t compile_generic_function_call(CompileEnvironment *env,
                                             AstListNode *form, FILE *stream,
                                             CompileError **err) {
    size_t emitted_count = 0;
    AstSymbolNode *name = (AstSymbolNode *) form->children[0];
    FunctionEntry *entry = lookup_function(env, name);
    if (!entry) {
        push_error_at_ast(err, (AstNode *) form, COMPILE_ERROR,
                          "unknown function");
    } else if (!function_arguments_ok(form, entry, err)) {
        // arguments invalid, give up compiling form
        return -1;
    }
    // first, thigs that clobber the "arg" registers
    for (size_t i = 1; i < form->nchildren; ++i) {
        switch (form->children[i]->type) {
        case AST_TYPE_QUOTE:
        case AST_TYPE_VECTOR:
        case AST_TYPE_LIST: {
            bool success = true;
            LispReg reg = {
                .type = REG_ARG,
                .which = i - 1,
            };
            ssize_t ec = byte_compile_form_internal(env, form->children[i],
                                                    &reg, stream, err);
            if (!success) {
                return -1;
            }
        }
            break;
        default:
            break;
        }
    }
    // TODO make sure that rest and key arguments go at the end
    // then all the other types of arguments
    for (size_t i = 1; i < form->nchildren; ++i) {
        switch (form->children[i]->type) {
        case AST_TYPE_SYMBOL:
        case AST_TYPE_INT:
        case AST_TYPE_FLOAT:
        case AST_TYPE_STRING:
        case AST_TYPE_NULL: {
            bool success = true;
            LispReg reg = {
                .type = REG_ARG,
                .which = i - 1,
            };
            ssize_t ec = byte_compile_form_internal(env, form->children[i],
                                                    &reg, stream, err);
            if (!success) {
                return -1;
            }
        }
            break;
        case AST_TYPE_QUOTE:
        case AST_TYPE_VECTOR:
        case AST_TYPE_LIST:
            break;
        }
        if (form->children[i]->type != AST_TYPE_LIST) {
        }
    }
    LispReg name_reg;
    ssize_t ec = intern_and_save(env, stream, name->name, name->name_length,
                                 &name_reg, err);
    if (ec == -1) {
        return -1;
    }
    emit_instruction(err, stream, INST_FUNCALL, 2,
                     ARG_REG, name_reg.type, name_reg.which,
                     ARG_U64, form->nchildren - 1);
    return 0;
}

static ssize_t byte_compile_form_internal(CompileEnvironment *env,
                                          AstNode *form, LispReg *target,
                                          FILE *stream, CompileError **err) {
    if (form->type != AST_TYPE_LIST) {
        if (!target) {
            // no use in compiling a literal if the value will just be thrown out
            return 0;
        }
        return compile_atom_node(env, form, target, stream, err);
    } else if (env->quote != AST_QUOTE_NONE) {
        return compile_quoted_list_node(env, (AstListNode *) form, target,
                                        stream, err);
    } else if (is_function_call(form)) {
        for (size_t i = 0; i < N_NATIVE_FUNCTIONS; ++i) {
            if (is_function_call_named(NATIVE_FUNCTIONS[i].name, form)) {
                return NATIVE_FUNCTIONS[i].handler(env, (AstListNode *) form,
                                                   target, stream, err);
            }
        }
        return compile_generic_function_call(env, (AstListNode *) form, stream, err);
    }
    return 0;
}

ssize_t byte_compile_form(CompileEnvironment *env, AstNode *form, FILE *stream,
                          CompileError **err) {
    env->first_available_var = 0;
    env->quote = AST_QUOTE_NONE;
    size_t ninst = byte_compile_form_internal(env, form, NULL, stream, err);
    // reverse err
    if (err) {
        CompileError *cur_err = *err;
        CompileError *prev_err = NULL;
        while (cur_err) {
            CompileError *next = cur_err->next;
            cur_err->next = prev_err;
            prev_err = cur_err;
            cur_err = next;
        }
        *err = prev_err;
    }
    return ninst;
}