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

[Erik Huelsmann]

Author: ehuelsmann
Date: Sun May  3 04:07:28 2009
New Revision: 11818

Log:
Harmonize the concept of 'block needing non-local-exit'
by centralizing the definition.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/jvm.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 04:07:28 2009
@@ -316,7 +316,7 @@
                   (dolist (enclosing-block *blocks*)
                     (when (eq enclosing-block block)
                       (return nil))
-                    (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
+                    (when (block-requires-non-local-exit-p enclosing-block)
                       (return t)))))
              (dformat t "p1-return-from protected = ~S~%" protected)
              (when protected
@@ -369,7 +369,7 @@
                     (dolist (enclosing-block *blocks*)
                       (when (eq enclosing-block tag-block)
                         (return nil))
-                      (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
+                      (when (block-requires-non-local-exit-p enclosing-block)
                         (return t)))))
                (when protected
                  (setf (block-non-local-go-p tag-block) t))))
@@ -695,6 +695,9 @@
 (defknown p1-progv (t) t)
 (defun p1-progv (form)
   ;; We've already checked argument count in PRECOMPILE-PROGV.
+
+  ;; ### FIXME: we need to return a block here, so that
+  ;;  (local) GO in p2 can restore the lastSpecialBinding environment
   (let ((new-form (rewrite-progv form)))
     (when (neq new-form form)
       (return-from p1-progv (p1 new-form))))

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun May  3 04:07:28 2009
@@ -4540,10 +4540,8 @@
               (dolist (enclosing-block *blocks*)
                 (when (eq enclosing-block tag-block)
                   (return nil))
-                (let ((block-name (block-name enclosing-block)))
-                  (when (or (equal block-name '(CATCH))
-                            (equal block-name '(UNWIND-PROTECT)))
-                    (return t))))))
+                (when (block-requires-non-local-exit-p enclosing-block)
+                  (return t)))))
         (unless protected
           (dolist (block *blocks*)
             (if (eq block tag-block)
@@ -4728,7 +4726,7 @@
                (dolist (enclosing-block *blocks*)
                  (when (eq enclosing-block block)
                    (return nil))
-                 (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
+                 (when (block-requires-non-local-exit-p enclosing-block)
                    (return t)))))
           (unless protected
             (unless (compiland-single-valued-p *current-compiland*)

Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp	Sun May  3 04:07:28 2009
@@ -379,6 +379,16 @@
         (t
          nil)))
 
+(defknown block-requires-non-local-exit-p (t) boolean)
+(defun block-requires-non-local-exit-p (object)
+  "A block which *always* requires a 'non-local-exit' is a block which
+requires a transfer control exception to be thrown: e.g. Go and Return.
+
+Non-local exits are required by blocks which do more in their cleanup
+than just restore the lastSpecialBinding (= dynamic environment).
+"
+  (memq (block-name object) '(CATCH UNWIND-PROTECT)))
+
 (defvar *blocks* ())
 
 (defun find-block (name)