diff --git a/lisp/kernel.gl b/lisp/kernel.gl index 2710a60..6037887 100644 --- a/lisp/kernel.gl +++ b/lisp/kernel.gl @@ -1,3 +1,14 @@ ;; -*- mode: lisp-data -*- -(print ((lambda (a b &rest r &key c &allow-other-keys) r) 1 2 :c 3 :d 4)) +(put 'x 'condition-class t) +(put 'y 'condition-class 'x) + +(print (condition-class-p 'x)) +(print (condition-class-p 'y)) +(print (condition-class-p 'z)) +(print (condition-subclass-p 'y 'x)) +(print (condition-subclass-p 'y t)) +(print (condition-subclass-p 'x t)) +(print (condition-subclass-p t t)) +(print (condition-subclass-p 'z 'x)) +(print (condition-subclass-p 'x 'y)) diff --git a/src/base.c b/src/base.c index 4481a2a..ab2aa69 100644 --- a/src/base.c +++ b/src/base.c @@ -140,6 +140,51 @@ DEFUN(symbol_function, "symbol-function", (LispVal * sym, LispVal *resolve), return sym; } +DEFUN(symbol_plist, "symbol-plist", (LispVal * sym), "(sym)", "") { + CHECK_TYPE(sym, TYPE_SYMBOL); + return ((LispSymbol *) sym)->plist; +} + +DEFUN(setplist, "setplist", (LispVal * sym, LispVal *plist), "(sym plist)", + "") { + CHECK_TYPE(sym, TYPE_SYMBOL); + return ((LispSymbol *) sym)->plist = 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)); +} + +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; +} + DEFINE_SYMBOL(backquote, "`"); DEFINE_SYMBOL(comma, ","); DEFINE_SYMBOL(comma_at, ",@"); diff --git a/src/base.h b/src/base.h index 605cd89..19f2e10 100644 --- a/src/base.h +++ b/src/base.h @@ -297,6 +297,15 @@ LispVal *make_vector(LispVal **data, size_t length, bool take); DECLARE_FUNCTION(make_symbol, (LispVal * name)); DECLARE_FUNCTION(intern, (LispVal * name)); DECLARE_FUNCTION(symbol_function, (LispVal * sym, LispVal *resolve)); +DECLARE_FUNCTION(symbol_plist, (LispVal * sym)); +DECLARE_FUNCTION(setplist, (LispVal * sym, LispVal *plist)); +DECLARE_FUNCTION(get, (LispVal * sym, LispVal *key, LispVal *def)); +DECLARE_FUNCTION(put, (LispVal * sym, LispVal *key, LispVal *val)); + +// condition stuff +DECLARE_SYMBOL(condition_class); +DECLARE_FUNCTION(condition_class_p, (LispVal * val)); +DECLARE_FUNCTION(condition_subclass_p, (LispVal * child, LispVal *parent)); // Defined in lisp code (eventually) but used in read.c DECLARE_SYMBOL(backquote); diff --git a/src/gc.c b/src/gc.c index 7ada346..190c663 100644 --- a/src/gc.c +++ b/src/gc.c @@ -151,6 +151,7 @@ void gc_mark_stack_for_rescan(void) { } static void free_object(LispVal *val) { + assert(OBJECT_GC_SET_P(val, GC_WHITE)); assert(!OBJECT_HAS_LOCAL_REFERENCE_P(val)); switch (((LispObject *) val)->type) { case TYPE_HASH_TABLE: { diff --git a/src/list.c b/src/list.c index 4fb48a6..0c3ce43 100644 --- a/src/list.c +++ b/src/list.c @@ -1,5 +1,7 @@ #include "list.h" +#include "function.h" + intptr_t list_length(LispVal *list) { assert(LISTP(list)); LispVal *tortise = list; @@ -61,6 +63,25 @@ DEFUN(list, "list", (LispVal * args), "(&rest args)", "") { return args; } +DEFUN(member, "member", (LispVal * elt, LispVal *list, LispVal *pred), + "(elt list &optional pred)", "") { + if (NILP(pred) || pred == Qeq) { + // fast case + DOTAILS(rest, list) { + if (elt == XCAR(rest)) { + return rest; + } + } + } else { + DOTAILS(rest, list) { + if (CALL(pred, elt, XCAR(rest))) { + return rest; + } + } + } + return Qnil; +} + DEFUN(plist_put, "plist-put", (LispVal * plist, LispVal *prop, LispVal *value), "(plist prop value)", "") { CHECK_LISTP(plist); diff --git a/src/list.h b/src/list.h index dc2dfdd..e097fb8 100644 --- a/src/list.h +++ b/src/list.h @@ -122,6 +122,9 @@ static ALWAYS_INLINE void CHECK_LISTP(LispVal *obj) { } } +// List utility functions +DECLARE_FUNCTION(member, (LispVal * elt, LispVal *list, LispVal *pred)); + DECLARE_FUNCTION(plist_put, (LispVal * plist, LispVal *prop, LispVal *value)); DECLARE_FUNCTION(plist_get, (LispVal * plist, LispVal *prop, LispVal *def)); diff --git a/src/main.c b/src/main.c index 85cfd8a..2cb9108 100644 --- a/src/main.c +++ b/src/main.c @@ -21,9 +21,10 @@ int main(int argc, const char **argv) { push_stack_frame(Qnil, Qnil, Qnil); ReadStream s; read_stream_init(&s, src, src_len); - LispVal *l = read(&s); - Feval(l, Qnil); - lisp_gc_yield(NULL, true); + LispVal *r; + while ((r = read(&s))) { + Feval(r, Qnil); + } pop_stack_frame(); lisp_shutdown(); free(src); diff --git a/src/stack.c b/src/stack.c index f0948fc..5a4f221 100644 --- a/src/stack.c +++ b/src/stack.c @@ -55,7 +55,7 @@ void push_stack_frame(LispVal *name, LispVal *fobj, LispVal *args) { static void reset_local_refs(struct LocalReferences *refs) { size_t last_block_size = refs->num_refs % LOCAL_REFERENCES_BLOCK_LENGTH; - size_t num_full_blocks = refs->num_blocks / LOCAL_REFERENCES_BLOCK_LENGTH; + size_t num_full_blocks = refs->num_refs / LOCAL_REFERENCES_BLOCK_LENGTH; for (size_t i = 0; i < num_full_blocks; ++i) { for (size_t j = 0; j < LOCAL_REFERENCES_BLOCK_LENGTH; ++j) { assert(OBJECTP(refs->blocks[i]->refs[j]));