Changeset 11819 for trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Timestamp:

05/03/09 08:46:39 (14 years ago)

Author:

ehuelsmann

Message:

Small refactoring: introduce a centralized definition of
"enclosed by a block which associates extensive cleanup
with a transfer of control exception".

Also some reordering of functions in jvm.lisp.

File:

• trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (modified) (3 diffs)

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

@@ -4439 +4439 @@
       (compile-progn-body body target representation))))
 
-(defknown find-tag (t) t)
-(defun find-tag (name)
-  (dolist (tag *visible-tags*)
-    (when (eql name (tag-name tag))
-      (return tag))))
-
 (defknown p2-tagbody-node (t t) t)
 (defun p2-tagbody-node (block target)
@@ -4535 +4529 @@
       ;; Local case.
       (let* ((tag-block (tag-block tag))
-             (register nil)
-             (protected
-              ;; Does the GO leave an enclosing CATCH or UNWIND-PROTECT?
-              (dolist (enclosing-block *blocks*)
-                (when (eq enclosing-block tag-block)
-                  (return nil))
-                (when (block-requires-non-local-exit-p enclosing-block)
-                  (return t)))))
-        (unless protected
+             (register nil))
+        (unless (enclosed-by-protected-block-p tag-block)
           (dolist (block *blocks*)
             (if (eq block tag-block)
@@ -4723 +4710 @@
         ;; Local case. Is the RETURN nested inside an UNWIND-PROTECT which is
         ;; inside the block we're returning from?
-        (let ((protected
-               (dolist (enclosing-block *blocks*)
-                 (when (eq enclosing-block block)
-                   (return nil))
-                 (when (block-requires-non-local-exit-p enclosing-block)
-                   (return t)))))
-          (unless protected
-            (unless (compiland-single-valued-p *current-compiland*)
+        (unless (enclosed-by-protected-block-p block)
+          (unless (compiland-single-valued-p *current-compiland*)
 ;;               (format t "compiland not single-valued: ~S~%"
 ;;                       (compiland-name *current-compiland*))
-              (emit-clear-values))
-            (compile-form result-form (block-target block) nil)
-            (emit 'goto (block-exit block))
-            (return-from p2-return-from)))))
+            (emit-clear-values))
+          (compile-form result-form (block-target block) nil)
+          (emit 'goto (block-exit block))
+          (return-from p2-return-from))))
     ;; Non-local RETURN.
     (aver (block-non-local-return-p block))