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

[Erik Huelsmann]

Author: ehuelsmann
Date: Sun May 10 17:21:44 2009
New Revision: 11853

Log:
Restore closure variables from their saved values,
in case of a non-local transfer of control (ie,
a Java exception), such as GO or RETURN-FROM in
the callee.

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

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 10 17:21:44 2009
@@ -3020,7 +3020,10 @@
          (args (cdr form))
          (local-function (find-local-function op))
          (*register* *register*)
-         (saved-vars '()))
+         (saved-vars '())
+         (label-START (gensym))
+         (label-END (gensym))
+         (label-EXIT (gensym)))
     (cond ((local-function-variable local-function)
            ;; LABELS
            (dformat t "compile-local-function-call LABELS case variable = ~S~%"
@@ -3031,6 +3034,8 @@
                                     (compiland-arg-vars (local-function-compiland local-function))
                                     *visible-variables*))))
 ;;            (emit 'var-ref (local-function-variable local-function) 'stack)
+           (when saved-vars
+             (label label-START))
            (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil))
           (t
            (dformat t "compile-local-function-call default case~%")
@@ -3049,7 +3054,16 @@
     (fix-boxing representation nil)
     (emit-move-from-stack target representation)
     (when saved-vars
-      (restore-variables saved-vars)))
+      (emit 'goto label-EXIT)
+      (label label-END)
+      (restore-variables saved-vars)
+      (emit 'athrow)
+      (label label-EXIT)
+      (restore-variables saved-vars)
+      (push (make-handler :from label-START
+                          :to label-END
+                          :code label-END
+                          :catch-type 0) *handlers*)))
   t)