Merge branch 'exception-handling-and-dynamic-wind'

cont.c

@@ -121,7 +121,7 @@ save_cont(pic_state *pic, struct pic_cont **c)
 
   cont = *c = (struct pic_cont *)pic_obj_alloc(pic, sizeof(struct pic_cont), PIC_TT_CONT);
 
-  cont->blk = pic->blk;
+  cont->wind = pic->wind;
 
   cont->stk_len = native_stack_length(pic, &pos);
   cont->stk_pos = pos;
@@ -131,14 +131,19 @@ save_cont(pic_state *pic, struct pic_cont **c)
 
   cont->sp_offset = pic->sp - pic->stbase;
   cont->st_len = pic->stend - pic->stbase;
-  cont->st_ptr = (pic_value *)pic_alloc(pic, sizeof(pic_value) * cont->st_len);
+  cont->st_ptr = pic_alloc(pic, sizeof(pic_value) * cont->st_len);
   memcpy(cont->st_ptr, pic->stbase, sizeof(pic_value) * cont->st_len);
 
   cont->ci_offset = pic->ci - pic->cibase;
   cont->ci_len = pic->ciend - pic->cibase;
-  cont->ci_ptr = (pic_callinfo *)pic_alloc(pic, sizeof(pic_callinfo) * cont->ci_len);
+  cont->ci_ptr = pic_alloc(pic, sizeof(pic_callinfo) * cont->ci_len);
   memcpy(cont->ci_ptr, pic->cibase, sizeof(pic_callinfo) * cont->ci_len);
 
+  cont->xp_offset = pic->xp - pic->xpbase;
+  cont->xp_len = pic->xpend - pic->xpbase;
+  cont->xp_ptr = pic_alloc(pic, sizeof(struct pic_proc *) * cont->xp_len);
+  memcpy(cont->xp_ptr, pic->xpbase, sizeof(struct pic_proc *) * cont->xp_len);
+
   cont->ip = pic->ip;
 
   cont->arena_idx = pic->arena_idx;
@@ -146,11 +151,6 @@ save_cont(pic_state *pic, struct pic_cont **c)
   cont->arena = (struct pic_object **)pic_alloc(pic, sizeof(struct pic_object *) * pic->arena_size);
   memcpy(cont->arena, pic->arena, sizeof(struct pic_object *) * pic->arena_size);
 
-  cont->try_jmp_idx = pic->try_jmp_idx;
-  cont->try_jmp_size = pic->try_jmp_size;
-  cont->try_jmps = pic_alloc(pic, sizeof(struct pic_jmpbuf) * pic->try_jmp_size);
-  memcpy(cont->try_jmps, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size);
-
   cont->results = pic_undef_value();
 }
 
@@ -168,7 +168,6 @@ restore_cont(pic_state *pic, struct pic_cont *cont)
 {
   char v;
   struct pic_cont *tmp = cont;
-  struct pic_block *blk;
 
   if (&v < pic->native_stack_start) {
     if (&v > cont->stk_pos) native_stack_extend(pic, cont);
@@ -177,19 +176,23 @@ restore_cont(pic_state *pic, struct pic_cont *cont)
     if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont);
   }
 
-  blk = pic->blk;
+  pic->wind = cont->wind;
-  pic->blk = cont->blk;
 
-  pic->stbase = (pic_value *)pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len);
+  pic->stbase = pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len);
   memcpy(pic->stbase, cont->st_ptr, sizeof(pic_value) * cont->st_len);
   pic->sp = pic->stbase + cont->sp_offset;
   pic->stend = pic->stbase + cont->st_len;
 
-  pic->cibase = (pic_callinfo *)pic_realloc(pic, pic->cibase, sizeof(pic_callinfo) * cont->ci_len);
+  pic->cibase = pic_realloc(pic, pic->cibase, sizeof(pic_callinfo) * cont->ci_len);
   memcpy(pic->cibase, cont->ci_ptr, sizeof(pic_callinfo) * cont->ci_len);
   pic->ci = pic->cibase + cont->ci_offset;
   pic->ciend = pic->cibase + cont->ci_len;
 
