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

[Erik Huelsmann]

Author: ehuelsmann
Date: Wed Dec 30 17:04:55 2009
New Revision: 12314

Log:
Upon OutOfMemoryError or StackOverflowError, unwind the stack
  to the first enclosing HANDLER-BIND, allowing it to bind a
  handler to STORAGE-CONDITION.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Java.java
   trunk/abcl/src/org/armedbear/lisp/signal.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Java.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Java.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Java.java	Wed Dec 30 17:04:55 2009
@@ -930,7 +930,28 @@
 	    }
         }
     };
-    
+
+
+    private static final Primitive JRUN_EXCEPTION_PROTECTED =
+        new Primitive("jrun-exception-protected", PACKAGE_JAVA, true,
+                      "closure") {
+
+      @Override
+      public LispObject execute(LispObject closure) {
+          Function fun = checkFunction(closure);
+
+          try {
+              return LispThread.currentThread().execute(closure);
+          }
+          catch (OutOfMemoryError oom) {
+              return error(new StorageCondition("Out of memory."));
+          }
+          catch (StackOverflowError oos) {
+              return error(new StorageCondition("Stack overflow."));
+          }
+      }
+    };
+
     private static PropertyDescriptor getPropertyDescriptor(Object obj, LispObject propertyName) throws IntrospectionException {
         String prop = ((AbstractString) propertyName).getStringValue();
         BeanInfo beanInfo = Introspector.getBeanInfo(obj.getClass());

Modified: trunk/abcl/src/org/armedbear/lisp/signal.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/signal.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/signal.lisp	Wed Dec 30 17:04:55 2009
@@ -105,8 +105,10 @@
           (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x)))
                                 bindings))
                 *handler-clusters*)))
-     (progn
-       , at forms)))
+     (java:jrun-exception-protected
+      (lambda ()
+        (progn
+          , at forms)))))
 
 (defmacro handler-case (form &rest cases)
   (let ((no-error-clause (assoc ':no-error cases)))