Exceptions!!!

src/base.c

@@ -52,23 +52,15 @@ void lisp_release_object(LispVal *val) {
 
 void internal_CHECK_TYPE_signal_type_error(LispVal *obj, size_t count,
                                            const LispValType types[count]) {
-    // TODO actually throw an error
-    fprintf(stderr, "Type error! Got: %s | Expected: (or ",
-            LISP_TYPE_NAMES[TYPE_OF(obj)]);
+    LispVal *syms = Qnil;
     for (size_t i = 0; i < count; ++i) {
-        fprintf(stderr, "%s%s", LISP_TYPE_NAMES[types[i]],
-                i < count - 1 ? " " : ")\n");
+        syms = CONS(symbol_for_type(types[i]), syms);
     }
-    abort();
+    signal_type_error(obj, Fnreverse(syms));
 }
 
 noreturn void signal_type_error(LispVal *obj, LispVal *typespec) {
-    // TODO actually throw an error
-    fprintf(stderr,
-            "Type error! Got: %s | Expected: ", LISP_TYPE_NAMES[TYPE_OF(obj)]);
-    debug_print(stderr, typespec);
-    fputc('\n', stderr);
-    abort();
+    lisp_signal(Qtype_error, LIST(obj, typespec));
 }
 
 DEFINE_SYMBOL(nil, "nil");
@@ -97,9 +89,15 @@ LispVal *make_vector(LispVal **data, size_t length, bool take) {
     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);
-        memcpy(obj->data, data, sizeof(LispVal *) * length);
+        for (size_t i = 0; i < length; ++i) {
+            MARK_OBJECT_ADDED(data[i], obj);
+            obj->data[i] = data[i];
+        }
     }
     return obj;
 }
@@ -166,13 +164,16 @@ DEFUN(fset, "fset", (LispVal * sym, LispVal *value), "(sym value)", "") {
         abort();
     }
     ((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);
-    return ((LispSymbol *) sym)->plist = plist;
+    ((LispSymbol *) sym)->plist = plist;
+    MARK_OBJECT_ADDED(plist, sym);
+    return plist;
 }
 
 DEFUN(get, "get", (LispVal * sym, LispVal *key, LispVal *def),
@@ -185,6 +186,38 @@ DEFUN(put, "put", (LispVal * sym, LispVal *key, LispVal *val), "(sym key val)",
     return Fsetplist(sym, Fplist_put(Fsymbol_plist(sym), key, val));
 }
 
+DEFINE_SYMBOL(fixnum, "fixnum");
+DEFINE_SYMBOL(float, "float");
+// cons defined in list.c
+DEFINE_SYMBOL(string, "strin");
+DEFINE_SYMBOL(symbol, "symbol");
+DEFINE_SYMBOL(vector, "vector");
+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)", "") {
@@ -209,6 +242,89 @@ DEFUN(condition_subclass_p, "condition-subclass-p",
     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_condition_case_handlers(LispVal *handlers) {
+    DOTAILS(rest, handlers) {
+        LispVal *handler = XCAR(rest);
+        if (ATOM(handler)) {
+            // TODO type error
+            abort();
+        } else if (LISTP(XCAR(handler))) {
+            // make sure each condition is a symbol
+            DOTAILS(rest, XCAR(handler)) {
+                if (!SYMBOLP(XCAR(rest))) {
+                    // TODO error
+                    abort();
+                }
+            }
+        } else if (!SYMBOLP(XCAR(handler))) {
+            // if the condition is not a list or symbol, it's an error
+            // TODO type error
+            abort();
+        }
+    }
+}
+
+DEFUN(condition_case, "condition-case",
+      (LispVal * var, LispVal *form, LispVal *handlers),
+      "(var form &rest handlers)", "") {
+    CHECK_TYPE(var, TYPE_SYMBOL);
+    check_condition_case_handlers(handlers);
+    StackFrame *stack_ref = LISP_STACK_REF();
+    jmp_buf jmp_target;
+    LispVal *success_handler = Qnil;
+    size_t idx = 0;
+    DOLIST(handler, handlers) {
+        if (EQ(XCAR(handler), Qkw_success)) {
+            success_handler = XCDR(handler);
+        } else {
+            push_condition_case_frame(&jmp_target, XCAR(handler), idx);
+        }
+        ++idx;
+    }
+    if (setjmp(jmp_target) == 0) {
+        LispVal *res = Feval(form, Vlexical_environment);
+        unwind_to(stack_ref);
+        if (NILP(success_handler)) {
+            return res;
+        } else {
+            return Fprogn(success_handler);
+        }
+    } else {
+        unwind_to(stack_ref);
+        if (!NILP(var)) {
+            push_copy_lexenv();
+            new_lexical_variable(var, CONS(EXCEPTION_NAME(), EXCEPTION_DATA()));
+        }
+        UNWIND_AND_RETURN(
+            stack_ref, Fprogn(XCDR(nth(EXCEPTION_HANDLER_DATUM(), handlers))));
+    }
+    return Qnil;
+}
+
+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(backquote, "`");
 DEFINE_SYMBOL(comma, ",");
 DEFINE_SYMBOL(comma_at, ",@");