Fix gc bug and add condition classes

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))

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, ",@");

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);

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: {

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);

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));
 

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);
+    LispVal *r;
-    Feval(l, Qnil);
+    while ((r = read(&s))) {
-    lisp_gc_yield(NULL, true);
+        Feval(r, Qnil);
+    }
     pop_stack_frame();
     lisp_shutdown();
     free(src);

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]));