compiler: implement unwind-protect.

* share/txr/stdlib/compiler.tl (compiler compile): Wire in
unwind-protect case via comp-unwind-protect method.
(compiler comp-unwind-protect): New method.

1 files changed, 25 insertions, 0 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index f1e1401a..403263ce 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -161,6 +161,7 @@
             (sys:setq me.(comp-setq oreg env form))
             (cond me.(comp-cond oreg env form))
             (if me.(comp-if oreg env form))
+            (unwind-protect me.(comp-unwind-protect oreg env form))
             (block me.(comp-block oreg env form))
             (return-from me.(comp-return-from oreg env form))
             (return me.(comp-return oreg env form))
@@ -348,6 +349,30 @@
     ((op) me.(compile oreg env nil))
     (form (compile-error form "excess argument forms"))))
 
+(defmeth compiler comp-unwind-protect (me oreg env form)
+  (mac-param-bind form (op prot-form . cleanup-body) form
+    (let* ((pfrag me.(compile oreg env prot-form))
+           (cfrag me.(comp-progn oreg env cleanup-body))
+           (lclean (gensym "l"))
+           (lskip (gensym "l")))
+      (cond
+        ((null pfrag.code)
+         (new (frag pfrag.oreg
+                    cfrag.code
+                    cfrag.fvars
+                    cfrag.ffuns)))
+        ((null cfrag.code) pfrag)
+        (t (new (frag pfrag.oreg
+                      ^((uwprot ,lclean)
+                        ,*pfrag.code
+                        (jmp ,lskip)
+                        ,lclean
+                        ,*cfrag.code
+                        (end nil)
+                        ,lskip)
+                      (uni pfrag.fvars pfrag.fvars)
+                      (uni cfrag.fvars cfrag.fvars))))))))
+
 (defmeth compiler comp-block (me oreg env form)
   (mac-param-bind form (op name . body) form
     (let* ((nreg (if name me.(get-dreg name) '(t 0)))