diff --git a/include/picrin/error.h b/include/picrin/error.h new file mode 100644 index 00000000..dd773ffa --- /dev/null +++ b/include/picrin/error.h @@ -0,0 +1,18 @@ +#ifndef ERROR_H__ +#define ERROR_H__ + +struct pic_error { + PIC_OBJECT_HEADER + enum pic_error_kind { + PIC_ERROR_OTHER, + PIC_ERROR_FILE, + PIC_ERROR_READ + } type; + char *msg; + pic_value irrs; +}; + +#define pic_error_p(v) (pic_type(v) == PIC_TT_ERROR) +#define pic_error_ptr(v) ((struct pic_error *)pic_ptr(v)) + +#endif diff --git a/include/picrin/value.h b/include/picrin/value.h index e7c9bb81..42354c78 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -87,6 +87,7 @@ enum pic_tt { PIC_TT_BLOB, PIC_TT_PROC, PIC_TT_PORT, + PIC_TT_ERROR, PIC_TT_ENV, PIC_TT_CONT }; diff --git a/src/codegen.c b/src/codegen.c index 7022ae5e..04284522 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -640,7 +640,8 @@ codegen(codegen_state *state, pic_value obj, bool tailpos) case PIC_TT_PROC: case PIC_TT_UNDEF: case PIC_TT_EOF: - case PIC_TT_PORT: { + case PIC_TT_PORT: + case PIC_TT_ERROR: { pic_error(pic, "invalid expression given"); } } diff --git a/src/error.c b/src/error.c index 517a4089..7f98508a 100644 --- a/src/error.c +++ b/src/error.c @@ -2,6 +2,8 @@ #include #include "picrin.h" +#include "picrin/proc.h" +#include "picrin/error.h" void pic_error(pic_state *pic, const char *msg) @@ -32,3 +34,157 @@ pic_warn(pic_state *pic, const char *msg) { fprintf(stderr, "warn: %s\n", msg); } + +void +pic_raise(pic_state *pic, pic_value obj) +{ + pic_value a; + struct pic_proc *handler; + + if (pic->ridx == 0) { + pic_abort(pic, "logic flaw: no exception handler remains"); + } + + handler = pic->rescue[--pic->ridx]; + pic_gc_protect(pic, pic_obj_value(handler)); + + a = pic_apply_argv(pic, handler, 1, obj); + /* when the handler returns */ + pic_errorf(pic, "handler returned", 2, pic_obj_value(handler), a); +} + +static pic_value +pic_error_with_exception_handler(pic_state *pic) +{ + pic_value v, w; + struct pic_proc *handler, *thunk; + + pic_get_args(pic, "oo", &v, &w); + + if (! pic_proc_p(v)){ + pic_error(pic, "expected procedure"); + } + handler = pic_proc_ptr(v); + + if (! pic_proc_p(v)) { + pic_error(pic, "expected procedure"); + } + thunk = pic_proc_ptr(w); + + if (pic->ridx >= pic->rlen) { + pic->rescue = (struct pic_proc **)pic_realloc(pic, pic->rescue, pic->rlen * 2); + pic->rlen *= 2; + } + pic->rescue[pic->ridx++] = handler; + + v = pic_apply_argv(pic, thunk, 0); + pic->ridx--; + return v; +} + +static pic_value +pic_error_raise(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + pic_raise(pic, v); + + /* the function never returns */ + return pic_undef_value(); +} + +static pic_value +pic_error_raise_continuable(pic_state *pic) +{ + pic_value v, a; + struct pic_proc *handler; + + pic_get_args(pic, "o", &v); + + if (pic->ridx == 0) { + pic_abort(pic, "logic flaw: no exception handler remains"); + } + + handler = pic->rescue[--pic->ridx]; + a = pic_apply_argv(pic, handler, 1, v); + pic->rescue[pic->ridx++] = handler; + + return a; +} + +static pic_value +pic_error_error_object_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + return pic_bool_value(pic_error_p(v)); +} + +static pic_value +pic_error_error_object_message(pic_state *pic) +{ + struct pic_error *e; + + pic_get_args(pic, "e", &e); + + return pic_str_new_cstr(pic, e->msg); +} + +static pic_value +pic_error_error_object_irritants(pic_state *pic) +{ + struct pic_error *e; + + pic_get_args(pic, "e", &e); + + return e->irrs; +} + +static pic_value +pic_error_read_error_p(pic_state *pic) +{ + pic_value v; + struct pic_error *e; + + pic_get_args(pic, "o", &v); + + if (! pic_error_p(v)) { + return pic_false_value(); + } + + e = pic_error_ptr(v); + return pic_bool_value(e->type == PIC_ERROR_READ); +} + +static pic_value +pic_error_file_error_p(pic_state *pic) +{ + pic_value v; + struct pic_error *e; + + pic_get_args(pic, "o", &v); + + if (! pic_error_p(v)) { + return pic_false_value(); + } + + e = pic_error_ptr(v); + return pic_bool_value(e->type == PIC_ERROR_FILE); +} + +void +pic_init_error(pic_state *pic) +{ + pic_defun(pic, "with-exception-handler", pic_error_with_exception_handler); + pic_defun(pic, "raise", pic_error_raise); + pic_defun(pic, "raise-continuable", pic_error_raise_continuable); + pic_defun(pic, "error-object?", pic_error_error_object_p); + pic_defun(pic, "error-object-message", pic_error_error_object_message); + pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants); + pic_defun(pic, "read-error?", pic_error_read_error_p); + pic_defun(pic, "file-error?", pic_error_file_error_p); +} diff --git a/src/expand.c b/src/expand.c index 18052bd0..9c99dba2 100644 --- a/src/expand.c +++ b/src/expand.c @@ -147,6 +147,7 @@ expand(pic_state *pic, pic_value obj, struct syntactic_env *env) } case PIC_TT_PROC: case PIC_TT_PORT: + case PIC_TT_ERROR: case PIC_TT_ENV: case PIC_TT_CONT: case PIC_TT_UNDEF: diff --git a/src/gc.c b/src/gc.c index 9213ff7b..7c907e87 100644 --- a/src/gc.c +++ b/src/gc.c @@ -7,6 +7,7 @@ #include "picrin/port.h" #include "picrin/blob.h" #include "picrin/cont.h" +#include "picrin/error.h" #if GC_DEBUG # include @@ -207,6 +208,10 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) case PIC_TT_PORT: { break; } + case PIC_TT_ERROR: { + gc_mark(pic, ((struct pic_error *)obj)->irrs); + break; + } case PIC_TT_STRING: { break; } @@ -363,6 +368,10 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) } break; } + case PIC_TT_ERROR: { + pic_free(pic, ((struct pic_error *)obj)->msg); + break; + } case PIC_TT_CONT: { struct pic_cont *cont = (struct pic_cont *)obj; pic_free(pic, cont->stk_ptr); diff --git a/src/init.c b/src/init.c index 7f3680e1..20a44e39 100644 --- a/src/init.c +++ b/src/init.c @@ -17,6 +17,7 @@ void pic_init_vector(pic_state *); void pic_init_blob(pic_state *); void pic_init_cont(pic_state *); void pic_init_char(pic_state *); +void pic_init_error(pic_state *); void pic_load_stdlib(pic_state *pic) @@ -83,6 +84,7 @@ pic_init_core(pic_state *pic) pic_init_blob(pic); DONE; pic_init_cont(pic); DONE; pic_init_char(pic); DONE; + pic_init_error(pic); DONE; pic_load_stdlib(pic); DONE; } diff --git a/src/port.c b/src/port.c index 2e17c8be..0c3709fd 100644 --- a/src/port.c +++ b/src/port.c @@ -88,6 +88,9 @@ write(pic_state *pic, pic_value obj) } printf(")"); break; + case PIC_TT_ERROR: + printf("#", pic_ptr(obj)); + break; case PIC_TT_ENV: printf("#", pic_env_ptr(obj)); break; diff --git a/t/exception.scm b/t/exception.scm new file mode 100644 index 00000000..8c96a373 --- /dev/null +++ b/t/exception.scm @@ -0,0 +1,11 @@ +(write + (call/cc + (lambda (k) + (with-exception-handler + (lambda (x) + (write "condition: ") + (write x) + (newline) + (k 'exception)) + (lambda () + (+ 1 (raise 'an-error)))))))