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

Exceptions!!!

Browse Source
This commit is contained in:
Zander671
2026-09-02 01:54:14 -07:00
parent 17c11d90ea
commit 07060a17fe
13 changed files with 396 additions and 60 deletions
Download Patch File Download Diff File Expand all files Collapse all files
lisp/kernel.gl
+1 -5
View File
@@ -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"))
src/base.c
+130 -14
View File
@@ -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, ",@");
src/base.h
+34
View File
@@ -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
+25 -1
View File
@@ -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
+5
View File
@@ -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
+1 -4
View File
@@ -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
+39 -6
View File
@@ -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);
src/list.h
+9
View File
@@ -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
+13 -9
View File
@@ -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;
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);
src/print.c
+30 -3
View File
@@ -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
+5
View File
@@ -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
+65 -13
View File
@@ -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,
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();
}
src/stack.h
+39 -5
View File
@@ -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,
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