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

[Erik Huelsmann]

Author: ehuelsmann
Date: Tue Jul 28 02:23:20 2009
New Revision: 12071

Log:
Retain values across execution of unwinding forms
in unwind protect, in case of errors/non-local returns.

Found by: Alan Ruttenberg.

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

Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java	Tue Jul 28 02:23:20 2009
@@ -3711,16 +3711,17 @@
         try
           {
             result = eval(args.car(), env, thread);
-            values = thread._values;
           }
         finally
           {
+            values = thread._values;
             LispObject body = args.cdr();
             while (body != NIL)
               {
                 eval(body.car(), env, thread);
                 body = ((Cons)body).cdr;
               }
+            thread._values = values;
           }
         if (values != null)
           thread.setValues(values);

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	Tue Jul 28 02:23:20 2009
@@ -7828,10 +7828,16 @@
       (label HANDLER) ; Start of exception handler.
       ;; The Throwable object is on the runtime stack. Stack depth is 1.
       (astore exception-register)
+      (emit-push-current-thread)
+      (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+)
+      (astore values-register)
       (let ((*register* *register*))
         (dolist (subform cleanup-forms)
           (compile-form subform nil nil)))
       (maybe-emit-clear-values cleanup-forms)
+      (emit-push-current-thread)
+      (aload values-register)
+      (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+)
       (aload exception-register)
       (emit 'athrow) ; Re-throw exception.
       (label EXIT)