From 07060a17fe70ebc8438f3b58670a3425db369e39 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Wed, 2 Sep 2026 01:54:14 -0700 Subject: [PATCH] Exceptions!!! --- lisp/kernel.gl | 6 +- src/base.c | 144 +++++++++++++++++++++++++++++++++++---- src/base.h | 34 +++++++++ src/gc.c | 26 ++++++- src/gen-init-globals.awk | 5 ++ src/lisp.c | 5 +- src/list.c | 45 ++++++++++-- src/list.h | 9 +++ src/main.c | 22 +++--- src/print.c | 33 ++++++++- src/print.h | 5 ++ src/stack.c | 78 +++++++++++++++++---- src/stack.h | 44 ++++++++++-- 13 files changed, 396 insertions(+), 60 deletions(-) diff --git a/lisp/kernel.gl b/lisp/kernel.gl index c19bdc0..cbe6319 100644 --- a/lisp/kernel.gl +++ b/lisp/kernel.gl @@ -1,7 +1,3 @@ ;; -*- mode: lisp-data -*- -(let ((print-quoted nil)) - (prin1 '(quote a)) - (write-byte ?\n)) -(prin1 '(quote a)) -(write-byte ?\n) +(error '("Hi")) diff --git a/src/base.c b/src/base.c index 54f5365..045a8dd 100644 --- a/src/base.c +++ b/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, ",@"); diff --git a/src/base.h b/src/base.h index ba7bb41..a01699b 100644 --- a/src/base.h +++ b/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); diff --git a/src/gc.c b/src/gc.c index 095cb9a..bb1ea79 100644 --- a/src/gc.c +++ b/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; diff --git a/src/gen-init-globals.awk b/src/gen-init-globals.awk index 521d8f3..d4c308d 100644 --- a/src/gen-init-globals.awk +++ b/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 "}" } diff --git a/src/lisp.c b/src/lisp.c index d986f53..3ea6de8 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -4,8 +4,6 @@ #include "init_globals.h" #include "lisp_string.h" -#include - 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: diff --git a/src/list.c b/src/list.c index 0c3ce43..4299db6 100644 --- a/src/list.c +++ b/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 - // TODO list may be circular - return MAKE_FIXNUM(list_length(list)); + CHECK_LISTP(list); + intptr_t len = 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); diff --git a/src/list.h b/src/list.h index e097fb8..642681b 100644 --- a/src/list.h +++ b/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)); diff --git a/src/main.c b/src/main.c index 81f9062..81a3ece 100644 --- a/src/main.c +++ b/src/main.c @@ -3,11 +3,6 @@ #include -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; - while ((r = read(&s))) { - Feval(r, Qnil); - } + 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); diff --git a/src/print.c b/src/print.c index fe15278..5a2c8ad 100644 --- a/src/print.c +++ b/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: diff --git a/src/print.h b/src/print.h index 85fc8ff..d47f2b1 100644 --- a/src/print.h +++ b/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); diff --git a/src/stack.c b/src/stack.c index 18d334b..1401a6b 100644 --- a/src/stack.c +++ b/src/stack.c @@ -4,8 +4,10 @@ #include "hashtable.h" #include "list.h" #include "memory.h" +#include "print.h" #include +#include 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, - LispVal *exceptions) { +void push_condition_case_frame(jmp_buf *buf, 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) { - the_stack.unwind_info.set = true; - the_stack.unwind_info.cause = UNWIND_NORMAL; - the_stack.unwind_info.target = frame; - while (&the_stack.frames[the_stack.depth - 1] > frame) { +static bool frame_handles_exception(StackFrame *restrict 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) { 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); - case UNWIND_EXCEPTION: - // TODO implement + do_unwind_to(the_stack.unwind_info.target, NULL, NULL); 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(); +} diff --git a/src/stack.h b/src/stack.h index c3b71f6..9d4d747 100644 --- a/src/stack.h +++ b/src/stack.h @@ -2,7 +2,6 @@ #define INCLUDED_STACK_H #include "base.h" -#include "list.h" #include #include @@ -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, - LispVal *exceptions); +void push_condition_case_frame(jmp_buf *buf, LispVal *exceptions, size_t datum); // 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,8 +181,23 @@ 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); \ + } \ + }; + #endif