+  pic->xpbase = pic_realloc(pic, pic->xpbase, sizeof(struct pic_proc *) * cont->xp_len);
+  memcpy(pic->xpbase, cont->xp_ptr, sizeof(struct pic_proc *) * cont->xp_len);
+  pic->xp = pic->xpbase + cont->xp_offset;
+  pic->xpend = pic->xpbase + cont->xp_len;
+
   pic->ip = cont->ip;
 
   pic->arena = (struct pic_object **)pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * cont->arena_size);
@@ -197,52 +200,47 @@ restore_cont(pic_state *pic, struct pic_cont *cont)
   pic->arena_size = cont->arena_size;
   pic->arena_idx = cont->arena_idx;
 
-  pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size);
-  memcpy(pic->try_jmps, cont->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size);
-  pic->try_jmp_size = cont->try_jmp_size;
-  pic->try_jmp_idx = cont->try_jmp_idx;
-
   memcpy(cont->stk_pos, cont->stk_ptr, cont->stk_len);
 
   longjmp(tmp->jmp, 1);
 }
 
-static void
+void
-walk_to_block(pic_state *pic, struct pic_block *here, struct pic_block *there)
+pic_wind(pic_state *pic, struct pic_winder *here, struct pic_winder *there)
 {
   if (here == there)
     return;
 
   if (here->depth < there->depth) {
-    walk_to_block(pic, here, there->prev);
+    pic_wind(pic, here, there->prev);
     pic_apply0(pic, there->in);
   }
   else {
     pic_apply0(pic, there->out);
-    walk_to_block(pic, here->prev, there);
+    pic_wind(pic, here->prev, there);
   }
 }
 
 static pic_value
 pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out)
 {
-  struct pic_block *here;
+  struct pic_winder *here;
   pic_value val;
 
   if (in != NULL) {
     pic_apply0(pic, in);        /* enter */
   }
 
-  here = pic->blk;
+  here = pic->wind;
-  pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK);
+  pic->wind = pic_alloc(pic, sizeof(struct pic_winder));
-  pic->blk->prev = here;
+  pic->wind->prev = here;
-  pic->blk->depth = here->depth + 1;
+  pic->wind->depth = here->depth + 1;
-  pic->blk->in = in;
+  pic->wind->in = in;
-  pic->blk->out = out;
+  pic->wind->out = out;
 
   val = pic_apply0(pic, thunk);
 
-  pic->blk = here;
+  pic->wind = here;
 
   if (out != NULL) {
     pic_apply0(pic, out);       /* exit */
@@ -266,7 +264,7 @@ cont_call(pic_state *pic)
   cont->results = pic_list_by_array(pic, argc, argv);
 
   /* execute guard handlers */
-  walk_to_block(pic, pic->blk, cont->blk);
+  pic_wind(pic, pic->wind, cont->wind);
 
   restore_cont(pic, cont);
 }

error.c

@@ -8,6 +8,8 @@
 
 #include "picrin.h"
 #include "picrin/pair.h"
+#include "picrin/proc.h"
+#include "picrin/cont.h"
 #include "picrin/string.h"
 #include "picrin/error.h"
 
@@ -34,41 +36,94 @@ pic_warnf(pic_state *pic, const char *fmt, ...)
 }
 
 void
-pic_push_try(pic_state *pic, struct pic_proc *handler)
+pic_errorf(pic_state *pic, const char *fmt, ...)
 {
-  struct pic_jmpbuf *try_jmp;
+  va_list ap;
+  pic_value err_line, irrs;
+  const char *msg;
 
-  if (pic->try_jmp_idx >= pic->try_jmp_size) {
+  va_start(ap, fmt);
-    pic->try_jmp_size *= 2;
+  err_line = pic_xvformat(pic, fmt, ap);
-    pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size);
+  va_end(ap);
+
+  msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line)));
+  irrs = pic_cdr(pic, err_line);
+
+  pic_error(pic, msg, irrs);
+}
+
+const char *
+pic_errmsg(pic_state *pic)
+{
+  pic_str *str;
+
+  assert(! pic_undef_p(pic->err));
+
+  if (! pic_error_p(pic->err)) {
+    str = pic_format(pic, "~s", pic->err);
+  } else {
+    str = pic_error_ptr(pic->err)->msg;
   }
 
-  try_jmp = pic->try_jmps + pic->try_jmp_idx++;
+  return pic_str_cstr(str);
+}
 
