From 3cb46b9b79ac71bf14005790fd1e4b4869b9b9a9 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 17:22:02 +0900
Subject: [PATCH 01/16] allocate jmpbuf array in heap

---
 include/picrin.h       |  1 +
 include/picrin/cont.h  |  3 +++
 include/picrin/error.h |  1 -
 src/cont.c             | 11 +++++++++++
 src/error.c            | 21 ++++++++-------------
 src/gc.c               |  1 +
 src/state.c            |  6 +++++-
 7 files changed, 29 insertions(+), 15 deletions(-)

diff --git a/include/picrin.h b/include/picrin.h
index fd3b4ca2..ca043c09 100644
--- a/include/picrin.h
+++ b/include/picrin.h
@@ -109,6 +109,7 @@ typedef struct {
   jmp_buf *jmp;
   struct pic_error *err;
   struct pic_jmpbuf *try_jmps;
+  size_t try_jmp_size, try_jmp_idx;
 
   struct pic_heap *heap;
   struct pic_object **arena;
diff --git a/include/picrin/cont.h b/include/picrin/cont.h
index 496454fd..b33b6755 100644
--- a/include/picrin/cont.h
+++ b/include/picrin/cont.h
@@ -30,6 +30,9 @@ struct pic_cont {
   size_t arena_size;
   int arena_idx;
 
+  struct pic_jmpbuf *try_jmps;
+  size_t try_jmp_idx, try_jmp_size;
+
   pic_value results;
 };
 
diff --git a/include/picrin/error.h b/include/picrin/error.h
index 75361c1a..41444dc6 100644
--- a/include/picrin/error.h
+++ b/include/picrin/error.h
@@ -15,7 +15,6 @@ struct pic_jmpbuf {
   pic_value *sp;
   pic_code *ip;
   jmp_buf *prev_jmp;
-  struct pic_jmpbuf *prev;
 };
 
 /* do not return from try block! */
diff --git a/src/cont.c b/src/cont.c
index 11b5a3f6..df2d8a6b 100644
--- a/src/cont.c
+++ b/src/cont.c
@@ -10,6 +10,7 @@
 #include "picrin/proc.h"
 #include "picrin/cont.h"
 #include "picrin/pair.h"
+#include "picrin/error.h"
 
 pic_value
 pic_values0(pic_state *pic)
@@ -143,6 +144,11 @@ 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();
 }
 
@@ -189,6 +195,11 @@ 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);
diff --git a/src/error.c b/src/error.c
index 21f6d487..517677b4 100644
--- a/src/error.c
+++ b/src/error.c
@@ -38,7 +38,7 @@ pic_push_try(pic_state *pic)
 {
   struct pic_jmpbuf *try_jmp;
 
-  try_jmp = pic_alloc(pic, sizeof(struct pic_jmpbuf));
+  try_jmp = pic->try_jmps + pic->try_jmp_idx++;
 
   try_jmp->ci = pic->ci;
   try_jmp->sp = pic->sp;
@@ -46,27 +46,22 @@ pic_push_try(pic_state *pic)
 
   try_jmp->prev_jmp = pic->jmp;
   pic->jmp = &try_jmp->here;
-
-  try_jmp->prev = pic->try_jmps;
-  pic->try_jmps = try_jmp;
 }
 
 void
 pic_pop_try(pic_state *pic)
 {
-  struct pic_jmpbuf *prev;
+  struct pic_jmpbuf *try_jmp;
 
-  assert(pic->jmp == &pic->try_jmps->here);
+  try_jmp = pic->try_jmps + --pic->try_jmp_idx;
 
-  pic->ci = pic->try_jmps->ci;
-  pic->sp = pic->try_jmps->sp;
-  pic->ip = pic->try_jmps->ip;
+  assert(pic->jmp == &try_jmp->here);
 
-  pic->jmp = pic->try_jmps->prev_jmp;
+  pic->ci = try_jmp->ci;
+  pic->sp = try_jmp->sp;
+  pic->ip = try_jmp->ip;
 
-  prev = pic->try_jmps->prev;
-  pic_free(pic, pic->try_jmps);
-  pic->try_jmps = prev;
+  pic->jmp = try_jmp->prev_jmp;
 }
 
 static struct pic_error *
diff --git a/src/gc.c b/src/gc.c
index 3d28aa96..1ea3986e 100644
--- a/src/gc.c
+++ b/src/gc.c
@@ -621,6 +621,7 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
     pic_free(pic, cont->st_ptr);
     pic_free(pic, cont->ci_ptr);
     pic_free(pic, cont->arena);
+    pic_free(pic, cont->try_jmps);
     PIC_BLK_DECREF(pic, cont->blk);
     break;
   }
diff --git a/src/state.c b/src/state.c
index 758bae9c..cdae3901 100644
--- a/src/state.c
+++ b/src/state.c
@@ -9,6 +9,7 @@
 #include "picrin/proc.h"
 #include "picrin/macro.h"
 #include "picrin/cont.h"
+#include "picrin/error.h"
 
 void pic_init_core(pic_state *);
 
@@ -70,7 +71,9 @@ pic_open(int argc, char *argv[], char **envp)
   /* error handling */
   pic->jmp = NULL;
   pic->err = NULL;
-  pic->try_jmps = NULL;
+  pic->try_jmps = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_jmpbuf));
+  pic->try_jmp_idx = 0;
+  pic->try_jmp_size = PIC_RESCUE_SIZE;
 
   /* GC arena */
   pic->arena = (struct pic_object **)calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **));
