Zander671/glisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Exception handling

Browse Source
This commit is contained in:
Zander671
2026-09-03 09:34:54 -07:00
parent 07060a17fe
commit dc313fafa0
12 changed files with 209 additions and 96 deletions
Download Patch File Download Diff File Expand all files Collapse all files
lisp/kernel.gl
+5 -1
View File
@@ -1,3 +1,7 @@
;; -*- mode: lisp-data -*-
(error '("Hi"))
(fset 'test-fun (lambda (x)
(error (list x))))
(test-fun "hi")
src/base.c
+42 -37
View File
@@ -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) {
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))) {
static void check_handler_bind_handlers(LispVal *handlers) {
DOLIST(handler, handlers) {
CHECK_LISTP(handler);
if (!list_length_eq(handler, 2)) {
// TODO error
abort();
}
CHECK_TYPE(XCDR(handler), TYPE_FUNCTION);
if (LISTP(XCAR(handler))) {
// make sure each condition is a symbol
DOTAILS(rest, XCAR(handler)) {
CHECK_TYPE(XCAR(rest), TYPE_SYMBOL);
}
} else if (!SYMBOLP(XCAR(handler))) {
// if the condition is not a list or symbol, it's an error
// TODO type error
abort();
signal_type_error(XCAR(handler), LIST(Qsymbol, Qlist));
}
}
}
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);
DEFUN(handler_bind, "handler-bind", (LispVal * thunk, LispVal *handlers),
"(thunk &rest handlers)", "") {
check_handler_bind_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)) {
success_handler = XCDR(handler);
} else {
push_condition_case_frame(&jmp_target, XCAR(handler), idx);
}
handler_vec[idx] = XCDR(handler);
enabled_vec[idx] =
push_handler_bind_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;
return UNWIND_AND_RETURN(stack_ref, CALL0(thunk));
} else {
return Fprogn(success_handler);
size_t handler_idx = EXCEPTION_HANDLER_FRAME()->handler_bind.datum;
for (size_t i = 0; i < nhandlers; ++i) {
*enabled_vec[i] = false;
}
} else {
unwind_to(stack_ref);
if (!NILP(var)) {
push_copy_lexenv();
new_lexical_variable(var, CONS(EXCEPTION_NAME(), EXCEPTION_DATA()));
CALL(handler_vec[handler_idx],
CONS(EXCEPTION_NAME(), EXCEPTION_DATA()));
for (size_t i = 0; i < nhandlers; ++i) {
*enabled_vec[i] = true;
}
UNWIND_AND_RETURN(
stack_ref, Fprogn(XCDR(nth(EXCEPTION_HANDLER_DATUM(), handlers))));
continue_unwinding();
}
return Qnil;
}
DEFUN(error, "error", (LispVal * data), "(data)", "") {
src/base.h
+3 -3
View File
@@ -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,
(LispVal * var, LispVal *form, LispVal *handlers));
DECLARE_FUNCTION(handler_bind, (LispVal * thunk, LispVal *handlers));
DECLARE_FUNCTION(error, (LispVal * data));
MAKE_CONDITION_CLASS(error);
src/function.c
+2 -3
View File
@@ -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
+2 -1
View File
@@ -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
+2 -2
View File
@@ -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:
mark_object(frame->condition_case.exceptions);
case STACK_FRAME_HANDLER_BIND:
mark_object(frame->handler_bind.exceptions);
saturating_dec(limit, 1);
break;
case STACK_FRAME_DYNAMIC_BINDING:
src/gen-init-globals.awk
+1 -1
View File
@@ -28,7 +28,7 @@ BEGIN {
}
print ""
print "void register_globals() {"
print "void register_globals(void) {"
first_header = 1
}
src/list.c
+27 -1
View File
@@ -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
+4
View File
@@ -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 -2
View File
@@ -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
+61 -33
View File
@@ -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,
size_t datum) {
StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_CONDITION_CASE);
frame->condition_case.target = buf;
frame->condition_case.exceptions = exceptions;
frame->condition_case.datum = datum;
bool *push_handler_bind_frame(jmp_buf *buf, LispVal *exceptions, size_t datum) {
StackFrame *frame = PUSH_NEW_FRAME(STACK_FRAME_HANDLER_BIND);
frame->handler_bind.target = buf;
frame->handler_bind.exceptions = exceptions;
frame->handler_bind.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,
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) {
static void do_unwind_to(StackFrame *frame) {
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:
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_HANDLER_BIND:
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,
the_stack.unwind_info.exception.data);
do_run_handler_cases(the_stack.unwind_info.exception.name,
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
+42 -11
View File
@@ -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
void push_condition_case_frame(jmp_buf *buf, LispVal *exceptions, size_t datum);
// handler bind
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(); \
} \
};