diff --git a/lisp/kernel.gl b/lisp/kernel.gl index cbe6319..fd8ce7f 100644 --- a/lisp/kernel.gl +++ b/lisp/kernel.gl @@ -1,3 +1,7 @@ ;; -*- mode: lisp-data -*- -(error '("Hi")) +(fset 'test-fun (lambda (x) + (error (list x)))) + +(test-fun "hi") + diff --git a/src/base.c b/src/base.c index 045a8dd..c3b8178 100644 --- a/src/base.c +++ b/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) { - DOTAILS(rest, handlers) { - LispVal *handler = XCAR(rest); - if (ATOM(handler)) { - // TODO type error +static void check_handler_bind_handlers(LispVal *handlers) { + DOLIST(handler, handlers) { + CHECK_LISTP(handler); + if (!list_length_eq(handler, 2)) { + // 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))) { - // TODO error - abort(); - } + 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; - } else { - return Fprogn(success_handler); - } + return UNWIND_AND_RETURN(stack_ref, CALL0(thunk)); } else { - unwind_to(stack_ref); - if (!NILP(var)) { - push_copy_lexenv(); - new_lexical_variable(var, CONS(EXCEPTION_NAME(), EXCEPTION_DATA())); + size_t handler_idx = EXCEPTION_HANDLER_FRAME()->handler_bind.datum; + for (size_t i = 0; i < nhandlers; ++i) { + *enabled_vec[i] = false; } - UNWIND_AND_RETURN( - stack_ref, Fprogn(XCDR(nth(EXCEPTION_HANDLER_DATUM(), handlers)))); + CALL(handler_vec[handler_idx], + 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)", "") { diff --git a/src/base.h b/src/base.h index a01699b..7bde8b9 100644 --- a/src/base.h +++ b/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, - (LispVal * var, LispVal *form, LispVal *handlers)); +DECLARE_FUNCTION(handler_bind, (LispVal * thunk, LispVal *handlers)); DECLARE_FUNCTION(error, (LispVal * data)); MAKE_CONDITION_CLASS(error); diff --git a/src/function.c b/src/function.c index ef560a9..9a8a0d1 100644 --- a/src/function.c +++ b/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; diff --git a/src/function.h b/src/function.h index d68c11c..c1b4439 100644 --- a/src/function.h +++ b/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)); diff --git a/src/gc.c b/src/gc.c index bb1ea79..18ff647 100644 --- a/src/gc.c +++ b/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: - 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: diff --git a/src/gen-init-globals.awk b/src/gen-init-globals.awk index d4c308d..b74b223 100644 --- a/src/gen-init-globals.awk +++ b/src/gen-init-globals.awk @@ -28,7 +28,7 @@ BEGIN { } print "" - print "void register_globals() {" + print "void register_globals(void) {" first_header = 1 } diff --git a/src/list.c b/src/list.c index 4299db6..56e8537 100644 --- a/src/list.c +++ b/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); } diff --git a/src/list.h b/src/list.h index 642681b..f86e21f 100644 --- a/src/list.h +++ b/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)); diff --git a/src/main.c b/src/main.c index 81a3ece..4eb38aa 100644 --- a/src/main.c +++ b/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; } diff --git a/src/stack.c b/src/stack.c index 1401a6b..be384f3 100644 --- a/src/stack.c +++ b/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, - 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; +} diff --git a/src/stack.h b/src/stack.h index 9d4d747..430519e 100644 --- a/src/stack.h +++ b/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 -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(); \ } \ };