glisp/src/base.c

#include "base.h"

#include "gc.h"
#include "hashtable.h"
#include "lisp.h"
#include "list.h"
#include "stack.h"

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

const char *LISP_TYPE_NAMES[N_LISP_TYPES] = {
    [TYPE_FIXNUM] = "fixnum",
    [TYPE_FLOAT] = "float",
    [TYPE_CONS] = "cons",
    [TYPE_STRING] = "string",
    [TYPE_SYMBOL] = "symbol",
    [TYPE_VECTOR] = "vector",
    [TYPE_HASH_TABLE] = "hash-table",
    [TYPE_FUNCTION] = "function",
};

bool lisp_gc_on_alloc;

void *lisp_alloc_object_no_gc(size_t size, LispValType type) {
    assert(size >= sizeof(LispObject));
    LispObject *obj = lisp_aligned_alloc(LISP_OBJECT_ALIGNMENT, size);
    memset(obj, 0, size);
    obj->type = type;
    obj->gc.lowest_local_ref = NULL;
    return obj;
}

void *lisp_alloc_object(size_t size, LispValType type) {
    LispObject *obj = lisp_alloc_object_no_gc(size, type);
    if (lisp_gc_on_alloc && the_stack.depth) {
        lisp_gc_yield(NULL, false);
    }
    if (the_stack.depth > 0) {
        add_local_reference_no_recurse(LISP_STACK_REF(), obj);
    }
    lisp_gc_register_object(obj);
    return obj;
}

void lisp_release_object(LispVal *val) {
    assert(OBJECTP(val));
    lisp_free(val);
}

void internal_CHECK_TYPE_signal_type_error(LispVal *obj, size_t count,
                                           const LispValType types[count]) {
    LispVal *syms = Qnil;
    for (size_t i = 0; i < count; ++i) {
        syms = CONS(symbol_for_type(types[i]), syms);
    }
    signal_type_error(obj, Fnreverse(syms));
}

noreturn void signal_type_error(LispVal *obj, LispVal *typespec) {
    lisp_signal(Qtype_error, LIST(obj, typespec));
}

DEFINE_SYMBOL(nil, "nil");
DEFINE_SYMBOL(t, "t");
DEFINE_SYMBOL(unbound, "unbound");
DEFVAR(lexical_environment, "lexical-environment", "", Qnil);

DEFUN(id, "id", (LispVal * obj), "(id)", "") {
    // TODO not all values are handled here
    return MAKE_FIXNUM((uintptr_t) obj);
}

DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)", "") {
    return EQ(obj1, obj2) ? Qt : Qnil;
}

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

// ################
// # Constructors #
// ################
LispVal *make_vector(LispVal **data, size_t length, bool take) {
    LispVector *obj = lisp_alloc_object(sizeof(LispVector), TYPE_VECTOR);
    obj->length = length;
    if (take) {
        obj->data = data;
        for (size_t i = 0; i < length; ++i) {
            MARK_OBJECT_ADDED(data[i], obj);
        }
    } else {
        obj->data = lisp_malloc(sizeof(LispVal *) * length);
        for (size_t i = 0; i < length; ++i) {
            MARK_OBJECT_ADDED(data[i], obj);
            obj->data[i] = data[i];
        }
    }
    return obj;
}

DEFUN(vector, "vector", (LispVal * data), "(&rest data)", "") {
    intptr_t length = list_length(data);
    if (length == -1) {
        lisp_signal(Qcircular_list_error, Qnil);
    }
    LispVal **vec_data = lisp_malloc(sizeof(LispVal *) * length);
    size_t i = 0;
    DOLIST(datum, data) {
        vec_data[i++] = datum;
    }
    return make_vector(vec_data, length, true);
}

DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)",
      "Return an uninterned symbol called NAME.") {
    LispSymbol *obj = lisp_alloc_object(sizeof(LispSymbol), TYPE_SYMBOL);
    obj->name = name;
    obj->function = Qnil;
    obj->plist = Qnil;
    obj->value_type = SYMBOL_NORMAL;
    if (KEYWORDP(obj)) {
        obj->value.normal = obj;
        obj->flags |= SYMBOL_CONST_VALUE;
    } else {
        obj->value.normal = Qunbound;
    }
    return obj;
}

DEFUN(intern, "intern", (LispVal * name), "(name)", "") {
    CHECK_TYPE(name, TYPE_STRING);
    LispVal *res = Fgethash(obarray, name, Qunbound);
    if (res != Qunbound) {
        return res;
    }
    LispVal *newsym = Fmake_symbol(name);
    Fputhash(obarray, name, newsym);
    return newsym;
}

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

DEFUN(symbol_function, "symbol-function", (LispVal * sym, LispVal *resolve),
      "(sym &optional resolve)", "") {
    CHECK_TYPE(sym, TYPE_SYMBOL);
    if (NILP(resolve)) {
        return ((LispSymbol *) sym)->function;
    }
    while (!NILP(sym) && SYMBOLP(sym)) {
        sym = ((LispSymbol *) sym)->function;
    }
    return sym;
}

DEFUN(symbol_plist, "symbol-plist", (LispVal * sym), "(sym)", "") {
    CHECK_TYPE(sym, TYPE_SYMBOL);
    return ((LispSymbol *) sym)->plist;
}

DEFUN(set, "set", (LispVal * sym, LispVal *value), "(sym value)", "") {
    CHECK_TYPE(sym, TYPE_SYMBOL);
    SET_SYMBOL_VALUE(sym, value);
    return value;
}

