conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'refactor-error'

This commit is contained in:
Yuichi Nishiwaki 2014-03-24 16:06:13 +09:00
parent 2246213a74 bccfc1f08d
commit b95184431f
10 changed files with 98 additions and 226 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
README.md
View File

@ -117,7 +117,7 @@ Picrin is a lightweight scheme implementation intended to comply with full R7RS
| 6.8 Vectors | yes | |
| 6.9 Bytevectors | yes | |
| 6.10 Control features | yes | |
| 6.11 Exceptions | yes | |
| 6.11 Exceptions | yes | `raise-continuable` is not supported |
| 6.12 Environments and evaluation | N/A | |
| 6.13.1 Ports | yes | |
| 6.13.2 Input | incomplete | TODO: binary input |

13
include/picrin.h
View File

@ -77,9 +77,6 @@ typedef struct {
pic_code *ip;
struct pic_proc **rescue;
size_t ridx, rlen;
pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG;
pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING;
pic_sym sDEFINE_SYNTAX, sDEFINE_MACRO;
@ -124,7 +121,7 @@ struct pic_object *pic_obj_alloc_unsafe(pic_state *, size_t, enum pic_tt);
void pic_free(pic_state *, void *);
void pic_gc_run(pic_state *);
void pic_gc_protect(pic_state *, pic_value);
pic_value pic_gc_protect(pic_state *, pic_value);
int pic_gc_arena_preserve(pic_state *);
void pic_gc_arena_restore(pic_state *, int);
@ -180,11 +177,15 @@ void pic_import(pic_state *, pic_value);
void pic_export(pic_state *, pic_sym);
noreturn void pic_abort(pic_state *, const char *);
noreturn void pic_raise(pic_state *, struct pic_error *);
noreturn void pic_error(pic_state *, const char *); /* obsoleted */
noreturn void pic_errorf(pic_state *, const char *, ...);
void pic_warn(pic_state *, const char *);
/* obsoleted */
noreturn static inline void pic_error(pic_state *pic, const char *msg)
{
pic_errorf(pic, msg);
}
const char *pic_errmsg(pic_state *);
pic_value pic_write(pic_state *, pic_value); /* returns given obj */

3
include/picrin/cont.h
View File

@ -26,9 +26,6 @@ struct pic_cont {
pic_code *ip;
struct pic_proc **rescue;
size_t ridx, rlen;
struct pic_object *arena[PIC_ARENA_SIZE];
int arena_idx;

6
include/picrin/error.h
View File

@ -15,6 +15,8 @@ struct pic_jmpbuf {
struct pic_jmpbuf *prev;
};
/* do not return from try block! */
#define pic_try \
pic_push_try(pic); \
if (setjmp(*pic->jmp) == 0) \
@ -27,6 +29,8 @@ struct pic_jmpbuf {
void pic_push_try(pic_state *);
void pic_pop_try(pic_state *);
noreturn void pic_throw(pic_state *, struct pic_error *);
struct pic_error {
PIC_OBJECT_HEADER
enum pic_error_kind {
@ -42,8 +46,6 @@ struct pic_error {
#define pic_error_p(v) (pic_type(v) == PIC_TT_ERROR)
#define pic_error_ptr(v) ((struct pic_error *)pic_ptr(v))
pic_value pic_raise_continuable(pic_state *, pic_value);
#if defined(__cplusplus)
}
#endif

10
src/cont.c
View File

@ -119,11 +119,6 @@ save_cont(pic_state *pic, struct pic_cont **c)
cont->ip = pic->ip;
cont->ridx = pic->ridx;
cont->rlen = pic->rlen;
cont->rescue = (struct pic_proc **)pic_alloc(pic, sizeof(struct pic_proc *) * cont->rlen);
memcpy(cont->rescue, pic->rescue, sizeof(struct pic_proc *) * cont->rlen);
cont->arena_idx = pic->arena_idx;
memcpy(cont->arena, pic->arena, sizeof(struct pic_object *) * PIC_ARENA_SIZE);
@ -168,11 +163,6 @@ restore_cont(pic_state *pic, struct pic_cont *cont)
pic->ip = cont->ip;
pic->rescue = (struct pic_proc **)pic_realloc(pic, pic->rescue, sizeof(struct pic_proc *) * cont->rlen);
memcpy(pic->rescue, cont->rescue, sizeof(struct pic_object *) * cont->rlen);
pic->ridx = cont->ridx;
pic->rlen = cont->rlen;
memcpy(pic->arena, cont->arena, sizeof(struct pic_object *) * PIC_ARENA_SIZE);
pic->arena_idx = cont->arena_idx;

141
src/error.c
View File

@ -11,6 +11,24 @@
#include "picrin/string.h"
#include "picrin/error.h"
void
pic_abort(pic_state *pic, const char *msg)
{
UNUSED(pic);
fprintf(stderr, "abort: %s\n", msg);
fflush(stderr);
abort();
}
void
pic_warn(pic_state *pic, const char *msg)
{
UNUSED(pic);
fprintf(stderr, "warn: %s\n", msg);
}
void
pic_push_try(pic_state *pic)
{
@ -39,16 +57,8 @@ pic_pop_try(pic_state *pic)
pic->try_jmps = prev;
}
const char *
pic_errmsg(pic_state *pic)
{
assert(pic->err != NULL);
return pic_str_cstr(pic->err->msg);
}
noreturn static void
raise(pic_state *pic, struct pic_error *e)
noreturn void
pic_throw(pic_state *pic, struct pic_error *e)
{
pic->err = e;
if (! pic->jmp) {
@ -58,23 +68,12 @@ raise(pic_state *pic, struct pic_error *e)
longjmp(*pic->jmp, 1);
}
noreturn static void
error(pic_state *pic, pic_str *msg, pic_value irrs)
const char *
pic_errmsg(pic_state *pic)
{
struct pic_error *e;
assert(pic->err != NULL);
e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR);
e->type = PIC_ERROR_OTHER;
e->msg = msg;
e->irrs = irrs;
raise(pic, e);
}
void
pic_error(pic_state *pic, const char *msg)
{
pic_errorf(pic, msg);
return pic_str_cstr(pic->err->msg);
}
void
@ -82,64 +81,18 @@ pic_errorf(pic_state *pic, const char *fmt, ...)
{
va_list ap;
pic_value err_line;
struct pic_error *e;
va_start(ap, fmt);
err_line = pic_vformat(pic, fmt, ap);
va_end(ap);
error(pic, pic_str_ptr(pic_car(pic, err_line)), pic_cdr(pic, err_line));
}
e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR);
e->type = PIC_ERROR_OTHER;
e->msg = pic_str_ptr(pic_car(pic, err_line));
e->irrs = pic_cdr(pic, err_line);
void
pic_abort(pic_state *pic, const char *msg)
{
UNUSED(pic);
fprintf(stderr, "abort: %s\n", msg);
fflush(stderr);
abort();
}
void
pic_warn(pic_state *pic, const char *msg)
{
UNUSED(pic);
fprintf(stderr, "warn: %s\n", msg);
}
void
pic_raise(pic_state *pic, struct pic_error *e)
{
pic_value a;
struct pic_proc *handler;
if (pic->ridx == 0) {
raise(pic, e);
}
handler = pic->rescue[--pic->ridx];
pic_gc_protect(pic, pic_obj_value(handler));
a = pic_apply_argv(pic, handler, 1, pic_obj_value(e));
/* when the handler returns */
pic_errorf(pic, "handler returned", 2, pic_obj_value(handler), a);
}
pic_value
pic_raise_continuable(pic_state *pic, pic_value obj)
{
struct pic_proc *handler;
if (pic->ridx == 0) {
pic_abort(pic, "logic flaw: no exception handler remains");
}
handler = pic->rescue[--pic->ridx];
obj = pic_apply_argv(pic, handler, 1, obj);
pic->rescue[pic->ridx++] = handler;
return obj;
pic_throw(pic, e);
}
static pic_value
@ -150,19 +103,16 @@ pic_error_with_exception_handler(pic_state *pic)
pic_get_args(pic, "ll", &handler, &thunk);
if (pic->ridx >= pic->rlen) {
#if DEBUG
puts("rescue realloced");
#endif
pic->rlen *= 2;
pic->rescue = (struct pic_proc **)pic_realloc(pic, pic->rescue, sizeof(struct pic_proc *) * pic->rlen);
pic_try {
v = pic_apply_argv(pic, thunk, 0);
}
pic->rescue[pic->ridx++] = handler;
pic_catch {
struct pic_error *e = pic->err;
v = pic_apply_argv(pic, thunk, 0);
pic->ridx--;
pic->err = NULL;
v = pic_apply_argv(pic, handler, 1, pic_obj_value(e));
pic_errorf(pic, "error handler returned ~s, by error ~s", v, pic_obj_value(e));
}
return v;
}
@ -179,17 +129,7 @@ pic_error_raise(pic_state *pic)
e->msg = pic_str_new_cstr(pic, "raised");
e->irrs = pic_list1(pic, v);
pic_raise(pic, e);
}
static pic_value
pic_error_raise_continuable(pic_state *pic)
{
pic_value obj;
pic_get_args(pic, "o", &obj);
return pic_raise_continuable(pic, obj);
pic_throw(pic, e);
}
noreturn static pic_value
@ -207,7 +147,7 @@ pic_error_error(pic_state *pic)
e->msg = str;
e->irrs = pic_list_by_array(pic, argc, argv);
pic_raise(pic, e);
pic_throw(pic, e);
}
static pic_value
@ -277,7 +217,6 @@ 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", pic_error_error);
pic_defun(pic, "error-object?", pic_error_error_object_p);
pic_defun(pic, "error-object-message", pic_error_error_object_message);

24
src/gc.c
View File

@ -183,17 +183,19 @@ gc_protect(pic_state *pic, struct pic_object *obj)
pic->arena[pic->arena_idx++] = obj;
}
void
pic_value
pic_gc_protect(pic_state *pic, pic_value v)
{
struct pic_object *obj;
if (pic_vtype(v) != PIC_VTYPE_HEAP) {
return;
return v;
}
obj = pic_obj_ptr(v);
gc_protect(pic, obj);
return v;
}
int
@ -406,8 +408,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
struct pic_cont *cont = (struct pic_cont *)obj;
pic_value *stack;
pic_callinfo *ci;
size_t i;
int j;
int i;
/* block */
gc_mark_block(pic, cont->blk);
@ -424,14 +425,9 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
}
}
/* exception handlers */
for (i = 0; i < cont->ridx; ++i) {
gc_mark_object(pic, (struct pic_object *)cont->rescue[i]);
}
/* arena */
for (j = 0; j < cont->arena_idx; ++j) {
gc_mark_object(pic, cont->arena[j]);
for (i = 0; i < cont->arena_idx; ++i) {
gc_mark_object(pic, cont->arena[i]);
}
/* result values */
@ -537,11 +533,6 @@ gc_mark_phase(pic_state *pic)
}
}
/* exception handlers */
for (i = 0; i < pic->ridx; ++i) {
gc_mark_object(pic, (struct pic_object *)pic->rescue[i]);
}
/* error object */
if (pic->err) {
gc_mark_object(pic, (struct pic_object *)pic->err);
@ -608,7 +599,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
pic_free(pic, cont->stk_ptr);
pic_free(pic, cont->st_ptr);
pic_free(pic, cont->ci_ptr);
pic_free(pic, cont->rescue);
PIC_BLK_DECREF(pic, cont->blk);
break;
}

