From 0001f0bdcbb52c86fc1a82236e2d92f5e43d9505 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Fri, 21 Mar 2014 10:20:00 +0900
Subject: [PATCH] Adding exception-protect.

---
 lib/init-7.scm | 23 +++++++++++++++++++++++
 1 file changed, 23 insertions(+)

diff --git a/lib/init-7.scm b/lib/init-7.scm
index ba4c66c4..4fd39f73 100644
--- a/lib/init-7.scm
+++ b/lib/init-7.scm
@@ -994,6 +994,29 @@
          (begin result1 result2 ...)
          (protect-aux reraise clause1 clause2 ...)))))
 
+;; Similar to unwind-protect, but allows escape via continuations
+;; assuming they'll return, whereas exceptions are assumed to not return.
+(define (with-exception-protect thunk final)
+  (let ((finalized? #f)
+        (run-finalize
+         (lambda ()
+           (cond ((not finalized?)
+                  (set! finalized? #t)
+                  (final))))))
+    (with-exception-handler
+     (lambda (exn)
+       (run-finalize)
+       (raise exn))
+     (lambda ()
+       (let ((res (thunk)))
+         (run-finalize)
+         res)))))
+
+(define-syntax exception-protect
+  (syntax-rules ()
+    ((exception-protect expr final)
+     (with-exception-protect (lambda () expr)  (lambda () final)))))
+
 (define (eval x . o)
   (let ((thunk (compile x (if (pair? o) (car o) (interaction-environment)))))
     (if (procedure? thunk) (thunk) (raise thunk))))