glisp/src/lisp.c

#include "lisp.h"

#include "hashtable.h"
#include "init_globals.h"
#include "lisp_string.h"

LispVal *obarray;

static void construct_manual_symbols(void) {
    // IMPORTANT: the symbols listed here need to also be set as special in
    // gen-init-globals.awk
    Qnil = Fmake_symbol(LISP_LITSTR("nil"));
    ((LispSymbol *) Qnil)->value = Qnil;
    ((LispSymbol *) Qnil)->function = Qnil;
    ((LispSymbol *) Qnil)->plist = Qnil;
    lisp_gc_register_static_object(Qnil);
    Qt = Fmake_symbol(LISP_LITSTR("t"));
    ((LispSymbol *) Qt)->value = Qt;
    lisp_gc_register_static_object(Qt);
    Qunbound = Fmake_symbol(LISP_LITSTR("unbound"));
    ((LispSymbol *) Qunbound)->value = Qunbound;
    ((LispSymbol *) Qunbound)->value = Qunbound;
    lisp_gc_register_static_object(Qunbound);

    Qhash_string = Fmake_symbol(LISP_LITSTR("hash-string"));
    lisp_gc_register_static_object(Qhash_string);
    Qstrings_equal = Fmake_symbol(LISP_LITSTR("strings-equal"));
    lisp_gc_register_static_object(Qstrings_equal);
}

static void register_manual_symbols(void) {
#define INTERN(cname) \
    Fputhash(obarray, ((LispSymbol *) Q##cname)->name, Q##cname);
    INTERN(nil);
    INTERN(t);
    INTERN(unbound);
    INTERN(hash_string);
    INTERN(strings_equal);
#undef INTERN
}

void lisp_init(void) {
    construct_manual_symbols();
    obarray = Fmake_hash_table(Qhash_string, Qstrings_equal);

    // Needed to register functions
    REGISTER_GLOBAL_SYMBOL(and_allow_other_keys);
    REGISTER_GLOBAL_SYMBOL(and_optional);
    REGISTER_GLOBAL_SYMBOL(and_key);
    REGISTER_GLOBAL_SYMBOL(and_rest);

    // these call Fintern, so they need to have obarray constructed
    ((LispSymbol *) Qhash_string)->function = BUILTIN_FUNCTION_OBJ(hash_string);
    ((LispSymbol *) Qstrings_equal)->function =
        BUILTIN_FUNCTION_OBJ(hash_string);

    register_manual_symbols();
    register_globals();

    lisp_init_stack();
}

void lisp_shutdown(void) {
    lisp_gc_teardown();
    lisp_teardown_stack();
}

static inline LispVal *lookup_variable(LispSymbol *name, LispVal *lexenv) {
    LispVal *lexval = Fplist_get(lexenv, name, Qunbound);
    if (lexval != Qunbound) {
        return lexval;
    }
    if (name->value == Qunbound) {
        // TODO better error
        printf("Unbound symbol: ");
        debug_print(stdout, name);
        fputc('\n', stdout);
        abort();
    }
    return name->value;
}

DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv),
      "(form &optional lexenv)", "") {
    if (!OBJECTP(form)) {
        // fixnum or float
        return form;
    }
    switch (((LispObject *) form)->type) {
    case TYPE_HASH_TABLE:
    case TYPE_FUNCTION:
    case TYPE_STRING:
        return form;
    case TYPE_VECTOR: {
        LispVector *vec = form;
        LispVal **out_data = lisp_malloc(sizeof(LispVal *) * vec->length);
        LispVector *newvec = make_vector(out_data, vec->length, true);
        for (size_t i = 0; i < vec->length; ++i) {
            out_data[i] = Qnil;
        }
        for (size_t i = 0; i < vec->length; ++i) {
            out_data[i] = Feval(vec->data[i], lexenv);
        }
        return newvec;
    }
    case TYPE_SYMBOL:
        return lookup_variable(form, lexenv);
    case TYPE_CONS: {
        return Ffuncall(XCAR(form), XCDR(form));
    }
    case TYPE_FIXNUM:
    case TYPE_FLOAT:
    default:
        abort();
    }
}

DEFSPECIAL(progn, "progn", (LispVal * forms), "(&rest forms)", "") {
    LispVal *rval = Qnil;
    DOLIST(form, forms) {
        rval = Feval(form, TOP_LEXENV());
    }
    return rval;
}

DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body),
           "(bindings &rest body)", "") {
    CHECK_LISTP(bindings);
    copy_parent_lexenv();
    DOLIST(binding, bindings) {
        if (SYMBOLP(binding)) {
            new_lexical_variable(binding, Qnil);
        } else if (CONSP(binding) && list_length_eq(binding, 2)) {
            new_lexical_variable(FIRST(binding),
                                 Feval(SECOND(binding), TOP_LEXENV()));
        } else {
            // TODO better error
            abort();
        }
    }
    return Fprogn(body);
}

void debug_print(FILE *file, LispVal *obj) {
    switch (TYPE_OF(obj)) {
    case TYPE_FIXNUM:
        fprintf(file, "%jd", (intmax_t) XFIXNUM(obj));
        break;
    case TYPE_FLOAT:
        fprintf(file, "%f", (double) XLISP_FLOAT(obj));
        break;
    case TYPE_STRING: {
        LispString *s = obj;
        fputc('"', file);
        fwrite(s->data, 1, s->length, file);
        fputc('"', file);
        break;
    }
    case TYPE_SYMBOL: {
        LispString *name = ((LispSymbol *) obj)->name;
        fwrite(name->data, 1, name->length, file);
        break;
    }
    case TYPE_HASH_TABLE: {
        fprintf(file, "<hash-table count=%zu at 0x%jx>",
                ((LispHashTable *) obj)->count, (uintmax_t) obj);
        break;
    }
    case TYPE_FUNCTION: {
        LispFunction *fobj = obj;
        if (NILP(fobj->name)) {
            fprintf(file, "<lambda at 0x%jx>", (uintmax_t) obj);
        } else {
            fprintf(file, "<function ");
            debug_print(file, fobj->name);
            fprintf(file, " at 0x%jx>", (uintmax_t) obj);
        }
        break;
    }
    case TYPE_CONS: {
        fputc('(', file);
        DOTAILS(tail, obj) {
            if (CONSP(tail)) {
                debug_print(file, XCAR(tail));
                if (!NILP(XCDR(tail))) {
                    fputc(' ', file);
                }
            } else {
                fwrite(". ", 1, 2, file);
                debug_print(file, tail);
            }
        }
        fputc(')', file);
        break;
    }
    case TYPE_VECTOR: {
        LispVector *v = obj;
        fputc('[', file);
        for (size_t i = 0; i < v->length; ++i) {
            debug_print(file, v->data[i]);
            if (i < v->length - 1) {
                fputc(' ', file);
            }
        }
        fputc(']', file);
        break;
    }
    default:
        abort();
    }
}

void debug_obj_info(FILE *file, LispVal *obj) {
    fprintf(file, "%s -> ", LISP_TYPE_NAMES[TYPE_OF(obj)]);
    debug_print(file, obj);
    fputc('\n', file);
}