85
src/macro.c
View File

@ -224,17 +224,10 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
pic_in_library(pic, pic_cadr(pic, expr));
pic_for_each (v, pic_cddr(pic, expr)) {
struct pic_proc *proc;
int ai = pic_gc_arena_preserve(pic);
proc = pic_compile(pic, v);
if (proc == NULL) {
abort();
}
pic_apply_argv(pic, proc, 0);
if (pic_undef_p(v)) {
abort();
}
pic_eval(pic, v);
pic_gc_arena_restore(pic, ai);
}
@ -243,7 +236,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
pic_catch {
/* restores pic->lib even if an error occurs */
pic_in_library(pic, prev->name);
longjmp(*pic->jmp, 1);
pic_throw(pic, pic->err);
}
return pic_none_value();
@ -271,7 +264,6 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
else if (tag == pic->sDEFINE_SYNTAX) {
pic_value var, val;
struct pic_proc *proc;
pic_sym uniq;
struct pic_macro *mac;
@ -290,17 +282,16 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
xh_put_int(senv->name, pic_sym(var), uniq);
val = pic_cadr(pic, pic_cdr(pic, expr));
proc = pic_compile(pic, val);
if (pic->err) {
printf("macroexpand error: %s\n", pic_errmsg(pic));
abort();
}
v = pic_apply(pic, proc, pic_nil_value());
if (pic->err) {
printf("macroexpand error: %s\n", pic_errmsg(pic));
abort();
}
assert(pic_proc_p(v));
pic_try {
v = pic_eval(pic, val);
} pic_catch {
pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
}
if (! pic_proc_p(v)) {
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
}
mac = macro_new(pic, pic_proc_ptr(v), senv);
xh_put_int(pic->macros, uniq, (long)mac);
@ -311,7 +302,6 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
else if (tag == pic->sDEFINE_MACRO) {
pic_value var, val;
struct pic_proc *proc;
pic_sym uniq;
struct pic_macro *mac;
@ -339,17 +329,15 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
uniq = pic_gensym(pic, pic_sym(var));
xh_put_int(senv->name, pic_sym(var), uniq);
proc = pic_compile(pic, val);
if (pic->err) {
printf("macroexpand error: %s\n", pic_errmsg(pic));
abort();
}
v = pic_apply(pic, proc, pic_nil_value());
if (pic->err) {
printf("macroexpand error: %s\n", pic_errmsg(pic));
abort();
}
assert(pic_proc_p(v));
pic_try {
v = pic_eval(pic, val);
} pic_catch {
pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
}
if (! pic_proc_p(v)) {
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
}
mac = macro_new(pic, pic_proc_ptr(v), NULL);
xh_put_int(pic->macros, uniq, (long)mac);
@ -441,7 +429,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
/* macro */
if ((e = xh_get_int(pic->macros, tag)) != NULL) {
pic_value v;
pic_value v, args;
struct pic_macro *mac;
#if DEBUG
@ -452,19 +440,17 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
mac = (struct pic_macro *)e->val;
if (mac->senv == NULL) { /* legacy macro */
v = pic_apply(pic, mac->proc, pic_cdr(pic, expr));
if (pic->err) {
printf("macroexpand error: %s\n", pic_errmsg(pic));
abort();
}
}
else {
v = pic_apply_argv(pic, mac->proc, 3, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
if (pic->err) {
printf("macroexpand error: %s\n", pic_errmsg(pic));
abort();
}
}
args = pic_cdr(pic, expr);
}
else {
args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
}
pic_try {
v = pic_apply(pic, mac->proc, args);
} pic_catch {
pic_errorf(pic, "macroexpand error: %s", pic_errmsg(pic));
}
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, v);
@ -508,8 +494,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
pic_error(pic, "unexpected value type");
return pic_undef_value(); /* unreachable */
}
/* suppress warnings, never be called */
abort();
UNREACHABLE();
}
static pic_value