@@ -170,6 +173,7 @@ pic_close(pic_state *pic)
 
   /* free global stacks */
   free(pic->globals);
+  free(pic->try_jmps);
   xh_destroy(&pic->syms);
   xh_destroy(&pic->global_tbl);
   xh_destroy(&pic->macros);

From be2fbc394e928f7b6281cb56f76ed9514d736751 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 17:24:47 +0900
Subject: [PATCH 02/16] realloc jmpbuf if necessary

---
 src/error.c | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/src/error.c b/src/error.c
index 517677b4..369fb185 100644
--- a/src/error.c
+++ b/src/error.c
@@ -38,6 +38,11 @@ pic_push_try(pic_state *pic)
 {
   struct pic_jmpbuf *try_jmp;
 
+  if (pic->try_jmp_idx >= pic->try_jmp_size) {
+    pic->try_jmp_size *= 2;
+    pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size);
+  }
+
   try_jmp = pic->try_jmps + pic->try_jmp_idx++;
 
   try_jmp->ci = pic->ci;

From f52ef27a8131ce4a76543edd1d91512ec9aea3b1 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 17:27:18 +0900
Subject: [PATCH 03/16] [bugfix] unwrap raised error object

---
 src/error.c | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/src/error.c b/src/error.c
index 369fb185..bc45ff65 100644
--- a/src/error.c
+++ b/src/error.c
@@ -147,7 +147,13 @@ pic_error_with_exception_handler(pic_state *pic)
     struct pic_error *e = pic->err;
 
     pic->err = NULL;
-    v = pic_apply1(pic, handler, pic_obj_value(e));
+
+    if (e->type == PIC_ERROR_RAISED) {
+      v = pic_list_ref(pic, e->irrs, 0);
+    } else {
+      v = pic_obj_value(e);
+    }
+    v = pic_apply1(pic, handler, v);
     pic_errorf(pic, "error handler returned ~s, by error ~s", v, pic_obj_value(e));
   }
   return v;

From 70ace29b7c50d5b7f79a89af862751d5c30693b7 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 17:44:55 +0900
Subject: [PATCH 04/16] initial raise-continuable support

---
 include/picrin/error.h |  7 +++++--
 src/error.c            | 29 +++++++++++++++++++++++++++--
 2 files changed, 32 insertions(+), 4 deletions(-)