-  try_jmp->handler = handler;
+static pic_value
+native_exception_handler(pic_state *pic)
+{
+  pic_value err;
+  struct pic_proc *cont;
 
-  try_jmp->ci_offset = pic->ci - pic->cibase;
+  pic_get_args(pic, "o", &err);
-  try_jmp->sp_offset = pic->sp - pic->stbase;
-  try_jmp->ip = pic->ip;
 
-  try_jmp->prev_jmp = pic->jmp;
+  pic->err = err;
-  pic->jmp = &try_jmp->here;
+
+  cont = pic_proc_ptr(pic_attr_ref(pic, pic_get_proc(pic), "@@escape"));
+
+  pic_apply1(pic, cont, pic_false_value());
+
+  UNREACHABLE();
+}
+
+static pic_value
+native_push_try(pic_state *pic)
+{
+  struct pic_proc *cont, *handler;
+  size_t xp_len, xp_offset;
+
+  pic_get_args(pic, "l", &cont);
+
+  handler = pic_make_proc(pic, native_exception_handler, "(native-exception-handler)");
+
+  pic_attr_set(pic, handler, "@@escape", pic_obj_value(cont));
+
+  if (pic->xp >= pic->xpend) {
+    xp_len = (pic->xpend - pic->xpbase) * 2;
+    xp_offset = pic->xp - pic->xpbase;
+    pic->xpbase = pic_realloc(pic, pic->xpbase, sizeof(struct pic_proc *) * xp_len);
+    pic->xp = pic->xpbase + xp_offset;
+    pic->xpend = pic->xpbase + xp_len;
+  }
+
+  *pic->xp++ = handler;
+
+  return pic_true_value();
+}
+
+bool
+pic_push_try(pic_state *pic)
+{
+  pic_value val;
+
+  val = pic_callcc(pic, pic_make_proc(pic, native_push_try, "(native-push-try)"));
+
+  return pic_test(val);
 }
 
 void
 pic_pop_try(pic_state *pic)
 {
-  struct pic_jmpbuf *try_jmp;
+  --pic->xp;
-
-  try_jmp = pic->try_jmps + --pic->try_jmp_idx;
-
-  /* assert(pic->jmp == &try_jmp->here); */
-
-  pic->ci = try_jmp->ci_offset + pic->cibase;
-  pic->sp = try_jmp->sp_offset + pic->stbase;
-  pic->ip = try_jmp->ip;
-
-  pic->jmp = try_jmp->prev_jmp;
 }
 
 struct pic_error *
@@ -88,20 +143,37 @@ pic_make_error(pic_state *pic, pic_sym type, const char *msg, pic_value irrs)
   return e;
 }
 
+pic_value
+pic_raise_continuable(pic_state *pic, pic_value err)
+{
+  struct pic_proc *handler;
+  pic_value v;
+
+  if (pic->xp == pic->xpbase) {
+    pic_panic(pic, "no exception handler registered");
+  }
+
+  handler = *--pic->xp;
+
+  pic_gc_protect(pic, pic_obj_value(handler));
+
+  v = pic_apply1(pic, handler, err);
+
+  *pic->xp++ = handler;
+
+  return v;
+}
+
 noreturn void
 pic_raise(pic_state *pic, pic_value err)
 {
-  void pic_vm_tear_off(pic_state *);
+  pic_value val;
 
-  pic_vm_tear_off(pic);         /* tear off */
+  val = pic_raise_continuable(pic, err);
 
-  pic->err = err;
+  pic_pop_try(pic);
-  if (! pic->jmp) {
-    puts(pic_errmsg(pic));
-    pic_panic(pic, "no handler found on stack");
-  }
 
-  longjmp(*pic->jmp, 1);
+  pic_errorf(pic, "error handler returned with ~s on error ~s", val, err);
 }
 
 noreturn void
@@ -120,59 +192,29 @@ pic_error(pic_state *pic, const char *msg, pic_value irrs)
   pic_throw(pic, pic_intern_cstr(pic, ""), msg, irrs);
 }
 
