X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fexhaust.impure.lisp;h=79f44a4e671941dacb213241956dd348456179f5;hb=94b8f6d07445666017dfeac29bbbe0863a3c2de2;hp=fc432b4f4802549e6b415952becdc0145ddfd900;hpb=ee61a0d8cefb5ccfba266a1e0407415adb88b150;p=sbcl.git

diff --git a/tests/exhaust.impure.lisp b/tests/exhaust.impure.lisp
index fc432b4..79f44a4 100644
--- a/tests/exhaust.impure.lisp
+++ b/tests/exhaust.impure.lisp
@@ -6,7 +6,7 @@
 ;;;; While most of SBCL is derived from the CMU CL system, the test
 ;;;; files (like this one) were written from scratch after the fork
 ;;;; from CMU CL.
-;;;; 
+;;;;
 ;;;; This software is in the public domain and is provided with
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
@@ -21,12 +21,53 @@
 ;;; Post 0.7.6.1, this was rewritten to use mprotect()-based stack
 ;;; protection which does not require lisp code to check anything,
 ;;; and works at all optimization settings.  However, it now signals a
-;;; STORAGE-CONDITION instead of an ERROR, so this test needs revising
-(locally
-  (defun recurse () (recurse) (recurse))
-  (handler-case
-    (recurse)
-    (storage-condition (c) (declare (ignore c)) (quit :unix-status 104))))
-
-;;; oops
-(quit :unix-status 1)
+;;; STORAGE-CONDITION instead of an ERROR.
+
+(defun recurse ()
+  (recurse)
+  (recurse))
+
+(defvar *count* 100)
+
+;;; Base-case: detecting exhaustion
+(assert (eq :exhausted
+            (handler-case
+                (recurse)
+              (storage-condition (c)
+                (declare (ignore c))
+                :exhausted))))
+
+;;; Check that non-local control transfers restore the stack
+;;; exhaustion checking after unwinding -- and that previous test
+;;; didn't break it.
+(let ((exhaust-count 0)
+      (recurse-count 0))
+  (tagbody
+     :retry
+     (handler-bind ((storage-condition (lambda (c)
+                                         (declare (ignore c))
+                                         (if (= *count* (incf exhaust-count))
+                                             (go :stop)
+                                             (go :retry)))))
+       (incf recurse-count)
+       (recurse))
+     :stop)
+  (assert (= exhaust-count recurse-count *count*)))
+
+;;; Check that we can safely use user-provided restarts to
+;;; unwind.
+(let ((exhaust-count 0)
+      (recurse-count 0))
+  (block nil
+   (handler-bind ((storage-condition (lambda (c)
+                                       (declare (ignore c))
+                                       (if (= *count* (incf exhaust-count))
+                                           (return)
+                                           (invoke-restart (find-restart 'ok))))))
+      (loop
+       (with-simple-restart (ok "ok")
+         (incf recurse-count)
+         (recurse)))))
+  (assert (= exhaust-count recurse-count *count*)))
+
+;;; OK!