initial exception handling support
This commit is contained in:
parent
5668ae1b29
commit
fdc9bfea4e
|
@ -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
|
|
@ -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
|
||||
};
|
||||
|
|
|
@ -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");
|
||||
}
|
||||
}
|
||||
|
|
156
src/error.c
156
src/error.c
|
@ -2,6 +2,8 @@
|
|||
#include <stdio.h>
|
||||
|
||||
#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);
|
||||
}
|
||||
|
|
|
@ -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:
|
||||
|
|
9
src/gc.c
9
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 <stdio.h>
|
||||
|
@ -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);
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
|
@ -88,6 +88,9 @@ write(pic_state *pic, pic_value obj)
|
|||
}
|
||||
printf(")");
|
||||
break;
|
||||
case PIC_TT_ERROR:
|
||||
printf("#<error %p>", pic_ptr(obj));
|
||||
break;
|
||||
case PIC_TT_ENV:
|
||||
printf("#<env %p>", pic_env_ptr(obj));
|
||||
break;
|
||||
|
|
|
@ -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)))))))
|
Loading…
Reference in New Issue