-const char *
-pic_errmsg(pic_state *pic)
-{
-  pic_str *str;
-
-  assert(! pic_undef_p(pic->err));
-
-  if (! pic_error_p(pic->err)) {
-    str = pic_format(pic, "~s", pic->err);
-  } else {
-    str = pic_error_ptr(pic->err)->msg;
-  }
-
-  return pic_str_cstr(str);
-}
-
-void
-pic_errorf(pic_state *pic, const char *fmt, ...)
-{
-  va_list ap;
-  pic_value err_line, irrs;
-  const char *msg;
-
-  va_start(ap, fmt);
-  err_line = pic_xvformat(pic, fmt, ap);
-  va_end(ap);
-
-  msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line)));
-  irrs = pic_cdr(pic, err_line);
-
-  pic_error(pic, msg, irrs);
-}
-
 static pic_value
 pic_error_with_exception_handler(pic_state *pic)
 {
   struct pic_proc *handler, *thunk;
   pic_value val;
+  size_t xp_len, xp_offset;
 
   pic_get_args(pic, "ll", &handler, &thunk);
 
-  pic_try_with_handler(handler) {
+  if (pic->xp >= pic->xpend) {
+    xp_len = (pic->xpend - pic->xpbase) * 2;
+    xp_offset = pic->xp - pic->xpbase;
+    pic->xpbase = pic_realloc(pic, pic->xpbase, sizeof(struct pic_proc *) * xp_len);
+    pic->xp = pic->xpbase + xp_offset;
+    pic->xpend = pic->xpbase + xp_len;
+  }
+
+  *pic->xp++ = handler;
+
   val = pic_apply0(pic, thunk);
-  }
-  pic_catch {
-    pic_value e = pic->err;
 
-    pic->err = pic_undef_value();
+  --pic->xp;
 
-    val = pic_apply1(pic, handler, e);
-
-    pic_errorf(pic, "error handler returned with ~s on error ~s", val, e);
-  }
   return val;
 }
 
@@ -193,18 +235,7 @@ pic_error_raise_continuable(pic_state *pic)
 
   pic_get_args(pic, "o", &v);
 
-  if (pic->try_jmp_idx == 0) {
+  return pic_raise_continuable(pic, v);
-    pic_errorf(pic, "no exception handler registered");
-  }
-  if (pic->try_jmps[pic->try_jmp_idx - 1].handler == NULL) {
-    pic_errorf(pic, "uncontinuable exception handler is on top");
-  }
-  else {
-    pic->try_jmp_idx--;
-    v = pic_apply1(pic, pic->try_jmps[pic->try_jmp_idx].handler, v);
-    ++pic->try_jmp_idx;
-  }
-  return v;
 }
 
 noreturn static pic_value

gc.c

@@ -333,6 +333,20 @@ gc_unmark(union header *p)
   p->s.mark = PIC_GC_UNMARK;
 }
 
+static void
+gc_mark_winder(pic_state *pic, struct pic_winder *wind)
+{
+  if (wind->prev) {
+    gc_mark_object(pic, (struct pic_object *)wind->prev);
+  }
+  if (wind->in) {
+    gc_mark_object(pic, (struct pic_object *)wind->in);
+  }
+  if (wind->out) {
+    gc_mark_object(pic, (struct pic_object *)wind->out);
+  }
+}
+
 static void
 gc_mark_object(pic_state *pic, struct pic_object *obj)
 {
@@ -402,10 +416,11 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     struct pic_cont *cont = (struct pic_cont *)obj;
     pic_value *stack;
     pic_callinfo *ci;
+    struct pic_proc **xhandler;
     size_t i;
 
-    /* block */
+    /* winder */
-    gc_mark_object(pic, (struct pic_object *)cont->blk);
+    gc_mark_winder(pic, cont->wind);
 
     /* stack */
     for (stack = cont->st_ptr; stack != cont->st_ptr + cont->sp_offset; ++stack) {
@@ -419,18 +434,16 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
       }
     }
 
+    /* exception handlers */
+    for (xhandler = cont->xp_ptr; xhandler != cont->xp_ptr + cont->xp_offset; ++xhandler) {
+      gc_mark_object(pic, (struct pic_object *)*xhandler);
+    }
+
     /* arena */
     for (i = 0; i < (size_t)cont->arena_idx; ++i) {
       gc_mark_object(pic, cont->arena[i]);
     }
 
