Exceptions!!!

lisp/kernel.gl

@@ -1,7 +1,3 @@
 ;; -*- mode: lisp-data -*-
 
-(let ((print-quoted nil))
+(error '("Hi"))
-  (prin1 '(quote a))
-  (write-byte ?\n))
-(prin1 '(quote a))
-(write-byte ?\n)

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
+    LispVal *syms = Qnil;
-    fprintf(stderr, "Type error! Got: %s | Expected: (or ",
-            LISP_TYPE_NAMES[TYPE_OF(obj)]);
     for (size_t i = 0; i < count; ++i) {
-        fprintf(stderr, "%s%s", LISP_TYPE_NAMES[types[i]],
+        syms = CONS(symbol_for_type(types[i]), syms);
-                i < count - 1 ? " " : ")\n");
     }
-    abort();
+    signal_type_error(obj, Fnreverse(syms));
 }
 
 noreturn void signal_type_error(LispVal *obj, LispVal *typespec) {
-    // TODO actually throw an error
+    lisp_signal(Qtype_error, LIST(obj, typespec));
-    fprintf(stderr,
-            "Type error! Got: %s | Expected: ", LISP_TYPE_NAMES[TYPE_OF(obj)]);
-    debug_print(stderr, typespec);
-    fputc('\n', stderr);
-    abort();
 }
 
 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, ",@");

src/base.h

@@ -256,6 +256,8 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
     extern const char *internal_F##cname##_docstr;      \
     extern const size_t internal_F##cname##_docstr_len; \
     LispVal *F##cname cargs
+#define MAKE_CONDITION_CLASS(cname) \
+    extern LispVal **internal_Q##cname##_parent_condition_class
 
 #define DEFINE_SYMBOL(cname, lisp_name)                                \
     const char *internal_Q##cname##_name = lisp_name;                  \
@@ -279,6 +281,8 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
     LispVal *F##cname cargs
 #define DEFSPECIAL(cname, lisp_name, cargs, lisp_args, doc) \
     DEFUN(cname, lisp_name, cargs, lisp_args, doc)
+#define DEFINE_CONDITION_CLASS(cname, parent_cname) \
+    LispVal **internal_Q##cname##_parent_condition_class = &Q##parent_cname
 
 #define REGISTER_GLOBAL_SYMBOL(cname)                                     \
     {                                                                     \
@@ -309,6 +313,11 @@ DEFOBJTYPE(Vector, VECTOR, VECTORP, {
         ((LispFunction *) ((LispSymbol *) Q##cname)->function)             \
             ->impl.native.no_eval_args = true;                             \
     }
+#define REGISTER_GLOBAL_CONDITION_CLASS(cname)             \
+    {                                                      \
+        Fput(Q##cname, Qcondition_class,                   \
+             *internal_Q##cname##_parent_condition_class); \
+    }
 
 DECLARE_SYMBOL(nil);
 DECLARE_SYMBOL(t);
@@ -384,12 +393,37 @@ static ALWAYS_INLINE void SET_SYMBOL_VALUE(LispVal *sym, LispVal *value) {
         *s->value.native = value;
         break;
     }
+    MARK_OBJECT_ADDED(value, sym);
 }
 
+// needed for conditions
+DECLARE_SYMBOL(fixnum);
+DECLARE_SYMBOL(float);
+// cons declared in list.h
+DECLARE_SYMBOL(string);
+DECLARE_SYMBOL(symbol);
+DECLARE_SYMBOL(vector);
+DECLARE_SYMBOL(hash_table);
+DECLARE_SYMBOL(function);
+
+LispVal *symbol_for_type(LispValType type);
+
 // condition stuff
 DECLARE_SYMBOL(condition_class);
 DECLARE_FUNCTION(condition_class_p, (LispVal * val));
 DECLARE_FUNCTION(condition_subclass_p, (LispVal * child, LispVal *parent));
+DECLARE_FUNCTION(condition_printer, (LispVal * val));
+
+DECLARE_SYMBOL(kw_success);
+
+DECLARE_FUNCTION(signal, (LispVal * name, LispVal *data));
+DECLARE_FUNCTION(condition_case,
+                 (LispVal * var, LispVal *form, LispVal *handlers));
+DECLARE_FUNCTION(error, (LispVal * data));
+MAKE_CONDITION_CLASS(error);
+
+DECLARE_SYMBOL(type_error);
+MAKE_CONDITION_CLASS(type_error);
 
 // Defined in lisp code (eventually) but used in read.c
 DECLARE_SYMBOL(backquote);

src/gc.c

@@ -33,6 +33,7 @@ ObjectGCSet GC_WHITE = 2;
 
 enum IncrementalGCSetp {
     GC_STEP_STATICS,
+    GC_STEP_UNWIND,
     GC_STEP_STACK,
     GC_STEP_HEAP,
     GC_STEP_FREE,
@@ -264,7 +265,7 @@ static void mark_statics(size_t *restrict limit) {
     // we processed the whole list, move to the next step
     if (!node) {
         incremental_state.next_static = static_objects;
-        incremental_state.step = GC_STEP_STACK;
+        incremental_state.step = GC_STEP_UNWIND;
     }
 }
 
@@ -311,6 +312,26 @@ static void mark_stack_frame(StackFrame *frame, size_t *restrict limit) {
     }
 }
 
+static void mark_unwind_info(size_t *restrict limit) {
+    if (the_stack.unwind_info.set) {
+        switch (the_stack.unwind_info.cause) {
+        case UNWIND_NORMAL:
+            mark_object(the_stack.unwind_info.target);
+            saturating_dec(limit, 1);
+            break;
+        case UNWIND_EXCEPTION:
+            mark_object(the_stack.unwind_info.exception.name);
+            mark_object(the_stack.unwind_info.exception.data);
+            saturating_dec(limit, 2);
+            break;
+        default:
+            abort();
+            break;
+        }
+    }
+    incremental_state.step = GC_STEP_STACK;
+}
+
 static void mark_the_stack(size_t *restrict limit) {
     size_t i;
     for (i = 0; i < the_stack.depth && *limit; ++i) {
@@ -385,6 +406,9 @@ void lisp_gc_yield(struct timespec *restrict time_took, bool full) {
         case GC_STEP_STATICS:
             mark_statics(&limit);
             break;
+        case GC_STEP_UNWIND:
+            mark_unwind_info(&limit);
+            break;
         case GC_STEP_STACK:
             mark_the_stack(&limit);
             break;

src/gen-init-globals.awk

@@ -96,6 +96,11 @@ function maybe_emit_next_symbol(entity) {
     maybe_emit_next_symbol("VARIABLE")
 }
 
+/DEFINE_CONDITION_CLASS\(/ {
+    maybe_print_file_header()
+    maybe_emit_next_symbol("CONDITION_CLASS")
+}
+
 END {
     print "}"
 }

src/lisp.c

@@ -4,8 +4,6 @@
 #include "init_globals.h"
 #include "lisp_string.h"
 
-#include <locale.h>
-
 LispVal *obarray;
 
 static void construct_manual_symbols(void) {
@@ -115,9 +113,8 @@ DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv),
     }
     case TYPE_SYMBOL:
         return lookup_variable(form, lexenv);
-    case TYPE_CONS: {
+    case TYPE_CONS:
         return Ffuncall(XCAR(form), XCDR(form));
-    }
     case TYPE_FIXNUM:
     case TYPE_FLOAT:
     default:

src/list.c

@@ -1,6 +1,10 @@
 #include "list.h"
 
 #include "function.h"
+#include "stack.h"
+
+DEFINE_SYMBOL(circular_list_error, "circular-list-error");
+DEFINE_CONDITION_CLASS(circular_list_error, error);
 
 intptr_t list_length(LispVal *list) {
     assert(LISTP(list));
@@ -32,21 +36,24 @@ DEFUN(cons, "cons", (LispVal * car, LispVal *cdr), "(car cdr)",
 }
 
 DEFUN(length, "length", (LispVal * list), "(list)", "") {
-    // TODO type check
+    CHECK_LISTP(list);
-    // TODO list may be circular
+    intptr_t len = list_length(list);
-    return MAKE_FIXNUM(list_length(list));
+    if (len == -1) {
+        lisp_signal(Qcircular_list_error, Qnil);
+    }
+    return MAKE_FIXNUM(len);
 }
 
 DEFUN(length_eq, "length=", (LispVal * list, LispVal *length), "(list length)",
       "Return non-nil if LIST's length is LENGTH.") {
-    // TODO type check
+    CHECK_LISTP(list);
     return list_length_eq(list, XFIXNUM(length)) ? Qt : Qnil;
 }
 
 DEFUN(nreverse, "nreverse", (LispVal * list), "(list)", "") {
-    // TODO type checking
     LispVal *rev = Qnil;
     while (!NILP(list)) {
+        CHECK_LISTP(list);
         LispVal *next = XCDR(list);
         RPLACD(list, rev);
         rev = list;
@@ -63,6 +70,22 @@ DEFUN(list, "list", (LispVal * args), "(&rest args)", "") {
     return args;
 }
 
+LispVal *nth(size_t n, LispVal *list) {
+    size_t i = 0;
+    DOTAILS(rest, list) {
+        if (i == n) {
+            return XCAR(rest);
+        }
+        ++i;
+    }
+    return Qnil;
+}
+
+DEFUN(nth, "list", (LispVal * n, LispVal *list), "(n list)", "") {
+    CHECK_TYPE(n, TYPE_FIXNUM);
+    return nth(XFIXNUM(n), list);
+}
+
 DEFUN(member, "member", (LispVal * elt, LispVal *list, LispVal *pred),
       "(elt list &optional pred)", "") {
     if (NILP(pred) || pred == Qeq) {
@@ -74,7 +97,7 @@ DEFUN(member, "member", (LispVal * elt, LispVal *list, LispVal *pred),
         }
     } else {
         DOTAILS(rest, list) {
-            if (CALL(pred, elt, XCAR(rest))) {
+            if (!NILP(CALL(pred, elt, XCAR(rest)))) {
                 return rest;
             }
         }
@@ -82,6 +105,16 @@ DEFUN(member, "member", (LispVal * elt, LispVal *list, LispVal *pred),
     return Qnil;
 }
 
+DEFUN(member_if, "member-if", (LispVal * pred, LispVal *list), "(pred list)",
+      "") {
+    DOTAILS(rest, list) {
+        if (!NILP(CALL(pred, 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

@@ -10,6 +10,9 @@ DEFOBJTYPE(Cons, CONS, CONSP, {
     LispVal *car;
     LispVal *cdr;
 });
+static ALWAYS_INLINE bool ATOM(LispVal *val) {
+    return !CONSP(val);
+}
 
 static ALWAYS_INLINE bool LISTP(LispVal *obj) {
     return NILP(obj) || CONSP(obj);
@@ -105,6 +108,9 @@ static ALWAYS_INLINE LispVal *LIST_N(int count, ...) {
 
 #define DOTAILS(v, l) for (LispVal *v = (l); !NILP(v); v = XCDR_SAFE(v))
 
+DECLARE_SYMBOL(circular_list_error);
+MAKE_CONDITION_CLASS(circular_list_error);
+
 // return -1 list is circular
 intptr_t list_length(LispVal *list);
 // Return true if the length of LIST == SIZE
@@ -116,6 +122,8 @@ DECLARE_FUNCTION(length_eq, (LispVal * list, LispVal *length));
 DECLARE_FUNCTION(nreverse, (LispVal * list));
 DECLARE_FUNCTION(listp, (LispVal * obj));
 DECLARE_FUNCTION(list, (LispVal * args));
+LispVal *nth(size_t n, LispVal *list);
+DECLARE_FUNCTION(nth, (LispVal * n, LispVal *list));
 static ALWAYS_INLINE void CHECK_LISTP(LispVal *obj) {
     if (!LISTP(obj)) {
         signal_type_error(obj, LIST(Qlist));
@@ -124,6 +132,7 @@ static ALWAYS_INLINE void CHECK_LISTP(LispVal *obj) {
 
 // List utility functions
 DECLARE_FUNCTION(member, (LispVal * elt, LispVal *list, LispVal *pred));
+DECLARE_FUNCTION(member_if, (LispVal * pred, LispVal *list));
 
 DECLARE_FUNCTION(plist_put, (LispVal * plist, LispVal *prop, LispVal *value));
 DECLARE_FUNCTION(plist_get, (LispVal * plist, LispVal *prop, LispVal *def));

src/main.c

@@ -3,11 +3,6 @@
 
 #include <stdio.h>
 
-DEFUN(print, "print", (LispVal * v), "(v)", "") {
-    debug_obj_info(stdout, v);
-    return Qnil;
-}
-
 int main(int argc, const char **argv) {
     FILE *in = fopen(argv[1], "r");
     fseek(in, 0, SEEK_END);
@@ -17,15 +12,24 @@ int main(int argc, const char **argv) {
     fread(src, 1, src_len, in);
     fclose(in);
     lisp_init();
-    REGISTER_GLOBAL_FUNCTION(print);
     push_local_reference_frame();
     StackFrame *toplevel = LISP_STACK_REF();
     ReadStream s;
     read_stream_init(&s, src, src_len);
     LispVal *r;
+    CONDITION_CASE(
+        LIST(Qt),
+        {
             while ((r = read(&s))) {
                 Feval(r, Qnil);
             }
+        },
+        {
+            fprintf(stderr, "Caught exception: ");
+            Fprint_condition(EXCEPTION_NAME(), EXCEPTION_DATA(),
+                             Qerror_write_byte); //
+            fprintf(stderr, "\nBacktrace (toplevel comes last):\n");
+        });
     unwind_to(toplevel);
     lisp_shutdown();
     free(src);

src/print.c

@@ -15,9 +15,9 @@ DEFVAR(print_base_upper, "print-base-upper", "", Qt);
 DEFVAR(print_precision, "print-precision", "", MAKE_FIXNUM(6));
 DEFVAR(print_quoted, "print-quoted", "", Qt);
 
-DEFUN(write_byte, "write-byte", (LispVal * ch), "(ch)", "") {
+static void lisp_fputc(LispVal *ch, FILE *file) {
     if (NILP(ch)) {
-        fflush(stdout);
+        fflush(file);
     }
     CHECK_TYPE(ch, TYPE_FIXNUM);
     fixnum_t f = XFIXNUM(ch);
@@ -25,7 +25,16 @@ DEFUN(write_byte, "write-byte", (LispVal * ch), "(ch)", "") {
         // TODO error
         abort();
     }
-    fputc(f, stdout);
+    fputc(f, file);
+}
+
+DEFUN(write_byte, "write-byte", (LispVal * ch), "(ch)", "") {
+    lisp_fputc(ch, stdout);
+    return Qnil;
+}
+
+DEFUN(error_write_byte, "error-write-byte", (LispVal * ch), "(ch)", "") {
+    lisp_fputc(ch, stderr);
     return Qnil;
 }
 
@@ -392,6 +401,24 @@ DEFUN(prin1, "prin1", (LispVal * val, LispVal *print_char_fun),
     return Qnil;
 }
 
+DEFUN(print_condition, "print-condition",
+      (LispVal * name, LispVal *data, LispVal *print_char_fun),
+      "(name data &optional print-char-fun)", "") {
+    if (NILP(Fcondition_class_p(name))) {
+        // TODO type error
+        abort();
+    }
+    LispVal *printer = Fcondition_printer(name);
+    if (NILP(printer)) {
+        // default format
+        Fprinc(CONS(name, data), print_char_fun);
+    } else {
+        // custom format
+        CALL(printer, data, print_char_fun);
+    }
+    return Qnil;
+}
+
 void debug_print(FILE *file, LispVal *obj) {
     switch (TYPE_OF(obj)) {
     case TYPE_FIXNUM:

src/print.h

@@ -15,12 +15,17 @@ DECLARE_VARIABLE(print_quoted);
 
 // For now, a print character function takes nil to mean flush
 DECLARE_FUNCTION(write_byte, (LispVal * ch));
+DECLARE_FUNCTION(error_write_byte, (LispVal * ch));
 
 // Pretty print
 DECLARE_FUNCTION(princ, (LispVal * val, LispVal *print_char_fun));
 // Quoted print
 DECLARE_FUNCTION(prin1, (LispVal * val, LispVal *print_char_fun));
 
+// Printing conditions
+DECLARE_FUNCTION(print_condition,
+                 (LispVal * name, LispVal *data, LispVal *print_char_fun));
+
 __attribute__((no_sanitize("address"))) void debug_print(FILE *file,
                                                          LispVal *obj);
 

src/stack.c

@@ -4,8 +4,10 @@
 #include "hashtable.h"
 #include "list.h"
 #include "memory.h"
+#include "print.h"
 
 #include <assert.h>
+#include <stdio.h>
 
 struct LispStack the_stack;
 
@@ -89,13 +91,12 @@ void push_unwind_protect_frame(jmp_buf *buf) {
     frame->unwind_protect.target = buf;
 }
 
-void push_condition_case_frame(jmp_buf *buf, LispVal **variable,
+void push_condition_case_frame(jmp_buf *buf, LispVal *exceptions,
-                               LispVal *exceptions) {
+                               size_t datum) {
     StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_CONDITION_CASE);
     frame->condition_case.target = buf;
-    frame->condition_case.variable = variable;
     frame->condition_case.exceptions = exceptions;
-    *variable = Qnil;
+    frame->condition_case.datum = datum;
 }
 
 void push_local_reference_frame(void) {
@@ -271,11 +272,20 @@ void new_lexical_variable(LispVal *name, LispVal *value) {
     }
 }
 
-void unwind_to(StackFrame *frame) {
+static bool frame_handles_exception(StackFrame *restrict frame,
-    the_stack.unwind_info.set = true;
+                                    LispVal *exception_name) {
-    the_stack.unwind_info.cause = UNWIND_NORMAL;
+    assert(frame->kind == STACK_FRAME_CONDITION_CASE);
-    the_stack.unwind_info.target = frame;
+    DOLIST(fe, frame->condition_case.exceptions) {
-    while (&the_stack.frames[the_stack.depth - 1] > frame) {
+        if (!NILP(Fcondition_subclass_p(exception_name, fe))) {
+            return true;
+        }
+    }
+    return false;
+}
+
+void do_unwind_to(StackFrame *frame, LispVal *exception_name,
+                  LispVal *exception_data) {
+    while (the_stack.depth && &the_stack.frames[the_stack.depth - 1] > frame) {
         StackFrame *restrict top = &the_stack.frames[--the_stack.depth];
         switch (top->kind) {
         case STACK_FRAME_DYNAMIC_BINDING:
@@ -291,24 +301,66 @@ void unwind_to(StackFrame *frame) {
         case STACK_FRAME_LOCAL_REFERENCES:
             teardown_local_references(top);
             break;
-        case STACK_FRAME_CALL:
         case STACK_FRAME_CONDITION_CASE:
+            if (exception_name
+                && frame_handles_exception(top, exception_name)) {
+                the_stack.unwind_info.exception.handler_datum =
+                    top->condition_case.datum;
+                longjmp(*top->condition_case.target, LISP_LONGJMP_FOR_UNWIND);
+            }
+            break;
+        case STACK_FRAME_CALL:
             // nothing to do
             break;
         }
     }
+}
+
+void unwind_to(StackFrame *frame) {
+    the_stack.unwind_info.set = true;
+    the_stack.unwind_info.cause = UNWIND_NORMAL;
+    the_stack.unwind_info.target = frame;
+    do_unwind_to(frame, NULL, NULL);
     the_stack.unwind_info.set = false;
 }
 
+static noreturn void top_of_stack_exception_handler(void) {
+    assert(the_stack.unwind_info.set
+           && the_stack.unwind_info.cause == UNWIND_EXCEPTION);
+    fprintf(stderr,
+            "An exception has propagated to the top of the lisp stack!\n");
+    fprintf(stderr, "Name: ");
+    debug_print(stderr, the_stack.unwind_info.exception.name);
+    fprintf(stderr, "\nData: ");
+    debug_print(stderr, the_stack.unwind_info.exception.data);
+    fprintf(stderr, "\nLisp will now exit...\n");
+    abort();
+}
+
 noreturn void continue_unwinding(void) {
     assert(the_stack.unwind_info.set);
     switch (the_stack.unwind_info.cause) {
     case UNWIND_NORMAL:
-        unwind_to(the_stack.unwind_info.target);
+        do_unwind_to(the_stack.unwind_info.target, NULL, NULL);
-    case UNWIND_EXCEPTION:
-        // TODO implement
         abort();
+    case UNWIND_EXCEPTION:
+        do_unwind_to(NULL, the_stack.unwind_info.exception.name,
+                     the_stack.unwind_info.exception.data);
+        top_of_stack_exception_handler();
     default:
         abort();
     }
 }
+
+noreturn void lisp_signal(LispVal *name, LispVal *data) {
+    if (NILP(Fcondition_class_p(name))) {
+        // TODO type ERROR
+    }
+    CHECK_LISTP(data);
+    the_stack.unwind_info.set = true;
+    the_stack.unwind_info.cause = UNWIND_EXCEPTION;
+    the_stack.unwind_info.exception.name = name;
+    the_stack.unwind_info.exception.data = data;
+    do_unwind_to(NULL, name, data);
+    top_of_stack_exception_handler();
+}

src/stack.h

@@ -2,7 +2,6 @@
 #define INCLUDED_STACK_H
 
 #include "base.h"
-#include "list.h"
 
 #include <setjmp.h>
 #include <stdnoreturn.h>
@@ -49,8 +48,8 @@ struct _StackFrame {
         } unwind_protect;
         struct {
             jmp_buf *target;
-            LispVal **variable;
             LispVal *exceptions; // list of exception symbols to catch
+            size_t datum; // extra value to identify this case
         } condition_case;
         struct {
             LispVal *symbol;
@@ -72,6 +71,7 @@ struct UnwindInformation {
         struct {
             LispVal *name;
             LispVal *data;
+            size_t handler_datum;
         } exception;
     };
 };
@@ -110,6 +110,24 @@ static ALWAYS_INLINE StackFrame *LISP_STACK_REF(void) {
     return &the_stack.frames[the_stack.depth - 1];
 }
 
+static ALWAYS_INLINE LispVal *EXCEPTION_NAME(void) {
+    assert(the_stack.unwind_info.set
+           && the_stack.unwind_info.cause == UNWIND_EXCEPTION);
+    return the_stack.unwind_info.exception.name;
+}
+
+static ALWAYS_INLINE LispVal *EXCEPTION_DATA(void) {
+    assert(the_stack.unwind_info.set
+           && the_stack.unwind_info.cause == UNWIND_EXCEPTION);
+    return the_stack.unwind_info.exception.data;
+}
+
+static ALWAYS_INLINE size_t EXCEPTION_HANDLER_DATUM(void) {
+    assert(the_stack.unwind_info.set
+           && the_stack.unwind_info.cause == UNWIND_EXCEPTION);
+    return the_stack.unwind_info.exception.handler_datum;
+}
+
 // functions
 void push_call_frame(LispVal *name, LispVal *args);
 // replace the args in the top stack frame with ARGS and mark them as evaluated
@@ -121,8 +139,7 @@ void set_stack_evaluated_args(StackFrame *restrict ref, LispVal *fobj,
 void push_unwind_protect_frame(jmp_buf *buf);
 
 // condition case
-void push_condition_case_frame(jmp_buf *buf, LispVal **variable,
+void push_condition_case_frame(jmp_buf *buf, LispVal *exceptions, size_t datum);
-                               LispVal *exceptions);
 
 // local references
 void push_local_reference_frame(void);
@@ -153,6 +170,8 @@ static ALWAYS_INLINE LispVal *UNWIND_AND_RETURN(StackFrame *frame,
 }
 noreturn void continue_unwinding(void);
 
+noreturn void lisp_signal(LispVal *name, LispVal *data);
+
 #define UNWIND_PROTECT(body, cleanup)                        \
     {                                                        \
         jmp_buf _internal_jb;                                \
@@ -162,7 +181,22 @@ noreturn void continue_unwinding(void);
             {body};                                          \
             unwind_to(_internal_target);                     \
         } else {                                             \
-            cleanup                                          \
+            {cleanup};                                       \
+            continue_unwinding();                            \
+        }                                                    \
+    };
+
+#define CONDITION_CASE(exceptions, body, handler)                    \
+    {                                                                \
+        jmp_buf _internal_jb;                                        \
+        StackFrame *_internal_target = LISP_STACK_REF();             \
+        if (setjmp(_internal_jb) == 0) {                             \
+            push_condition_case_frame(&_internal_jb, exceptions, 0); \
+            {body};                                                  \
+            unwind_to(_internal_target);                             \
+        } else {                                                     \
+            {handler};                                               \
+            unwind_to(_internal_target);                             \
         }                                                            \
     };