Exception handling

lisp/kernel.gl

@@ -1,3 +1,7 @@
 ;; -*- mode: lisp-data -*-
 
-(error '("Hi"))
+(fset 'test-fun (lambda (x)
+                  (error (list x))))
+
+(test-fun "hi")
+

src/base.c

@@ -102,6 +102,19 @@ LispVal *make_vector(LispVal **data, size_t length, bool take) {
     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);
@@ -191,7 +204,7 @@ DEFINE_SYMBOL(float, "float");
 // cons defined in list.c
 DEFINE_SYMBOL(string, "strin");
 DEFINE_SYMBOL(symbol, "symbol");
-DEFINE_SYMBOL(vector, "vector");
+// vector defined above
 DEFINE_SYMBOL(hash_table, "hash-table");
 DEFINE_SYMBOL(function, "function");
 
@@ -258,63 +271,55 @@ DEFUN(signal, "signal", (LispVal * name, LispVal *data), "(name data)", "") {
     abort();
 }
 
-static void check_condition_case_handlers(LispVal *handlers) {
+static void check_handler_bind_handlers(LispVal *handlers) {
-    DOTAILS(rest, handlers) {
+    DOLIST(handler, handlers) {
-        LispVal *handler = XCAR(rest);
+        CHECK_LISTP(handler);
-        if (ATOM(handler)) {
+        if (!list_length_eq(handler, 2)) {
-            // TODO type error
+            // TODO error
             abort();
-        } else if (LISTP(XCAR(handler))) {
+        }
+        CHECK_TYPE(XCDR(handler), TYPE_FUNCTION);
+        if (LISTP(XCAR(handler))) {
             // make sure each condition is a symbol
             DOTAILS(rest, XCAR(handler)) {
-                if (!SYMBOLP(XCAR(rest))) {
+                CHECK_TYPE(XCAR(rest), TYPE_SYMBOL);
-                    // TODO error
-                    abort();
-                }
             }
         } else if (!SYMBOLP(XCAR(handler))) {
             // if the condition is not a list or symbol, it's an error
-            // TODO type error
+            signal_type_error(XCAR(handler), LIST(Qsymbol, Qlist));
-            abort();
         }
     }
 }
 
-DEFUN(condition_case, "condition-case",
+DEFUN(handler_bind, "handler-bind", (LispVal * thunk, LispVal *handlers),
-      (LispVal * var, LispVal *form, LispVal *handlers),
+      "(thunk &rest handlers)", "") {
-      "(var form &rest handlers)", "") {
+    check_handler_bind_handlers(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 nhandlers = list_length(handlers);
+    LispVal **handler_vec = lisp_malloc(sizeof(LispVal *) * nhandlers);
+    bool **enabled_vec = lisp_malloc(sizeof(bool *) * nhandlers);
     size_t idx = 0;
     DOLIST(handler, handlers) {
-        if (EQ(XCAR(handler), Qkw_success)) {
+        handler_vec[idx] = XCDR(handler);
-            success_handler = XCDR(handler);
+        enabled_vec[idx] =
-        } else {
+            push_handler_bind_frame(&jmp_target, XCAR(handler), idx);
-            push_condition_case_frame(&jmp_target, XCAR(handler), idx);
-        }
         ++idx;
     }
     if (setjmp(jmp_target) == 0) {
-        LispVal *res = Feval(form, Vlexical_environment);
+        return UNWIND_AND_RETURN(stack_ref, CALL0(thunk));
-        unwind_to(stack_ref);
-        if (NILP(success_handler)) {
-            return res;
-        } else {
-            return Fprogn(success_handler);
-        }
     } else {
-        unwind_to(stack_ref);
+        size_t handler_idx = EXCEPTION_HANDLER_FRAME()->handler_bind.datum;
-        if (!NILP(var)) {
+        for (size_t i = 0; i < nhandlers; ++i) {
-            push_copy_lexenv();
+            *enabled_vec[i] = false;
-            new_lexical_variable(var, CONS(EXCEPTION_NAME(), EXCEPTION_DATA()));
         }
-        UNWIND_AND_RETURN(
+        CALL(handler_vec[handler_idx],
-            stack_ref, Fprogn(XCDR(nth(EXCEPTION_HANDLER_DATUM(), handlers))));
+             CONS(EXCEPTION_NAME(), EXCEPTION_DATA()));
+        for (size_t i = 0; i < nhandlers; ++i) {
+            *enabled_vec[i] = true;
+        }
+        continue_unwinding();
     }
-    return Qnil;
 }
 
 DEFUN(error, "error", (LispVal * data), "(data)", "") {

src/base.h

@@ -341,6 +341,7 @@ DECLARE_FUNCTION(quote, (LispVal * form));
 
 // TODO probably move these to another file
 LispVal *make_vector(LispVal **data, size_t length, bool take);
+DECLARE_FUNCTION(vector, (LispVal * data));
 DECLARE_FUNCTION(make_symbol, (LispVal * name));
 DECLARE_FUNCTION(intern, (LispVal * name));
 DECLARE_FUNCTION(symbol_value, (LispVal * sym));
@@ -402,7 +403,7 @@ DECLARE_SYMBOL(float);
 // cons declared in list.h
 DECLARE_SYMBOL(string);
 DECLARE_SYMBOL(symbol);
-DECLARE_SYMBOL(vector);
+// vector defined above
 DECLARE_SYMBOL(hash_table);
 DECLARE_SYMBOL(function);
 
@@ -417,8 +418,7 @@ DECLARE_FUNCTION(condition_printer, (LispVal * val));
 DECLARE_SYMBOL(kw_success);
 
 DECLARE_FUNCTION(signal, (LispVal * name, LispVal *data));
-DECLARE_FUNCTION(condition_case,
+DECLARE_FUNCTION(handler_bind, (LispVal * thunk, LispVal *handlers));
-                 (LispVal * var, LispVal *form, LispVal *handlers));
 DECLARE_FUNCTION(error, (LispVal * data));
 MAKE_CONDITION_CLASS(error);
 

src/function.c

@@ -105,14 +105,13 @@ parse_optional_arg_spec(LispVal *used_names, LispVal **out, LispVal *entry) {
         result->err_obj = (obj);              \
         return;                               \
     }
-void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
+void parse_lambda_list(LambdaListParseResult *restrict result, LispVal *list) {
     enum { REQ = 0, OPT = 1, KEY = 2, REST = 4, MUST_CHANGE } mode = REQ;
     unsigned int seen = 0;
     result->err_obj = Qnil;
     result->status = LLPS_OK;
-    struct LambdaList *out = &result->lambda_list;
+    struct LambdaList *restrict out = &result->lambda_list;
     LispVal *used_names = make_hash_table_no_gc(Qnil, Qnil);
-    // TODO check for repeat names
     out->n_req = 0;
     out->n_opt = 0;
     out->allow_other_keys = false;

src/function.h

@@ -75,7 +75,7 @@ typedef struct {
     LispVal *err_obj; // the object the caused the above status
 } LambdaListParseResult;
 
-void parse_lambda_list(LambdaListParseResult *out, LispVal *list);
+void parse_lambda_list(LambdaListParseResult *restrict out, LispVal *list);
 
 // This will cause the program to exit if an error occurs while parsing
 // LISP_ARGS!
@@ -91,6 +91,7 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*func)(void),
 
 DECLARE_FUNCTION(funcall, (LispVal * func, LispVal *args));
 #define CALL(func, ...) (Ffuncall((func), LIST(__VA_ARGS__)))
+#define CALL0(func)     (Ffuncall((func), Qnil))
 
 DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body));
 

src/gc.c

@@ -300,8 +300,8 @@ static void mark_stack_frame(StackFrame *frame, size_t *restrict limit) {
     case STACK_FRAME_UNWIND_PROTECT:
         // nothing to do
         break;
-    case STACK_FRAME_CONDITION_CASE:
+    case STACK_FRAME_HANDLER_BIND:
-        mark_object(frame->condition_case.exceptions);
+        mark_object(frame->handler_bind.exceptions);
         saturating_dec(limit, 1);
         break;
     case STACK_FRAME_DYNAMIC_BINDING:

src/gen-init-globals.awk

@@ -28,7 +28,7 @@ BEGIN {
     }
 
     print ""
-    print "void register_globals() {"
+    print "void register_globals(void) {"
     first_header = 1
 }
 

src/list.c

@@ -62,10 +62,36 @@ DEFUN(nreverse, "nreverse", (LispVal * list), "(list)", "") {
     return rev;
 }
 
+DEFUN(last, "last", (LispVal * list), "(list)", "") {
+    if (NILP(list)) {
+        return Qnil;
+    }
+    CHECK_LISTP(list);
+    while (CONSP(XCDR(list))) {
+        list = XCDR(list);
+    }
+    return list;
+}
+
 DEFUN(listp, "listp", (LispVal * obj), "(obj)", "") {
     return LISTP(obj) ? Qt : Qnil;
 }
 
+DEFUN(proper_list_p, "proper-list-p", (LispVal * obj), "(obj)", "") {
+    CHECK_LISTP(obj);
+    return (NILP(Fcircular_list_p(obj)) && NILP(XCDR(Flast(obj)))) ? Qt : Qnil;
+}
+
+DEFUN(circular_list_p, "circular-list-p", (LispVal * obj), "(obj)", "") {
+    CHECK_LISTP(obj);
+    return list_length(obj) == -1 ? Qt : Qnil;
+}
+
+DEFUN(dotted_list_p, "dotted-list-p", (LispVal * obj), "(obj)", "") {
+    CHECK_LISTP(obj);
+    return (NILP(Fcircular_list_p(obj)) && !NILP(XCDR(Flast(obj)))) ? Qt : Qnil;
+}
+
 DEFUN(list, "list", (LispVal * args), "(&rest args)", "") {
     return args;
 }
@@ -81,7 +107,7 @@ LispVal *nth(size_t n, LispVal *list) {
     return Qnil;
 }
 
-DEFUN(nth, "list", (LispVal * n, LispVal *list), "(n list)", "") {
+DEFUN(nth, "nth", (LispVal * n, LispVal *list), "(n list)", "") {
     CHECK_TYPE(n, TYPE_FIXNUM);
     return nth(XFIXNUM(n), list);
 }

src/list.h

@@ -120,7 +120,11 @@ DECLARE_FUNCTION(cons, (LispVal * car, LispVal *cdr));
 DECLARE_FUNCTION(length, (LispVal * list));
 DECLARE_FUNCTION(length_eq, (LispVal * list, LispVal *length));
 DECLARE_FUNCTION(nreverse, (LispVal * list));
+DECLARE_FUNCTION(last, (LispVal * list));
 DECLARE_FUNCTION(listp, (LispVal * obj));
+DECLARE_FUNCTION(proper_list_p, (LispVal * obj));
+DECLARE_FUNCTION(circular_list_p, (LispVal * obj));
+DECLARE_FUNCTION(dotted_list_p, (LispVal * obj));
 DECLARE_FUNCTION(list, (LispVal * args));
 LispVal *nth(size_t n, LispVal *list);
 DECLARE_FUNCTION(nth, (LispVal * n, LispVal *list));

src/main.c

@@ -17,7 +17,8 @@ int main(int argc, const char **argv) {
     ReadStream s;
     read_stream_init(&s, src, src_len);
     LispVal *r;
-    CONDITION_CASE(
+    bool had_toplevel_error = false;
+    HANDLER_BIND1(
         LIST(Qt),
         {
             while ((r = read(&s))) {
@@ -29,9 +30,23 @@ int main(int argc, const char **argv) {
             Fprint_condition(EXCEPTION_NAME(), EXCEPTION_DATA(),
                              Qerror_write_byte); //
             fprintf(stderr, "\nBacktrace (toplevel comes last):\n");
+            LispVal *backtrace = Fbacktrace();
+            DOLIST(frame, backtrace) {
+                LispVal *name = FIRST(frame);
+                bool evaled = !NILP(THIRD(frame));
+                LispVal *args = FOURTH(frame);
+                fprintf(stderr, " %c ", evaled ? '-' : '*');
+                Fprinc(name, Qerror_write_byte);
+                Fprinc(args, Qerror_write_byte);
+                fputc('\n', stderr);
+            }
+            CLEAR_EXCEPTION();
+            had_toplevel_error = true;
+            goto toplevel_error;
         });
+toplevel_error:
     unwind_to(toplevel);
     lisp_shutdown();
     free(src);
-    return 0;
+    return had_toplevel_error ? EXIT_FAILURE : EXIT_SUCCESS;
 }

src/stack.c

@@ -91,12 +91,13 @@ void push_unwind_protect_frame(jmp_buf *buf) {
     frame->unwind_protect.target = buf;
 }
 
-void push_condition_case_frame(jmp_buf *buf, LispVal *exceptions,
+bool *push_handler_bind_frame(jmp_buf *buf, LispVal *exceptions, size_t datum) {
-                               size_t datum) {
+    StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_HANDLER_BIND);
-    StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_CONDITION_CASE);
+    frame->handler_bind.target = buf;
-    frame->condition_case.target = buf;
+    frame->handler_bind.exceptions = exceptions;
-    frame->condition_case.exceptions = exceptions;
+    frame->handler_bind.datum = datum;
-    frame->condition_case.datum = datum;
+    frame->handler_bind.enabled = true;
+    return &frame->handler_bind.enabled;
 }
 
 void push_local_reference_frame(void) {
@@ -272,19 +273,7 @@ void new_lexical_variable(LispVal *name, LispVal *value) {
     }
 }
 
-static bool frame_handles_exception(StackFrame *restrict frame,
+static void do_unwind_to(StackFrame *frame) {
-                                    LispVal *exception_name) {
-    assert(frame->kind == STACK_FRAME_CONDITION_CASE);
-    DOLIST(fe, frame->condition_case.exceptions) {
-        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) {
@@ -301,14 +290,7 @@ void do_unwind_to(StackFrame *frame, LispVal *exception_name,
         case STACK_FRAME_LOCAL_REFERENCES:
             teardown_local_references(top);
             break;
-        case STACK_FRAME_CONDITION_CASE:
+        case STACK_FRAME_HANDLER_BIND:
-            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;
@@ -320,10 +302,40 @@ 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);
+    do_unwind_to(frame);
     the_stack.unwind_info.set = false;
 }
 
+static bool frame_handles_exception(StackFrame *restrict frame,
+                                    LispVal *exception_name) {
+    assert(frame->kind == STACK_FRAME_HANDLER_BIND);
+    DOLIST(fe, frame->handler_bind.exceptions) {
+        if (!NILP(Fcondition_subclass_p(exception_name, fe))) {
+            return true;
+        }
+    }
+    return false;
+}
+
+static StackFrame *find_exception_handler(StackFrame *from,
+                                          LispVal *exception_name) {
+    for (ptrdiff_t i = from - the_stack.frames; i >= 0; --i) {
+        StackFrame *restrict top = &the_stack.frames[i];
+        if (top->kind == STACK_FRAME_HANDLER_BIND && top->handler_bind.enabled
+            && frame_handles_exception(top, exception_name)) {
+            return top;
+        }
+    }
+    return NULL;
+}
+
+static void do_run_handler_cases(LispVal *name, StackFrame *start) {
+    while ((start = find_exception_handler(start, name))) {
+        the_stack.unwind_info.exception.handler_frame = start;
+        longjmp(*start->handler_bind.target, LISP_LONGJMP_FOR_UNWIND);
+    }
+}
+
 static noreturn void top_of_stack_exception_handler(void) {
     assert(the_stack.unwind_info.set
            && the_stack.unwind_info.cause == UNWIND_EXCEPTION);
@@ -341,11 +353,12 @@ noreturn void continue_unwinding(void) {
     assert(the_stack.unwind_info.set);
     switch (the_stack.unwind_info.cause) {
     case UNWIND_NORMAL:
-        do_unwind_to(the_stack.unwind_info.target, NULL, NULL);
+        do_unwind_to(the_stack.unwind_info.target);
         abort();
     case UNWIND_EXCEPTION:
-        do_unwind_to(NULL, the_stack.unwind_info.exception.name,
+        do_run_handler_cases(the_stack.unwind_info.exception.name,
-                     the_stack.unwind_info.exception.data);
+                             the_stack.unwind_info.exception.handler_frame - 1);
+        do_unwind_to(NULL);
         top_of_stack_exception_handler();
     default:
         abort();
@@ -354,13 +367,28 @@ noreturn void continue_unwinding(void) {
 
 noreturn void lisp_signal(LispVal *name, LispVal *data) {
     if (NILP(Fcondition_class_p(name))) {
-        // TODO type ERROR
+        signal_type_error(name, LIST(Qcondition_class));
     }
     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);
+    do_run_handler_cases(name, LISP_STACK_REF());
+    do_unwind_to(NULL);
     top_of_stack_exception_handler();
 }
+
+DEFUN(backtrace, "backtrace", (void), "()", "") {
+    LispVal *out = Qnil;
+    for (size_t i = 0; i < the_stack.depth; ++i) {
+        StackFrame *restrict frame = &the_stack.frames[i];
+        if (frame->kind == STACK_FRAME_CALL) {
+            out = CONS(LIST(frame->call.name, frame->call.fobj,
+                            frame->call.evaled_args ? Qt : Qnil,
+                            frame->call.args),
+                       out);
+        }
+    }
+    return out;
+}

src/stack.h

@@ -10,7 +10,7 @@ enum StackFrameKind {
     STACK_FRAME_LOCAL_REFERENCES,
     STACK_FRAME_CALL,
     STACK_FRAME_UNWIND_PROTECT,
-    STACK_FRAME_CONDITION_CASE,
+    STACK_FRAME_HANDLER_BIND,
     STACK_FRAME_DYNAMIC_BINDING,
 };
 
@@ -44,13 +44,13 @@ struct _StackFrame {
         } call;
         struct {
             jmp_buf *target;
-            StackFrame **unwind_target;
         } unwind_protect;
         struct {
             jmp_buf *target;
             LispVal *exceptions; // list of exception symbols to catch
             size_t datum; // extra value to identify this case
-        } condition_case;
+            bool enabled;
+        } handler_bind;
         struct {
             LispVal *symbol;
             LispVal *old_value;
@@ -71,7 +71,7 @@ struct UnwindInformation {
         struct {
             LispVal *name;
             LispVal *data;
-            size_t handler_datum;
+            StackFrame *handler_frame;
         } exception;
     };
 };
@@ -110,6 +110,14 @@ static ALWAYS_INLINE StackFrame *LISP_STACK_REF(void) {
     return &the_stack.frames[the_stack.depth - 1];
 }
 
+static ALWAYS_INLINE void CLEAR_EXCEPTION(void) {
+    the_stack.unwind_info.set = false;
+}
+
+static ALWAYS_INLINE bool EXCEPTION_SET_P(void) {
+    return the_stack.unwind_info.set;
+}
+
 static ALWAYS_INLINE LispVal *EXCEPTION_NAME(void) {
     assert(the_stack.unwind_info.set
            && the_stack.unwind_info.cause == UNWIND_EXCEPTION);
@@ -122,10 +130,10 @@ static ALWAYS_INLINE LispVal *EXCEPTION_DATA(void) {
     return the_stack.unwind_info.exception.data;
 }
 
-static ALWAYS_INLINE size_t EXCEPTION_HANDLER_DATUM(void) {
+static ALWAYS_INLINE StackFrame *EXCEPTION_HANDLER_FRAME(void) {
     assert(the_stack.unwind_info.set
            && the_stack.unwind_info.cause == UNWIND_EXCEPTION);
-    return the_stack.unwind_info.exception.handler_datum;
+    return the_stack.unwind_info.exception.handler_frame;
 }
 
 // functions
@@ -138,8 +146,8 @@ void set_stack_evaluated_args(StackFrame *restrict ref, LispVal *fobj,
 // unwind protect
 void push_unwind_protect_frame(jmp_buf *buf);
 
-// condition case
+// handler bind
-void push_condition_case_frame(jmp_buf *buf, LispVal *exceptions, size_t datum);
+bool *push_handler_bind_frame(jmp_buf *buf, LispVal *exceptions, size_t datum);
 
 // local references
 void push_local_reference_frame(void);
@@ -172,6 +180,11 @@ noreturn void continue_unwinding(void);
 
 noreturn void lisp_signal(LispVal *name, LispVal *data);
 
+/**
+ * Backtraces have the form (name fobj evaled? args)
+ */
+DECLARE_FUNCTION(backtrace, (void) );
+
 #define UNWIND_PROTECT(body, cleanup)                        \
     {                                                        \
         jmp_buf _internal_jb;                                \
@@ -186,17 +199,35 @@ noreturn void lisp_signal(LispVal *name, LispVal *data);
         }                                                    \
     };
 
-#define CONDITION_CASE(exceptions, body, handler)                    \
+#define HANDLER_BIND1(exceptions, body, handler)                               \
+    {                                                                          \
+        jmp_buf _internal_jb;                                                  \
+        StackFrame *_internal_target = LISP_STACK_REF();                       \
+        bool *enabled;                                                         \
+        if (setjmp(_internal_jb) == 0) {                                       \
+            enabled = push_handler_bind_frame(&_internal_jb, (exceptions), 0); \
+            {body};                                                            \
+            unwind_to(_internal_target);                                       \
+        } else {                                                               \
+            *enabled = false;                                                  \
+            {handler};                                                         \
+            *enabled = true;                                                   \
+            continue_unwinding();                                              \
+        }                                                                      \
+    };
+
+#define CONDITION_CASE1(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); \
+            push_handler_bind_frame(&_internal_jb, (exceptions), 0); \
             {body};                                                  \
             unwind_to(_internal_target);                             \
         } else {                                                     \
-            {handler};                                               \
             unwind_to(_internal_target);                             \
+            {handler};                                               \
+            CLEAR_EXCEPTION();                                       \
         }                                                            \
     };