glisp/src/lisp.c

#include "lisp.h"

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

#include <locale.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)->flags = SYMBOL_CONST_VALUE | SYMBOL_CONST_FUNCTION;
    ((LispSymbol *) Qnil)->value.normal = Qnil;
    ((LispSymbol *) Qnil)->function = Qnil;
    ((LispSymbol *) Qnil)->plist = Qnil;
    lisp_gc_register_static_object(Qnil);
    Qt = Fmake_symbol(LISP_LITSTR("t"));
    ((LispSymbol *) Qt)->flags = SYMBOL_CONST_VALUE | SYMBOL_CONST_FUNCTION;
    ((LispSymbol *) Qt)->value.normal = Qt;
    lisp_gc_register_static_object(Qt);
    Qunbound = Fmake_symbol(LISP_LITSTR("unbound"));
    ((LispSymbol *) Qunbound)->value.normal = Qunbound;
    lisp_gc_register_static_object(Qunbound);
    Qlexical_environment = Fmake_symbol(LISP_LITSTR("lexical-environment"));
    ((LispSymbol *) Qlexical_environment)->value_type = SYMBOL_NATIVE;
    ((LispSymbol *) Qlexical_environment)->value.native = &Vlexical_environment;
    lisp_gc_register_static_object(Qlexical_environment);

    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();
    Vlexical_environment = Qnil;
    obarray = Fmake_hash_table(Qhash_string, Qstrings_equal);
    lisp_gc_register_static_object(obarray);

    // 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();
    lisp_gc_on_alloc = true;
}

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

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

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, Vlexical_environment);
    }
    return rval;
}

DEFSPECIAL(setq, "setq", (LispVal * bindings), "(&rest bindings)", "") {
    size_t nbindings = list_length(bindings);
    if (nbindings < 2 || (nbindings & 1) != 0) {
        // TODO error
        abort();
    }
    LispVal *value = Qnil;
    for (LispVal *rest = bindings; !NILP(bindings);
         bindings = XCDR(XCDR(bindings))) {
        LispVal *name = FIRST(rest);
        value = Feval(SECOND(rest), Vlexical_environment);
        set_lexical_variable(name, value);
    }
    return value;
}

DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body),
           "(bindings &rest body)", "") {
    CHECK_LISTP(bindings);
    StackFrame *stack_ref = LISP_STACK_REF();
    DOLIST(binding, bindings) {
        if (CONSP(binding) && list_length_eq(binding, 2)) {
            if (!SYMBOLP(XCAR(binding))) {
                // TODO better error
                abort();
            }
            RPLACA(XCDR(binding), Feval(SECOND(binding), Vlexical_environment));
        } else if (!SYMBOLP(binding)) {
            // TODO better error
            abort();
        }
    }
    push_copy_lexenv();
    DOLIST(binding, bindings) {
        // we already checked that all bindings are well formed
        if (SYMBOLP(binding)) {
            new_lexical_variable(binding, Qnil);
        } else {
            new_lexical_variable(FIRST(binding), SECOND(binding));
        }
    }
    return UNWIND_AND_RETURN(stack_ref, Fprogn(body));
}

DEFSPECIAL(if, "if", (LispVal * cond, LispVal *then, LispVal *otherwise),
           "(cond then &rest else)", "") {
    StackFrame *stack_ref = LISP_STACK_REF();
    LispVal *res = Feval(cond, Vlexical_environment);
    if (!NILP(res)) {
        return UNWIND_AND_RETURN(stack_ref, Feval(then, Vlexical_environment));
    } else {
        return UNWIND_AND_RETURN(stack_ref, Fprogn(otherwise));
    }
}

DEFSPECIAL(and, "and", (LispVal * forms), "(&rest forms)", "") {
    LispVal *res = Qt;
    DOLIST(form, forms) {
        res = Feval(form, Vlexical_environment);
        if (NILP(res)) {
            return Qnil;
        }
    }
    return res;
}

DEFSPECIAL(or, "or", (LispVal * forms), "(&rest forms)", "") {
    DOLIST(form, forms) {
        LispVal *res = Feval(form, Vlexical_environment);
        if (!NILP(res)) {
            return res;
        }
    }
    return Qnil;
}

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