0.8.7.15:
[sbcl.git] / tests / condition.pure.lisp
1 ;;;; side-effect-free tests of the condition system
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
16 ;;; Until 0.7.7.21, (MAKE-CONDITION 'FILE-ERROR :PATHNAME "FOO")
17 ;;; wasn't printable, because the REPORT function for FILE-ERROR
18 ;;; referred to unbound slots. This was reported and fixed by Antonio
19 ;;; Martinez (sbcl-devel 2002-09-10).
20 (format t
21         "~&printable now: ~A~%"
22         (make-condition 'file-error :pathname "foo"))
23
24 (assert (eq
25          (block nil
26            (macrolet ((opaque-error (arg) `(error ,arg)))
27              (handler-bind
28                  ((error (lambda (c)
29                            (let ((restarts (remove 'res (compute-restarts c)
30                                                    :key #'restart-name
31                                                    :test-not #'eql)))
32                              (assert (= (length restarts) 2))
33                              (invoke-restart (second restarts))))))
34                (let ((foo1 (make-condition 'error))
35                      (foo2 (make-condition 'error)))
36                  (restart-case
37                      (with-condition-restarts foo1 (list (find-restart 'res))
38                        (restart-case
39                            (opaque-error foo2)
40                          (res () 'int1)
41                          (res () 'int2)))
42                    (res () 'ext))))))
43          'int2))
44
45 (assert (eq
46          (block nil
47            (macrolet ((opaque-error (arg) `(error ,arg)))
48              (let ((foo1 (make-condition 'error))
49                    (foo2 (make-condition 'error)))
50                (handler-bind
51                    ((error (lambda (c)
52                              (let ((restarts (remove 'res (compute-restarts foo1)
53                                                      :key #'restart-name
54                                                      :test-not #'eql)))
55                                (assert (= (length restarts) 1))
56                                (invoke-restart (first restarts))))))
57                  (restart-case
58                      (with-condition-restarts foo1 (list (find-restart 'res))
59                        (restart-case
60                            (opaque-error foo2)
61                          (res () 'int1)
62                          (res () 'int2)))
63                    (res () 'ext))))))
64          'ext))
65
66 (assert (eq
67          'ext
68          (block nil
69            (let ((visible nil)
70                  (c1 (make-condition 'error))
71                  (c2 (make-condition 'error)))
72              (handler-bind
73                  ((error
74                    (lambda (c)
75                      (declare (ignore c))
76                      (flet ((check-restarts (length)
77                               (assert (= length
78                                          (length (remove 'foo (compute-restarts c1)
79                                                          :key #'restart-name
80                                                          :test-not #'eql))))))
81                        (check-restarts 1)
82                        (setq visible t)
83                        (check-restarts 1)
84                        (invoke-restart (find-restart 'foo c1))))))
85                (restart-case
86                    (restart-case
87                        (error c2)
88                      (foo () 'in1)
89                      (foo () :test (lambda (c) (declare (ignore c)) visible)
90                           'in2))
91                  (foo () 'ext)))))))
92
93 ;;; First argument of CERROR is a format control
94 (assert
95  (eq (block nil
96        (handler-bind
97            ((type-error (lambda (c) (return :failed)))
98             (simple-error (lambda (c)
99                             (return (if (find-restart 'continue)
100                                         :passed
101                                         :failed)))))
102          (cerror (formatter "Continue from ~A") "bug ~A" :bug)))
103      :passed))
104
105 ;;; clauses in HANDLER-CASE are allowed to have declarations (and
106 ;;; indeed, only declarations)
107 (assert 
108  (null (handler-case (error "foo") (error () (declare (optimize speed))))))