DEFUN(fset, "fset", (LispVal * sym, LispVal *value), "(sym value)", "") {
    CHECK_TYPE(sym, TYPE_SYMBOL);
    if (CONST_FUNCTION_P(sym)) {
        signal_value_constant(sym);
    }
    ((LispSymbol *) sym)->function = value;
    MARK_OBJECT_ADDED(value, sym);
    return value;
}

DEFUN(setplist, "setplist", (LispVal * sym, LispVal *plist), "(sym plist)",
      "") {
    CHECK_TYPE(sym, TYPE_SYMBOL);
    ((LispSymbol *) sym)->plist = plist;
    MARK_OBJECT_ADDED(plist, sym);
    return plist;
}

DEFUN(get, "get", (LispVal * sym, LispVal *key, LispVal *def),
      "(sym key &optional def)", "") {
    return Fplist_get(Fsymbol_plist(sym), key, def);
}

DEFUN(put, "put", (LispVal * sym, LispVal *key, LispVal *val), "(sym key val)",
      "") {
    return Fsetplist(sym, Fplist_put(Fsymbol_plist(sym), key, val));
}

noreturn void signal_value_constant(LispVal *value) {
    lisp_signal(Qvalue_constant_error, LIST(value));
}

DEFINE_SYMBOL(fixnum, "fixnum");
DEFINE_SYMBOL(float, "float");
// cons defined in list.c
DEFINE_SYMBOL(string, "strin");
DEFINE_SYMBOL(symbol, "symbol");
// vector defined above
DEFINE_SYMBOL(hash_table, "hash-table");
DEFINE_SYMBOL(function, "function");

LispVal *symbol_for_type(LispValType type) {
    switch (type) {
    case TYPE_FIXNUM:
        return Qfixnum;
    case TYPE_FLOAT:
        return Qfloat;
    case TYPE_CONS:
        return Qcons;
    case TYPE_STRING:
        return Qstring;
    case TYPE_SYMBOL:
        return Qsymbol;
    case TYPE_VECTOR:
        return Qvector;
    case TYPE_HASH_TABLE:
        return Qhash_table;
    case TYPE_FUNCTION:
        return Qfunction;
    default:
        abort();
    }
}

DEFINE_SYMBOL(condition_class, "condition-class");

DEFUN(condition_class_p, "condition-class-p", (LispVal * val), "(val)", "") {
    if (!SYMBOLP(val)) {
        return Qnil;
    }
    LispVal *class = Fget(val, Qcondition_class, Qnil);
    return !NILP(class) && SYMBOLP(class) ? class : Qnil;
}

DEFUN(condition_subclass_p, "condition-subclass-p",
      (LispVal * child, LispVal *parent), "(child parent)", "") {
    if (parent == child || (parent == Qt && SYMBOLP(child))) {
        return Qt;
    }
    LispVal *cur = child;
    while (!NILP((cur = Fcondition_class_p(cur))) && cur != Qt) {
        if (cur == parent) {
            return Qt;
        }
    }
    return Qnil;
}

DEFUN(condition_printer, "condition-printer", (LispVal * val), "(val)", "") {
    if (NILP(Fcondition_class_p(val))) {
        return Qnil;
    }
    return Fget(val, Qcondition_printer, Qnil);
}

DEFINE_SYMBOL(kw_success, ":success");

DEFUN(signal, "signal", (LispVal * name, LispVal *data), "(name data)", "") {
    lisp_signal(name, data);
    // the above is a non-local exit, if we come back here something has gone
    // very wrong
    abort();
}

static void check_handler_bind_handlers(LispVal *handlers) {
    DOLIST(handler, handlers) {
        CHECK_LISTP(handler);
        if (!list_length_eq(handler, 2)) {
            lisp_signal(Qargument_error,
                        LIST(LISP_LITSTR("Wrong number of arguments.")));
        }
        CHECK_TYPE(XCDR(handler), TYPE_FUNCTION);
        if (LISTP(XCAR(handler))) {
            // make sure each condition is a symbol
            DOTAILS(rest, XCAR(handler)) {
                CHECK_TYPE(XCAR(rest), TYPE_SYMBOL);
            }
        } else if (!SYMBOLP(XCAR(handler))) {
            // if the condition is not a list or symbol, it's an error
            signal_type_error(XCAR(handler), LIST(Qsymbol, Qlist));
        }
    }
}

static void lisp_handler_bind_handler(LispVal *name, LispVal *data,
                                      LispVal *lisp_handler) {
    CALL(lisp_handler, CONS(name, data));
}

DEFUN(handler_bind, "handler-bind", (LispVal * thunk, LispVal *handlers),
      "(thunk &rest handlers)", "") {
    check_handler_bind_handlers(handlers);
    StackFrame *stack_ref = LISP_STACK_REF();
    DOLIST(handler, handlers) {
        push_handler_bind_frame(FIRST(handler), lisp_handler_bind_handler,
                                SECOND(handler), NULL);
    }
    return UNWIND_AND_RETURN(stack_ref, CALL0(thunk));
}

DEFUN(error, "error", (LispVal * data), "(data)", "") {
    return Fsignal(Qerror, data);
}
DEFINE_CONDITION_CLASS(error, t);

DEFINE_SYMBOL(type_error, "type-error");
DEFINE_CONDITION_CLASS(type_error, error);

DEFINE_SYMBOL(value_constant_error, "value-constant-error");
DEFINE_CONDITION_CLASS(value_constant_error, error);

DEFINE_SYMBOL(backquote, "`");
DEFINE_SYMBOL(comma, ",");
DEFINE_SYMBOL(comma_at, ",@");