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

diff --git a/tests/exhaust.impure.lisp b/tests/exhaust.impure.lisp
index 0956f29..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.
@@ -14,13 +14,60 @@
 (cl:in-package :cl-user)
 
 ;;; Prior to sbcl-0.7.1.38, doing something like (RECURSE), even in
-;;; safe code, would crash the entire Lisp process. Now it should
-;;; signal an error in a context where the soft stack limit has been
-;;; relaxed enough that the error can be handled.
-(locally
-  (declare (optimize safety))
-  (defun recurse () (recurse) (recurse))
-  (ignore-errors (recurse)))
-
-;;; success
-(quit :unix-status 104)
+;;; safe code, would crash the entire Lisp process. Then the soft
+;;; stack checking was introduced, which checked (in safe code) for
+;;; stack exhaustion at each lambda.
+
+;;; 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.
+
+(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!