diff --git a/include/picrin/error.h b/include/picrin/error.h
index 41444dc6..cbaff543 100644
--- a/include/picrin/error.h
+++ b/include/picrin/error.h
@@ -11,6 +11,7 @@ extern "C" {
 
 struct pic_jmpbuf {
   jmp_buf here;
+  struct pic_proc *handler;
   pic_callinfo *ci;
   pic_value *sp;
   pic_code *ip;
@@ -20,7 +21,9 @@ struct pic_jmpbuf {
 /* do not return from try block! */
 
 #define pic_try                                 \
-  pic_push_try(pic);                            \
+  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                               \
@@ -28,7 +31,7 @@ struct pic_jmpbuf {
   else                                          \
     if (pic_pop_try(pic), 1)
 
-void pic_push_try(pic_state *);
+void pic_push_try(pic_state *, struct pic_proc *);
 void pic_pop_try(pic_state *);
 
 noreturn void pic_throw(pic_state *, short, const char *, pic_value);
diff --git a/src/error.c b/src/error.c
index bc45ff65..b5ed169e 100644
--- a/src/error.c
+++ b/src/error.c
@@ -34,7 +34,7 @@ pic_warnf(pic_state *pic, const char *fmt, ...)
 }
 
 void
-pic_push_try(pic_state *pic)
+pic_push_try(pic_state *pic, struct pic_proc *handler)
 {
   struct pic_jmpbuf *try_jmp;
 
@@ -45,6 +45,8 @@ pic_push_try(pic_state *pic)
 
   try_jmp = pic->try_jmps + pic->try_jmp_idx++;
 
+  try_jmp->handler = handler;
+
   try_jmp->ci = pic->ci;
   try_jmp->sp = pic->sp;
   try_jmp->ip = pic->ip;
@@ -140,7 +142,7 @@ pic_error_with_exception_handler(pic_state *pic)
 
   pic_get_args(pic, "ll", &handler, &thunk);
 
-  pic_try {
+  pic_try_with_handler(handler) {
     v = pic_apply0(pic, thunk);
   }
   pic_catch {
@@ -169,6 +171,28 @@ pic_error_raise(pic_state *pic)
   pic_throw(pic, PIC_ERROR_RAISED, "object is raised", pic_list1(pic, v));
 }
 
+static pic_value
+pic_error_raise_continuable(pic_state *pic)
+{
+  pic_value v;
+  size_t i;
+
+  pic_get_args(pic, "o", &v);
+
+  if (pic->try_jmps->handler == NULL) {
+    pic_errorf(pic, "uncontinuable exception handler is on top");
+  }
+  if ((i = pic->try_jmp_idx) == 0) {
+    pic_errorf(pic, "no exception handler registered");
+  }
+  else {
+    pic->try_jmp_idx--;
+    v = pic_apply1(pic, pic->try_jmps->handler, v);
+    ++pic->try_jmp_idx;
+  }
+  return v;
+}
+
 noreturn static pic_value
 pic_error_error(pic_state *pic)
 {
@@ -248,6 +272,7 @@ 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);

From 01c657ddbab2f4c2459f622ffa0a81e7f75e2450 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 17:45:25 +0900
Subject: [PATCH 05/16] [bugfix] pic_get_args supports 'e' specifier

---
 src/vm.c | 20 +++++++++++++++++++-
 1 file changed, 19 insertions(+), 1 deletion(-)

diff --git a/src/vm.c b/src/vm.c
index 8e2ddb6c..39e0d6f8 100644
--- a/src/vm.c
+++ b/src/vm.c
@@ -51,6 +51,7 @@ pic_get_proc(pic_state *pic)
  *  l   lambda object
  *  p   port object
  *  d   dictionary object
+ *  e   error object
  *
  *  |  optional operator
  *  *  variable length operator
@@ -346,8 +347,25 @@ pic_get_args(pic_state *pic, const char *format, ...)
       }
       break;
     }
+    case 'e': {
+      struct pic_error **e;
+      pic_value v;
+
+      e = va_arg(ap, struct pic_error **);
+      if (i < argc) {
+        v = GET_OPERAND(pic,i);
+        if (pic_error_p(v)) {
+          *e = pic_error_ptr(v);
+        }
+        else {
+          pic_error(pic, "pic_get_args, expected error");
+        }
+        i++;
+      }
+      break;
+    }
     default:
-      pic_error(pic, "pic_get_args: invalid argument specifier given");
+      pic_errorf(pic, "pic_get_args: invalid argument specifier '%c' given", c);
     }
   }
   if ('*' == c) {

From c584b7baa9a37672bfad77fdc65ec71d41fbe8c5 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 17:45:49 +0900
Subject: [PATCH 06/16] add guard macro

---
 piclib/prelude.scm | 59 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 59 insertions(+)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 5a5008c0..feef5c0c 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -1014,3 +1014,62 @@
 (import (picrin syntax-rules))
 (export syntax-rules)
 
+(define-syntax guard-aux
+  (syntax-rules (else =>)
+    ((guard-aux reraise (else result1 result2 ...))
+     (begin result1 result2 ...))
+    ((guard-aux reraise (test => result))
+     (let ((temp test))
+       (if temp
+           (result temp)
+           reraise)))
+    ((guard-aux reraise (test => result)
+                clause1 clause2 ...)
+     (let ((temp test))
+       (if temp
+           (result temp)
+           (guard-aux reraise clause1 clause2 ...))))
+    ((guard-aux reraise (test))
+     (or test reraise))
+    ((guard-aux reraise (test) clause1 clause2 ...)
+     (let ((temp test))
+       (if temp
+           temp
+           (guard-aux reraise clause1 clause2 ...))))
+    ((guard-aux reraise (test result1 result2 ...))
+     (if test
+         (begin result1 result2 ...)
+         reraise))
+    ((guard-aux reraise
+                (test result1 result2 ...)
+                clause1 clause2 ...)
+     (if test
+         (begin result1 result2 ...)
+         (guard-aux reraise clause1 clause2 ...)))))
+
+(define-syntax guard
+  (syntax-rules ()
+    ((guard (var clause ...) e1 e2 ...)
+     ((call/cc
+       (lambda (guard-k)
+         (with-exception-handler
+          (lambda (condition)
+            ((call/cc
+              (lambda (handler-k)
+                (guard-k
+                 (lambda ()
+                   (let ((var condition))
+                     (guard-aux
+                      (handler-k
+                       (lambda ()
+                         (raise-continuable condition)))
+                      clause ...))))))))
+          (lambda ()
+            (call-with-values
+                (lambda () e1 e2 ...)
+              (lambda args
+                (guard-k
+                 (lambda ()
+                   (apply values args)))))))))))))
+
+(export guard)

From 077cb8bcfac63b4d49cef0bba86517fe81461f4d Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 17:46:57 +0900
Subject: [PATCH 07/16] update doc

---
 docs/lang.rst | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/docs/lang.rst b/docs/lang.rst
index 3c3f463b..9ff59b5c 100644
--- a/docs/lang.rst
+++ b/docs/lang.rst
@@ -47,7 +47,7 @@ section                                          status     comments
 4.2.4 Iteration                                  yes
 4.2.5 Delayed evaluation                         N/A
 4.2.6 Dynamic bindings                           yes
-4.2.7 Exception handling                         no         ``guard`` syntax.
+4.2.7 Exception handling                         yes        ``guard`` syntax.
 4.2.8 Quasiquotation                             yes        can be safely nested. TODO: multiple argument for unquote
 4.2.9 Case-lambda                                N/A
 4.3.1 Bindings constructs for syntactic keywords incomplete [#]_

From a75a48fc8fd2dc0288dd28a13f6507dc0ded2265 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Sun, 29 Jun 2014 17:47:04 +0900
Subject: [PATCH 08/16] unlock some of exception tests

---
 t/r7rs-tests.scm | 174 +++++++++++++++++++++++------------------------
 1 file changed, 87 insertions(+), 87 deletions(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index c02b0c9d..0b1cc38f 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -1619,29 +1619,29 @@
 
 (test-begin "6.11 Exceptions")
 
-;; (test 65
-;;     (with-exception-handler
-;;      (lambda (con) 42)
-;;      (lambda ()
-;;        (+ (raise-continuable "should be a number")
-;;           23))))
+(test 65
+    (with-exception-handler
+     (lambda (con) 42)
+     (lambda ()
+       (+ (raise-continuable "should be a number")
+          23))))
 
-;; (test #t
-;;     (error-object? (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
+(test #t
+    (error-object? (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
 ;; (test "BOOM!"
 ;;     (error-object-message (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
 ;; (test '(1 2 3)
 ;;     (error-object-irritants (guard (exn (else exn)) (error "BOOM!" 1 2 3))))
 
-;; (test #f
-;;     (file-error? (guard (exn (else exn)) (error "BOOM!"))))
-;; (test #t
-;;     (file-error? (guard (exn (else exn)) (open-input-file " no such file "))))
+(test #f
+    (file-error? (guard (exn (else exn)) (error "BOOM!"))))
+(test #t
+    (file-error? (guard (exn (else exn)) (open-input-file " no such file "))))
 
-;; (test #f
-;;     (read-error? (guard (exn (else exn)) (error "BOOM!"))))
-;; (test #t
-;;     (read-error? (guard (exn (else exn)) (read (open-input-string ")")))))
+(test #f
+    (read-error? (guard (exn (else exn)) (error "BOOM!"))))
+(test #t
+    (read-error? (guard (exn (else exn)) (read (open-input-string ")")))))
 
 (define something-went-wrong #f)
 (define (test-exception-handler-1 v)
@@ -1659,86 +1659,86 @@
 (test '("condition: " an-error) something-went-wrong)
 
 (set! something-went-wrong #f)
-;; (define (test-exception-handler-2 v)
-;;   (guard (ex (else 'caught-another-exception))
-;;     (with-exception-handler
-;;      (lambda (x)
-;;        (set! something-went-wrong #t)
-;;        (list "exception:" x))
-;;      (lambda ()
-;;        (+ 1 (if (> v 0) (+ v 100) (raise 'an-error)))))))
-;; (test 106 (test-exception-handler-2 5))
-;; (test #f something-went-wrong)
-;; (test 'caught-another-exception (test-exception-handler-2 -1))
-;; (test #t something-went-wrong)
+(define (test-exception-handler-2 v)
+  (guard (ex (else 'caught-another-exception))
+    (with-exception-handler
+     (lambda (x)
+       (set! something-went-wrong #t)
+       (list "exception:" x))
+     (lambda ()
+       (+ 1 (if (> v 0) (+ v 100) (raise 'an-error)))))))
+(test 106 (test-exception-handler-2 5))
+(test #f something-went-wrong)
+(test 'caught-another-exception (test-exception-handler-2 -1))
+(test #t something-went-wrong)
 
 ;; Based on an example from R6RS-lib section 7.1 Exceptions.
 ;; R7RS section 6.11 Exceptions has a simplified version.
-;; (let* ((out (open-output-string))
-;;        (value (with-exception-handler
-;;                (lambda (con)
-;;                  (cond
-;;                   ((not (list? con))
-;;                    (raise con))
-;;                   ((list? con)
-;;                    (display (car con) out))
-;;                   (else
-;;                    (display "a warning has been issued" out)))
-;;                  42)
-;;                (lambda ()
-;;                  (+ (raise-continuable
-;;                      (list "should be a number"))
-;;                     23)))))
-;;   (test "should be a number" (get-output-string out))
-;;   (test 65 value))
+(let* ((out (open-output-string))
+       (value (with-exception-handler
+               (lambda (con)
+                 (cond
+                  ((not (list? con))
+                   (raise con))
+                  ((list? con)
+                   (display (car con) out))
+                  (else
+                   (display "a warning has been issued" out)))
+                 42)
+               (lambda ()
+                 (+ (raise-continuable
+                     (list "should be a number"))
+                    23)))))
+  (test "should be a number" (get-output-string out))
+  (test 65 value))
 
 ;; From SRFI-34 "Examples" section - #3
-;; (define (test-exception-handler-3 v out)
-;;   (guard (condition
-;;           (else
-;;            (display "condition: " out)
-;;            (write condition out)
-;;            (display #\! out)
-;;            'exception))
-;;          (+ 1 (if (= v 0) (raise 'an-error) (/ 10 v)))))
-;; (let* ((out (open-output-string))
-;;        (value (test-exception-handler-3 0 out)))
-;;   (test 'exception value)
-;;   (test "condition: an-error!" (get-output-string out)))
+(define (test-exception-handler-3 v out)
+  (guard (condition
+          (else
+           (display "condition: " out)
+           (write condition out)
+           (display #\! out)
+           'exception))
+         (+ 1 (if (= v 0) (raise 'an-error) (/ 10 v)))))
+(let* ((out (open-output-string))
+       (value (test-exception-handler-3 0 out)))
+  (test 'exception value)
+  (test "condition: an-error!" (get-output-string out)))
 
-;; (define (test-exception-handler-4 v out)
-;;   (call-with-current-continuation
-;;    (lambda (k)
-;;      (with-exception-handler
-;;       (lambda (x)
-;;         (display "reraised " out)
-;;         (write x out) (display #\! out)
-;;         (k 'zero))
-;;       (lambda ()
-;;         (guard (condition
-;;                 ((positive? condition)
-;;                  'positive)
-;;                 ((negative? condition)
-;;                  'negative))
-;;           (raise v)))))))
+(define (test-exception-handler-4 v out)
+  (call-with-current-continuation
+   (lambda (k)
+     (with-exception-handler
+      (lambda (x)
+        (display "reraised " out)
+        (write x out) (display #\! out)
+        (k 'zero))
+      (lambda ()
+        (guard (condition
+                ((positive? condition)
+                 'positive)
+                ((negative? condition)
+                 'negative))
+          (raise v)))))))
 
 ;; From SRFI-34 "Examples" section - #5
-;; (let* ((out (open-output-string))
-;;        (value (test-exception-handler-4 1 out)))
-;;   (test "" (get-output-string out))
-;;   (test 'positive value))
-;; ;; From SRFI-34 "Examples" section - #6
-;; (let* ((out (open-output-string))
-;;        (value (test-exception-handler-4 -1 out)))
-;;   (test "" (get-output-string out))
-;;   (test 'negative value))
-;; ;; From SRFI-34 "Examples" section - #7
-;; (let* ((out (open-output-string))
-;;        (value (test-exception-handler-4 0 out)))
-;;   (test "reraised 0!" (get-output-string out))
-;;   (test 'zero value))
+(let* ((out (open-output-string))
+       (value (test-exception-handler-4 1 out)))
+  (test "" (get-output-string out))
+  (test 'positive value))
+;; From SRFI-34 "Examples" section - #6
+(let* ((out (open-output-string))
+       (value (test-exception-handler-4 -1 out)))
+  (test "" (get-output-string out))
+  (test 'negative value))
+;; From SRFI-34 "Examples" section - #7
+(let* ((out (open-output-string))
+       (value (test-exception-handler-4 0 out)))
+  (test "reraised 0!" (get-output-string out))
+  (test 'zero value))
 
-;; From SRFI-34 "Examples" section - #8
+;; ;; From SRFI-34 "Examples" section - #8
 ;; (test 42
 ;;     (guard (condition
 ;;             ((assq 'a condition) => cdr)

From f176fadb8914005b0b6a15b04ad6e6f162cda9b5 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 4 Jul 2014 13:21:45 +0900
Subject: [PATCH 09/16] tear off on longjmp

---
 src/cont.c  |  3 +++
 src/error.c |  5 +++++
 src/vm.c    | 16 ++++++++++++++++
 3 files changed, 24 insertions(+)

diff --git a/src/cont.c b/src/cont.c
index df2d8a6b..a5740aa0 100644
--- a/src/cont.c
+++ b/src/cont.c
@@ -164,9 +164,12 @@ native_stack_extend(pic_state *pic, struct pic_cont *cont)
 noreturn static void
 restore_cont(pic_state *pic, struct pic_cont *cont)
 {
+  void pic_vm_tear_off(pic_state *);
   char v;
   struct pic_cont *tmp = cont;
 
+  pic_vm_tear_off(pic);         /* tear off */
+
   if (&v < pic->native_stack_start) {
     if (&v > cont->stk_pos) native_stack_extend(pic, cont);
   }
diff --git a/src/error.c b/src/error.c
index b5ed169e..fb2d63f7 100644
--- a/src/error.c
+++ b/src/error.c
@@ -91,11 +91,16 @@ error_new(pic_state *pic, short type, pic_str *msg, pic_value irrs)
 noreturn void
 pic_throw_error(pic_state *pic, struct pic_error *e)
 {
+  void pic_vm_tear_off(pic_state *);
+
+  pic_vm_tear_off(pic);         /* tear off */
+
   pic->err = e;
   if (! pic->jmp) {
     puts(pic_errmsg(pic));
     abort();
   }
+
   longjmp(*pic->jmp, 1);
 }
 
diff --git a/src/vm.c b/src/vm.c
index 39e0d6f8..2ab80a1e 100644
--- a/src/vm.c
+++ b/src/vm.c
@@ -503,12 +503,28 @@ vm_tear_off(pic_state *pic)
   assert(pic->ci->env != NULL);
 
   env = pic->ci->env;
+
+  if (env->regs == env->storage) {
+    return;                     /* is torn off */
+  }
   for (i = 0; i < env->regc; ++i) {
     env->storage[i] = env->regs[i];
   }
   env->regs = env->storage;
 }
 
+void
+pic_vm_tear_off(pic_state *pic)
+{
+  pic_callinfo *ci;
+
+  for (ci = pic->ci; ci > pic->cibase; ci--) {
+    if (pic->ci->env != NULL) {
+      vm_tear_off(pic);
+    }
+  }
+}
+
 pic_value
 pic_apply0(pic_state *pic, struct pic_proc *proc)
 {

From e3e7c5376292d3f5b35dff7cbcab6b092555e47d Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 15:14:12 +0900
Subject: [PATCH 10/16] fix memory leak

---
 src/cont.c | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/src/cont.c b/src/cont.c
index a5740aa0..bfda7310 100644
--- a/src/cont.c
+++ b/src/cont.c
@@ -167,6 +167,7 @@ restore_cont(pic_state *pic, struct pic_cont *cont)
   void pic_vm_tear_off(pic_state *);
   char v;
   struct pic_cont *tmp = cont;
+  pic_block *blk;
 
   pic_vm_tear_off(pic);         /* tear off */
 
@@ -177,9 +178,10 @@ restore_cont(pic_state *pic, struct pic_cont *cont)
     if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont);
   }
 
-  PIC_BLK_DECREF(pic, pic->blk);
-  PIC_BLK_INCREF(pic, cont->blk);
+  blk = pic->blk;
   pic->blk = cont->blk;
+  PIC_BLK_INCREF(pic, pic->blk);
+  PIC_BLK_DECREF(pic, blk);
 
   pic->stbase = (pic_value *)pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len);
   memcpy(pic->stbase, cont->st_ptr, sizeof(pic_value) * cont->st_len);

From 0c8ef0bd32d76f6dad11f342a75db677176251aa Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 15 Jul 2014 17:47:17 +0900
Subject: [PATCH 11/16] hold destination stack locations by offset

---
 include/picrin/error.h | 4 ++--
 src/error.c            | 8 ++++----
 2 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/include/picrin/error.h b/include/picrin/error.h
index cbaff543..bea590e2 100644
--- a/include/picrin/error.h
+++ b/include/picrin/error.h
@@ -12,8 +12,8 @@ extern "C" {
 struct pic_jmpbuf {
   jmp_buf here;
   struct pic_proc *handler;
-  pic_callinfo *ci;
-  pic_value *sp;
+  ptrdiff_t ci_offset;
+  ptrdiff_t sp_offset;
   pic_code *ip;
   jmp_buf *prev_jmp;
 };
diff --git a/src/error.c b/src/error.c
index fb2d63f7..5987ed25 100644
--- a/src/error.c
+++ b/src/error.c
@@ -47,8 +47,8 @@ pic_push_try(pic_state *pic, struct pic_proc *handler)
 
   try_jmp->handler = handler;
 
-  try_jmp->ci = pic->ci;
-  try_jmp->sp = pic->sp;
+  try_jmp->ci_offset = pic->ci - pic->cibase;
+  try_jmp->sp_offset = pic->sp - pic->stbase;
   try_jmp->ip = pic->ip;
 
   try_jmp->prev_jmp = pic->jmp;
@@ -64,8 +64,8 @@ pic_pop_try(pic_state *pic)
 
   assert(pic->jmp == &try_jmp->here);
 
-  pic->ci = try_jmp->ci;
-  pic->sp = try_jmp->sp;
+  pic->ci += try_jmp->ci_offset;
+  pic->sp += try_jmp->sp_offset;
   pic->ip = try_jmp->ip;
 
   pic->jmp = try_jmp->prev_jmp;

From 4ddf7fb163f1a22a8286dfeb0525d4a00fc1ade8 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 25 Jul 2014 12:02:05 +0900
Subject: [PATCH 12/16] fix a bug in pic_pop_try

---
 src/error.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/error.c b/src/error.c
index 5987ed25..782062a6 100644
--- a/src/error.c
+++ b/src/error.c
@@ -64,8 +64,8 @@ pic_pop_try(pic_state *pic)
 
   assert(pic->jmp == &try_jmp->here);
 
-  pic->ci += try_jmp->ci_offset;
-  pic->sp += try_jmp->sp_offset;
+  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;

From 50879dd7b6195a9029601b7ee928f22a9602f060 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 25 Jul 2014 14:41:56 +0900
Subject: [PATCH 13/16] Allocate pic_blocks in picrin's gc pool; reference
 count may cause problems

---
 include/picrin.h       |  9 +--------
 include/picrin/cont.h  | 37 ++++++++-----------------------------
 include/picrin/value.h |  5 ++++-
 src/codegen.c          |  1 +
 src/cont.c             | 14 ++++----------
 src/gc.c               | 36 +++++++++++++++++++++---------------
 src/macro.c            |  1 +
 src/state.c            | 23 +++++++++++++++--------
 src/system.c           |  2 +-
 9 files changed, 56 insertions(+), 72 deletions(-)

diff --git a/include/picrin.h b/include/picrin.h
index ca043c09..b4036cb5 100644
--- a/include/picrin.h
+++ b/include/picrin.h
@@ -57,18 +57,11 @@ typedef struct {
   struct pic_env *up;
 } pic_callinfo;
 
-typedef struct pic_block {
-  struct pic_block *prev;
-  int depth;
-  struct pic_proc *in, *out;
-  unsigned refcnt;
-} pic_block;
-
 typedef struct {
   int argc;
   char **argv, **envp;
 
-  pic_block *blk;
+  struct pic_block *blk;
 
   pic_value *sp;
   pic_value *stbase, *stend;
diff --git a/include/picrin/cont.h b/include/picrin/cont.h
index b33b6755..0a0da9f1 100644
--- a/include/picrin/cont.h
+++ b/include/picrin/cont.h
@@ -9,11 +9,18 @@
 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;
 
-  pic_block *blk;
+  struct pic_block *blk;
 
   char *stk_pos, *stk_ptr;
   ptrdiff_t stk_len;
@@ -36,34 +43,6 @@ struct pic_cont {
   pic_value results;
 };
 
-#define PIC_BLK_INCREF(pic,blk) do {		\
-    (blk)->refcnt++;				\
-  } while (0)
-
-#define PIC_BLK_DECREF(pic,blk) do {			\
-    pic_block *_a = (blk), *_b;                         \
-    while (_a) {					\
-      if (! --_a->refcnt) {				\
-	_b = _a->prev;					\
-	pic_free((pic), _a);				\
-	_a = _b;					\
-      } else {						\
-	break;						\
-      }							\
-    }							\
-  } while (0)
-
-#define PIC_BLK_EXIT(pic) do {                           \
-    pic_block *_a;                                       \
-    while (pic->blk) {                                   \
-      if (pic->blk->out)                                 \
-        pic_apply0(pic, pic->blk->out);                  \
-      _a = pic->blk->prev;                               \
-      PIC_BLK_DECREF(pic, pic->blk);                     \
-      pic->blk = _a;                                     \
-    }                                                    \
-  } while (0)
-
 pic_value pic_values0(pic_state *);
 pic_value pic_values1(pic_state *, pic_value);
 pic_value pic_values2(pic_state *, pic_value, pic_value);
diff --git a/include/picrin/value.h b/include/picrin/value.h
index 283bac28..023902a3 100644
--- a/include/picrin/value.h
+++ b/include/picrin/value.h
@@ -115,7 +115,8 @@ enum pic_tt {
   PIC_TT_VAR,
   PIC_TT_IREP,
   PIC_TT_DATA,
-  PIC_TT_DICT
+  PIC_TT_DICT,
+  PIC_TT_BLK,
 };
 
 #define PIC_OBJECT_HEADER			\
@@ -268,6 +269,8 @@ pic_type_repr(enum pic_tt tt)
     return "data";
   case PIC_TT_DICT:
     return "dict";
+  case PIC_TT_BLK:
+    return "block";
   }
   UNREACHABLE();
 }
diff --git a/src/codegen.c b/src/codegen.c
index a5c35eb8..8f8d9aed 100644
--- a/src/codegen.c
+++ b/src/codegen.c
@@ -831,6 +831,7 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos)
   case PIC_TT_IREP:
   case PIC_TT_DATA:
   case PIC_TT_DICT:
+  case PIC_TT_BLK:
     pic_errorf(pic, "invalid expression given: ~s", obj);
   }
   UNREACHABLE();
diff --git a/src/cont.c b/src/cont.c
index bfda7310..30d26568 100644
--- a/src/cont.c
+++ b/src/cont.c
@@ -119,7 +119,6 @@ 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;
-  PIC_BLK_INCREF(pic, cont->blk);
 
   cont->stk_len = native_stack_length(pic, &pos);
   cont->stk_pos = pos;
@@ -167,7 +166,7 @@ restore_cont(pic_state *pic, struct pic_cont *cont)
   void pic_vm_tear_off(pic_state *);
   char v;
   struct pic_cont *tmp = cont;
-  pic_block *blk;
+  struct pic_block *blk;
 
   pic_vm_tear_off(pic);         /* tear off */
 
@@ -180,8 +179,6 @@ restore_cont(pic_state *pic, struct pic_cont *cont)
 
   blk = pic->blk;
   pic->blk = cont->blk;
-  PIC_BLK_INCREF(pic, pic->blk);
-  PIC_BLK_DECREF(pic, blk);
 
   pic->stbase = (pic_value *)pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len);
   memcpy(pic->stbase, cont->st_ptr, sizeof(pic_value) * cont->st_len);
@@ -211,7 +208,7 @@ restore_cont(pic_state *pic, struct pic_cont *cont)
 }
 
 static void
-walk_to_block(pic_state *pic, pic_block *here, pic_block *there)
+walk_to_block(pic_state *pic, struct pic_block *here, struct pic_block *there)
 {
   if (here == there)
     return;
@@ -229,7 +226,7 @@ walk_to_block(pic_state *pic, pic_block *here, pic_block *there)
 static pic_value
 pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out)
 {
-  pic_block *here;
+  struct pic_block *here;
   pic_value val;
 
   if (in != NULL) {
@@ -237,17 +234,14 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st
   }
 
   here = pic->blk;
-  pic->blk = (pic_block *)pic_alloc(pic, sizeof(pic_block));
+  pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK);
   pic->blk->prev = here;
   pic->blk->depth = here->depth + 1;
   pic->blk->in = in;
   pic->blk->out = out;
-  pic->blk->refcnt = 1;
-  PIC_BLK_INCREF(pic, here);
 
   val = pic_apply0(pic, thunk);
 
-  PIC_BLK_DECREF(pic, pic->blk);
   pic->blk = here;
 
   if (out != NULL) {
diff --git a/src/gc.c b/src/gc.c
index 1ea3986e..4e3c82ff 100644
--- a/src/gc.c
+++ b/src/gc.c
@@ -322,18 +322,6 @@ gc_free(pic_state *pic, union header *bp)
 static void gc_mark(pic_state *, pic_value);
 static void gc_mark_object(pic_state *pic, struct pic_object *obj);
 
-static void
-gc_mark_block(pic_state *pic, pic_block *blk)
-{
-  while (blk) {
-    if (blk->in)
-      gc_mark_object(pic, (struct pic_object *)blk->in);
-    if (blk->out)
-      gc_mark_object(pic, (struct pic_object *)blk->out);
-    blk = blk->prev;
-  }
-}
-
 static bool
 gc_is_marked(union header *p)
 {
@@ -418,7 +406,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     int i;
 
     /* block */
-    gc_mark_block(pic, cont->blk);
+    gc_mark_object(pic, (struct pic_object *)cont->blk);
 
     /* stack */
     for (stack = cont->st_ptr; stack != cont->st_ptr + cont->sp_offset; ++stack) {
@@ -506,6 +494,20 @@ 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:
@@ -539,7 +541,9 @@ gc_mark_phase(pic_state *pic)
   xh_iter it;
 
   /* block */
-  gc_mark_block(pic, pic->blk);
+  if (pic->blk) {
+    gc_mark_object(pic, (struct pic_object *)pic->blk);
+  }
 
   /* stack */
   for (stack = pic->stbase; stack != pic->sp; ++stack) {
@@ -622,7 +626,6 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
     pic_free(pic, cont->ci_ptr);
     pic_free(pic, cont->arena);
     pic_free(pic, cont->try_jmps);
-    PIC_BLK_DECREF(pic, cont->blk);
     break;
   }
   case PIC_TT_SENV: {
@@ -659,6 +662,9 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
     xh_destroy(&dict->hash);
     break;
   }
+  case PIC_TT_BLK: {
+    break;
+  }
   case PIC_TT_NIL:
   case PIC_TT_BOOL:
   case PIC_TT_FLOAT:
diff --git a/src/macro.c b/src/macro.c
index 597eb57f..a31173de 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -416,6 +416,7 @@ macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
   case PIC_TT_IREP:
   case PIC_TT_DATA:
   case PIC_TT_DICT:
+  case PIC_TT_BLK:
     pic_errorf(pic, "unexpected value type: ~s", expr);
   }
   UNREACHABLE();
diff --git a/src/state.c b/src/state.c
index cdae3901..518d2ea4 100644
--- a/src/state.c
+++ b/src/state.c
@@ -23,18 +23,14 @@ pic_open(int argc, char *argv[], char **envp)
 
   pic = (pic_state *)malloc(sizeof(pic_state));
 
+  /* root block */
+  pic->blk = NULL;
+
   /* command line */
   pic->argc = argc;
   pic->argv = argv;
   pic->envp = envp;
 
-  /* root block */
-  pic->blk = (pic_block *)malloc(sizeof(pic_block));
-  pic->blk->prev = NULL;
-  pic->blk->depth = 0;
-  pic->blk->in = pic->blk->out = NULL;
-  pic->blk->refcnt = 1;
-
   /* prepare VM stack */
   pic->stbase = pic->sp = (pic_value *)calloc(PIC_STACK_SIZE, sizeof(pic_value));
   pic->stend = pic->stbase + PIC_STACK_SIZE;
@@ -135,6 +131,12 @@ pic_open(int argc, char *argv[], char **envp)
   register_renamed_symbol(pic, rEXPORT, "export");
   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->blk->prev = NULL;
+  pic->blk->depth = 0;
+  pic->blk->in = pic->blk->out = NULL;
+
   pic_init_core(pic);
 
   /* set library */
@@ -150,7 +152,12 @@ pic_close(pic_state *pic)
   xh_iter it;
 
   /* invoke exit handlers */
-  PIC_BLK_EXIT(pic);
+  while (pic->blk) {
+    if (pic->blk->out) {
+      pic_apply0(pic, pic->blk->out);
+    }
+    pic->blk = pic->blk->prev;
+  }
 
   /* clear out root objects */
   pic->sp = pic->stbase;
diff --git a/src/system.c b/src/system.c
index 73b27262..633d4a94 100644
--- a/src/system.c
+++ b/src/system.c
@@ -47,7 +47,7 @@ pic_system_exit(pic_state *pic)
     }
   }
 
-  PIC_BLK_EXIT(pic);
+  pic_close(pic);
 
   exit(status);
 }

From 1c718fd4c16ff83d20fb8e1cfaa3611d924159dd Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 25 Jul 2014 14:43:37 +0900
Subject: [PATCH 14/16] unlock dynamic-wind test

---
 t/r7rs-tests.scm | 1 -
 1 file changed, 1 deletion(-)

diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 0b1cc38f..9b3ce733 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -1596,7 +1596,6 @@
 
 (test -1 (call-with-values * -))
 
-#;
 (test '(connect talk1 disconnect
                 connect talk2 disconnect)
       (let ((path '())

From 0111cd19eda9c2c78fa512b7c384f55a331ff871 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 24 Jul 2014 11:45:16 +0900
Subject: [PATCH 15/16] mark error handlers

---
 src/gc.c | 18 ++++++++++++++++--
 1 file changed, 16 insertions(+), 2 deletions(-)

diff --git a/src/gc.c b/src/gc.c
index 4e3c82ff..bd907524 100644
--- a/src/gc.c
+++ b/src/gc.c
@@ -403,7 +403,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;
-    int i;
+    size_t i;
 
     /* block */
     gc_mark_object(pic, (struct pic_object *)cont->blk);
@@ -421,10 +421,17 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
     }
 
     /* arena */
-    for (i = 0; i < cont->arena_idx; ++i) {
+    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;
@@ -578,6 +585,13 @@ gc_mark_phase(pic_state *pic)
     gc_mark_object(pic, xh_val(it.e, struct pic_object *));
   }
 
+  /* error handlers */
+  for (i = 0; i < pic->try_jmp_idx; ++i) {
+    if (pic->try_jmps[i].handler) {
+      gc_mark_object(pic, (struct pic_object *)pic->try_jmps[i].handler);
+    }
+  }
+
   /* library table */
   gc_mark(pic, pic->lib_tbl);
 }

From a38ba15010e8284725a3656dbc73dcabd4e5292f Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 24 Jul 2014 11:45:28 +0900
Subject: [PATCH 16/16] raise-continuable broken

---
 src/error.c | 11 +++++------
 1 file changed, 5 insertions(+), 6 deletions(-)

diff --git a/src/error.c b/src/error.c
index 782062a6..971a0b47 100644
--- a/src/error.c
+++ b/src/error.c
@@ -180,19 +180,18 @@ static pic_value
 pic_error_raise_continuable(pic_state *pic)
 {
   pic_value v;
-  size_t i;
 
   pic_get_args(pic, "o", &v);
 
-  if (pic->try_jmps->handler == NULL) {
-    pic_errorf(pic, "uncontinuable exception handler is on top");
-  }
-  if ((i = pic->try_jmp_idx) == 0) {
+  if (pic->try_jmp_idx == 0) {
     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->handler, v);
+    v = pic_apply1(pic, pic->try_jmps[pic->try_jmp_idx].handler, v);
     ++pic->try_jmp_idx;
   }
   return v;