[armedbear-cvs] r11825 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Sun May  3 15:50:20 2009
New Revision: 11825

Log:
Compilation P1:
* Set up a CATCH block before processing the subforms.
* Exclude the unwinding forms from the UNWIND-PROTECT
  block: they are themselves not protected by their
  own block.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	Sun May  3 15:50:20 2009
@@ -272,6 +272,10 @@
 (defun p1-catch (form)
   (let* ((tag (p1 (cadr form)))
          (body (cddr form))
+         (block (make-block-node '(CATCH)))
+         ;; our subform processors need to know
+         ;; they're enclosed in a CATCH block
+         (*blocks* (cons block *blocks*))
          (result '()))
     (dolist (subform body)
       (let ((op (and (consp subform) (%car subform))))
@@ -285,16 +289,22 @@
       (return-from p1-catch (car result)))
     (push tag result)
     (push 'CATCH result)
-    (let ((block (make-block-node '(CATCH))))
-      (setf (block-form block) result)
-      block)))
+    (setf (block-form block) result)
+    block))
 
 (defun p1-unwind-protect (form)
   (if (= (length form) 2)
       (p1 (second form)) ; No cleanup forms: (unwind-protect (...)) => (...)
       (let* ((block (make-block-node '(UNWIND-PROTECT)))
-             (*blocks* (cons block *blocks*)))
-        (setf (block-form block) (p1-default form))
+             ;; a bit of jumping through hoops...
+             (unprotected-forms (p1-body (cddr form)))
+             ;; ... because only the protected form is
+             ;; protected by the UNWIND-PROTECT block
+             (*blocks* (cons block *blocks*))
+             (protected-form (p1 (cadr form))))
+        (setf (block-form block)
+              `(unwind-protect ,protected-form
+                 , at unprotected-forms))
         block)))
 
 (defknown p1-return-from (t) t)