-    /* error handlers */
-    for (i = 0; i < cont->try_jmp_idx; ++i) {
-      if (cont->try_jmps[i].handler) {
-        gc_mark_object(pic, (struct pic_object *)cont->try_jmps[i].handler);
-      }
-    }
-
     /* result values */
     gc_mark(pic, cont->results);
     break;
@@ -504,20 +517,6 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     }
     break;
   }
-  case PIC_TT_BLK: {
-    struct pic_block *blk = (struct pic_block *)obj;
-
-    if (blk->prev) {
-      gc_mark_object(pic, (struct pic_object *)blk->prev);
-    }
-    if (blk->in) {
-      gc_mark_object(pic, (struct pic_object *)blk->in);
-    }
-    if (blk->out) {
-      gc_mark_object(pic, (struct pic_object *)blk->out);
-    }
-    break;
-  }
   case PIC_TT_NIL:
   case PIC_TT_BOOL:
   case PIC_TT_FLOAT:
@@ -562,12 +561,13 @@ gc_mark_phase(pic_state *pic)
 {
   pic_value *stack;
   pic_callinfo *ci;
-  size_t i, j;
+  struct pic_proc **xhandler;
+  size_t j;
   xh_entry *it;
 
-  /* block */
+  /* winder */
-  if (pic->blk) {
+  if (pic->wind) {
-    gc_mark_object(pic, (struct pic_object *)pic->blk);
+    gc_mark_winder(pic, pic->wind);
   }
 
   /* stack */
@@ -582,8 +582,10 @@ gc_mark_phase(pic_state *pic)
     }
   }
 
-  /* error object */
+  /* exception handlers */
-  gc_mark(pic, pic->err);
+  for (xhandler = pic->xpbase; xhandler != pic->xp; ++xhandler) {
+    gc_mark_object(pic, (struct pic_object *)*xhandler);
+  }
 
   /* arena */
   for (j = 0; j < pic->arena_idx; ++j) {
@@ -600,13 +602,10 @@ gc_mark_phase(pic_state *pic)
     gc_mark_object(pic, xh_val(it, struct pic_object *));
   }
 
-  /* error handlers */
+  /* error object */
-  for (i = 0; i < pic->try_jmp_idx; ++i) {
+  gc_mark(pic, pic->err);
-    if (pic->try_jmps[i].handler) {
-      gc_mark_object(pic, (struct pic_object *)pic->try_jmps[i].handler);
-    }
-  }
 
+  /* features */
   gc_mark(pic, pic->features);
 
   /* readers */
@@ -669,8 +668,8 @@ 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->xp_ptr);
     pic_free(pic, cont->arena);
-    pic_free(pic, cont->try_jmps);
     break;
   }
   case PIC_TT_SENV: {
@@ -709,9 +708,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
     xh_destroy(&rec->hash);
     break;
   }
-  case PIC_TT_BLK: {
-    break;
-  }
   case PIC_TT_NIL:
   case PIC_TT_BOOL:
   case PIC_TT_FLOAT:

include/picrin.h

