0.9.1.16:
[sbcl.git] / tests / exhaust.impure.lisp
1 ;;;; tests of the system's ability to catch resource exhaustion problems
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; from CMU CL.
9 ;;;; 
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
13
14 (cl:in-package :cl-user)
15 \f
16 ;;; Prior to sbcl-0.7.1.38, doing something like (RECURSE), even in
17 ;;; safe code, would crash the entire Lisp process. Then the soft
18 ;;; stack checking was introduced, which checked (in safe code) for
19 ;;; stack exhaustion at each lambda.
20
21 ;;; Post 0.7.6.1, this was rewritten to use mprotect()-based stack
22 ;;; protection which does not require lisp code to check anything,
23 ;;; and works at all optimization settings.  However, it now signals a
24 ;;; STORAGE-CONDITION instead of an ERROR.
25
26 (defun recurse () 
27   (recurse) 
28   (recurse))
29
30 (defvar *count* 100)
31
32 ;;; Base-case: detecting exhaustion
33 (assert (eq :exhausted
34             (handler-case
35                 (recurse)
36               (storage-condition (c) 
37                 (declare (ignore c))
38                 :exhausted))))
39
40 ;;; Check that non-local control transfers restore the stack
41 ;;; exhaustion checking after unwinding -- and that previous test
42 ;;; didn't break it.
43 (let ((exhaust-count 0)
44       (recurse-count 0))
45   (tagbody
46      :retry
47      (handler-bind ((storage-condition (lambda (c)
48                                          (declare (ignore c))
49                                          (if (= *count* (incf exhaust-count))
50                                              (go :stop)
51                                              (go :retry)))))
52        (incf recurse-count)
53        (recurse))
54      :stop)
55   (assert (= exhaust-count recurse-count *count*)))
56
57 ;;; Check that we can safely use user-provided restarts to
58 ;;; unwind.
59 (let ((exhaust-count 0)
60       (recurse-count 0))
61   (block nil
62    (handler-bind ((storage-condition (lambda (c)
63                                        (declare (ignore c))
64                                        (if (= *count* (incf exhaust-count))
65                                            (return)
66                                            (invoke-restart (find-restart 'ok))))))
67       (loop
68        (with-simple-restart (ok "ok")
69          (incf recurse-count)
70          (recurse)))))
71   (assert (= exhaust-count recurse-count *count*)))
72
73 ;;; OK!
74 (quit :unix-status 104)