7
src/state.c
View File

@ -42,11 +42,6 @@ pic_open(int argc, char *argv[], char **envp)
pic->cibase = pic->ci = (pic_callinfo *)calloc(PIC_STACK_SIZE, sizeof(pic_callinfo));
pic->ciend = pic->cibase + PIC_STACK_SIZE;
/* exception handlers */
pic->rescue = (struct pic_proc **)calloc(PIC_RESCUE_SIZE, sizeof(struct pic_proc *));
pic->ridx = 0;
pic->rlen = PIC_RESCUE_SIZE;
/* memory heap */
pic->heap = pic_heap_open();
@ -136,7 +131,6 @@ pic_close(pic_state *pic)
/* clear out root objects */
pic->sp = pic->stbase;
pic->ci = pic->cibase;
pic->ridx = 0;
pic->arena_idx = 0;
pic->err = NULL;
pic->glen = 0;
@ -152,7 +146,6 @@ pic_close(pic_state *pic)
/* free runtime context */
free(pic->stbase);
free(pic->cibase);
free(pic->rescue);
/* free global stacks */
free(pic->globals);

33
src/vm.c
View File

@ -18,6 +18,7 @@
#include "picrin/var.h"
#include "picrin/lib.h"
#include "picrin/macro.h"
#include "picrin/error.h"
#define GET_OPERAND(pic,n) ((pic)->ci->fp[(n)])
@ -499,7 +500,6 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
{
pic_code c;
int ai = pic_gc_arena_preserve(pic);
jmp_buf jmp, *prev_jmp = pic->jmp;
size_t argc, i;
pic_code boot[2];
@ -515,13 +515,6 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
};
#endif
if (setjmp(jmp) == 0) {
pic->jmp = &jmp;
}
else {
goto L_RAISE;
}
if (! pic_list_p(argv)) {
pic_error(pic, "argv must be a proper list");
}
@ -773,12 +766,6 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
pic_value *retv;
pic_callinfo *ci;
if (pic->err) {
L_RAISE:
goto L_STOP;
}
if (pic->ci->env != NULL) {
vm_tear_off(pic);
}
@ -918,7 +905,6 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
} \
else { \
pic_error(pic, #op " got non-number operands"); \
goto L_RAISE; \
} \
NEXT; \
}
@ -928,21 +914,12 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
DEFINE_COMP_OP(OP_LE, <=);
CASE(OP_STOP) {
pic_value val;
L_STOP:
val = POP();
pic->jmp = prev_jmp;
if (pic->err) {
longjmp(*pic->jmp, 1);
}
#if VM_DEBUG
puts("**VM END STATE**");
printf("stbase\t= %p\nsp\t= %p\n", (void *)stbase, (void *)pic->sp);
printf("cibase\t= %p\nci\t= %p\n", (void *)cibase, (void *)pic->ci);
if (stbase < pic->sp) {
if (stbase < pic->sp - 1) {
pic_value *sp;
printf("* stack trace:");
for (sp = stbase; pic->sp != sp; ++sp) {
@ -950,14 +927,12 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
puts("");
}
}
if (stbase > pic->sp) {
if (stbase > pic->sp - 1) {
puts("*** stack underflow!");
}
#endif
pic_gc_protect(pic, val);
return val;
return pic_gc_protect(pic, POP());
}
} VM_LOOP_END;
}