initial exception handling support

This commit is contained in:
Yuichi Nishiwaki 2013-11-17 17:25:26 +09:00
parent 5668ae1b29
commit fdc9bfea4e
9 changed files with 203 additions and 1 deletions

18
include/picrin/error.h Normal file
View File

@ -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

View File

@ -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
};

View File

@ -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");
}
}

View File

@ -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);
}

View File

@ -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:

View File

@ -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);

View File

@ -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;
}

View File

@ -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;

11
t/exception.scm Normal file
View File

@ -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)))))))