@@ -46,6 +46,13 @@ extern "C" {
 
 typedef struct pic_code pic_code;
 
+struct pic_winder {
+  struct pic_proc *in;
+  struct pic_proc *out;
+  int depth;
+  struct pic_winder *prev;
+};
+
 typedef struct {
   int argc, retc;
   pic_code *ip;
@@ -60,7 +67,7 @@ typedef struct {
   int argc;
   char **argv, **envp;
 
-  struct pic_block *blk;
+  struct pic_winder *wind;
 
   pic_value *sp;
   pic_value *stbase, *stend;
@@ -68,6 +75,9 @@ typedef struct {
   pic_callinfo *ci;
   pic_callinfo *cibase, *ciend;
 
+  struct pic_proc **xp;
+  struct pic_proc **xpbase, **xpend;
+
   pic_code *ip;
 
   struct pic_lib *lib;
@@ -104,17 +114,14 @@ typedef struct {
 
   struct pic_reader *reader;
 
-  jmp_buf *jmp;
-  pic_value err;
-  struct pic_jmpbuf *try_jmps;
-  size_t try_jmp_size, try_jmp_idx;
-
   struct pic_heap *heap;
   struct pic_object **arena;
   size_t arena_size, arena_idx;
 
   struct pic_port *xSTDIN, *xSTDOUT, *xSTDERR;
 
+  pic_value err;
+
   char *native_stack_start;
 } pic_state;
 

include/picrin/cont.h

@@ -9,18 +9,11 @@
 extern "C" {
 #endif
 
-struct pic_block {
-  PIC_OBJECT_HEADER
-  struct pic_block *prev;
-  int depth;
-  struct pic_proc *in, *out;
-};
-
 struct pic_cont {
   PIC_OBJECT_HEADER
   jmp_buf jmp;
 
-  struct pic_block *blk;
+  struct pic_winder *wind;
 
   char *stk_pos, *stk_ptr;
   ptrdiff_t stk_len;
@@ -31,15 +24,15 @@ struct pic_cont {
   pic_callinfo *ci_ptr;
   size_t ci_offset, ci_len;
 
+  struct pic_proc **xp_ptr;
+  size_t xp_offset, xp_len;
+
   pic_code *ip;
 
   struct pic_object **arena;
   size_t arena_size;
   int arena_idx;
 
-  struct pic_jmpbuf *try_jmps;
-  size_t try_jmp_idx, try_jmp_size;
-
   pic_value results;
 };
 
@@ -54,6 +47,7 @@ pic_value pic_values_by_list(pic_state *, pic_value);
 size_t pic_receive(pic_state *, size_t, pic_value *);
 
 pic_value pic_callcc(pic_state *, struct pic_proc *);
+void pic_wind(pic_state *, struct pic_winder *, struct pic_winder *);
 
 #if defined(__cplusplus)
 }

include/picrin/error.h

@@ -9,35 +9,6 @@
 extern "C" {
 #endif
 
-struct pic_jmpbuf {
-  jmp_buf here;
-  struct pic_proc *handler;
-  ptrdiff_t ci_offset;
-  ptrdiff_t sp_offset;
-  pic_code *ip;
-  jmp_buf *prev_jmp;
-};
-
-/* do not return from try block! */
-
-#define pic_try                                 \
-  pic_try_with_handler(NULL)
-#define pic_try_with_handler(handler)           \
-  pic_push_try(pic, handler);                   \
-  if (setjmp(*pic->jmp) == 0)                   \
-    do
-#define pic_catch                               \
-    while (pic_pop_try(pic), 0);                \
-  else                                          \
-    if (pic_pop_try(pic), 1)
-
-void pic_push_try(pic_state *, struct pic_proc *);
-void pic_pop_try(pic_state *);
-
-noreturn void pic_raise(pic_state *, pic_value);
-noreturn void pic_throw(pic_state *, pic_sym, const char *, pic_list);
-noreturn void pic_error(pic_state *, const char *, pic_list);
-
 struct pic_error {
   PIC_OBJECT_HEADER
   pic_sym type;
@@ -51,6 +22,24 @@ struct pic_error {
 
 struct pic_error *pic_make_error(pic_state *, pic_sym, const char *, pic_list);
 
+/* do not return from try block! */
+
+#define pic_try                                 \
+  if (pic_push_try(pic))                        \
+    do
+#define pic_catch                               \
+    while (pic_pop_try(pic), 0);                \
+  else                                          \
+    if (pic_pop_try(pic), 1)
+
+bool pic_push_try(pic_state *);
+void pic_pop_try(pic_state *);
+
+pic_value pic_raise_continuable(pic_state *, pic_value);
+noreturn void pic_raise(pic_state *, pic_value);
+noreturn void pic_throw(pic_state *, pic_sym, const char *, pic_list);
+noreturn void pic_error(pic_state *, const char *, pic_list);
+
 #if defined(__cplusplus)
 }
 #endif

include/picrin/value.h

@@ -125,7 +125,6 @@ enum pic_tt {
   PIC_TT_DATA,
   PIC_TT_DICT,
   PIC_TT_RECORD,
-  PIC_TT_BLK,
 };
 
 #define PIC_OBJECT_HEADER			\
@@ -274,8 +273,6 @@ pic_type_repr(enum pic_tt tt)
     return "dict";
   case PIC_TT_RECORD:
     return "record";
-  case PIC_TT_BLK:
-    return "block";
   }
   UNREACHABLE();
 }

state.c

@@ -27,7 +27,7 @@ pic_open(int argc, char *argv[], char **envp)
   pic = malloc(sizeof(pic_state));
 
   /* root block */
-  pic->blk = NULL;
+  pic->wind = NULL;
 
   /* command line */
   pic->argc = argc;
@@ -42,6 +42,10 @@ pic_open(int argc, char *argv[], char **envp)
   pic->cibase = pic->ci = calloc(PIC_STACK_SIZE, sizeof(pic_callinfo));
   pic->ciend = pic->cibase + PIC_STACK_SIZE;
 
+  /* exception handler */
+  pic->xpbase = pic->xp = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_proc *));
+  pic->xpend = pic->xpbase + PIC_RESCUE_SIZE;
+
   /* memory heap */
   pic->heap = pic_heap_open();
 
@@ -70,12 +74,8 @@ pic_open(int argc, char *argv[], char **envp)
   pic->reader->trie = pic_make_trie(pic);
   xh_init_int(&pic->reader->labels, sizeof(pic_value));
 
-  /* error handling */
+  /* raised error object */
-  pic->jmp = NULL;
   pic->err = pic_undef_value();
-  pic->try_jmps = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_jmpbuf));
-  pic->try_jmp_idx = 0;
-  pic->try_jmp_size = PIC_RESCUE_SIZE;
 
   /* standard ports */
   pic->xSTDIN = NULL;
@@ -153,10 +153,10 @@ pic_open(int argc, char *argv[], char **envp)
   pic_gc_arena_restore(pic, ai);
 
   /* root block */
-  pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK);
+  pic->wind = pic_alloc(pic, sizeof(struct pic_winder));
-  pic->blk->prev = NULL;
+  pic->wind->prev = NULL;
-  pic->blk->depth = 0;
+  pic->wind->depth = 0;
-  pic->blk->in = pic->blk->out = NULL;
+  pic->wind->in = pic->wind->out = NULL;
 
   /* init readers */
   pic_init_reader(pic);
