Changeset 11818

Timestamp:

05/03/09 08:07:28 (14 years ago)

Author:

ehuelsmann

Message:

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

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• compiler-pass1.lisp (modified) (3 diffs)
• compiler-pass2.lisp (modified) (2 diffs)
• jvm.lisp (modified) (1 diff)

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

@@ -317 +317 @@
                     (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)
@@ -370 +370 @@
                       (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
@@ -696 +696 @@
 (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)

trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -4541 +4541 @@
                 (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*)
@@ -4729 +4727 @@
                  (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

trunk/abcl/src/org/armedbear/lisp/jvm.lisp

@@ -380 +380 @@
          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* ())