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

[Erik Huelsmann]

Author: ehuelsmann
Date: Sun May  3 08:19:19 2009
New Revision: 11821

Log:
Be more exact on determining 'being enclosed by a block which
sets (= modifies) the environment'.

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

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 08:19:19 2009
@@ -363,6 +363,7 @@
   non-local-go-p
   ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the
   ;; environment, with GO forms in them which target tags in this TAGBODY
+  ;; Non-nil if and only if the block doesn't modify the environment
   needs-environment-restoration
   ;; If non-nil, register containing saved dynamic environment for this block.
   environment-register
@@ -400,7 +401,7 @@
   (memq (block-name object) '(CATCH UNWIND-PROTECT)))
 
 
-(defknown enclosed-by-protected-block-p (&optional outermost-block) boolean)
+(defknown enclosed-by-protected-block-p (&optional t) boolean)
 (defun enclosed-by-protected-block-p (&optional outermost-block)
   "Indicates whether the code being compiled/analyzed is enclosed in
 a block which requires a non-local transfer of control exception to
@@ -412,13 +413,13 @@
     (when (block-requires-non-local-exit-p enclosing-block)
       (return-from enclosed-by-protected-block-p t))))
 
-(defknown enclosed-by-environment-setting-block-p (&optional outermost-block)
-  boolean)
+(defknown enclosed-by-environment-setting-block-p (&optional t) boolean)
 (defun enclosed-by-environment-setting-block-p (&optional outermost-block)
   (dolist (enclosing-block *blocks*)
     (when (eq enclosing-block outermost-block)
       (return nil))
-    (when (block-environment-register enclosing-block)
+    (when (and (block-environment-register enclosing-block)
+               (not (block-needs-environment-restoration enclosing-block)))
       (return t))))
 
 (defstruct tag