@@ -182,16 +182,17 @@ pic_close(pic_state *pic)
   xh_entry *it;
 
   /* invoke exit handlers */
-  while (pic->blk) {
+  while (pic->wind) {
-    if (pic->blk->out) {
+    if (pic->wind->out) {
-      pic_apply0(pic, pic->blk->out);
+      pic_apply0(pic, pic->wind->out);
     }
-    pic->blk = pic->blk->prev;
+    pic->wind = pic->wind->prev;
   }
 
   /* clear out root objects */
   pic->sp = pic->stbase;
   pic->ci = pic->cibase;
+  pic->xp = pic->xpbase;
   pic->arena_idx = 0;
   pic->err = pic_undef_value();
   xh_clear(&pic->macros);
@@ -207,6 +208,7 @@ pic_close(pic_state *pic)
   /* free runtime context */
   free(pic->stbase);
   free(pic->cibase);
+  free(pic->xpbase);
 
   /* free reader struct */
   xh_destroy(&pic->reader->labels);
@@ -214,7 +216,6 @@ pic_close(pic_state *pic)
   free(pic->reader);
 
   /* free global stacks */
-  free(pic->try_jmps);
   xh_destroy(&pic->syms);
   xh_destroy(&pic->globals);
   xh_destroy(&pic->macros);

vm.c

@@ -755,21 +755,29 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
     }
     CASE(OP_LREF) {
       pic_callinfo *ci = pic->ci;
+      struct pic_irep *irep;
 
       if (ci->env != NULL && ci->env->regs == ci->env->storage) {
+        irep = pic_get_proc(pic)->u.irep;
+        if (c.u.i >= irep->argc + irep->localc) {
           PUSH(ci->env->regs[c.u.i - (ci->regs - ci->fp)]);
           NEXT;
         }
+      }
       PUSH(pic->ci->fp[c.u.i]);
       NEXT;
     }
     CASE(OP_LSET) {
       pic_callinfo *ci = pic->ci;
+      struct pic_irep *irep;
 
       if (ci->env != NULL && ci->env->regs == ci->env->storage) {
+        irep = pic_get_proc(pic)->u.irep;
+        if (c.u.i >= irep->argc + irep->localc) {
           ci->env->regs[c.u.i - (ci->regs - ci->fp)] = POP();
           NEXT;
         }
+      }
       pic->ci->fp[c.u.i] = POP();
       NEXT;
     }