0b071d85cfcbb9ec40f256eaed3cd0305ebe9226
[sbcl.git] / 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 (load "test-util.lisp")
17
18 ;;; Until 0.7.7.21, (MAKE-CONDITION 'FILE-ERROR :PATHNAME "FOO")
19 ;;; wasn't printable, because the REPORT function for FILE-ERROR
20 ;;; referred to unbound slots. This was reported and fixed by Antonio
21 ;;; Martinez (sbcl-devel 2002-09-10).
22 (format t
23         "~&printable now: ~A~%"
24         (make-condition 'file-error :pathname "foo"))
25
26 (assert (eq
27          (block nil
28            (macrolet ((opaque-error (arg) `(error ,arg)))
29              (handler-bind
30                  ((error (lambda (c)
31                            (let ((restarts (remove 'res (compute-restarts c)
32                                                    :key #'restart-name
33                                                    :test-not #'eql)))
34                              (assert (= (length restarts) 2))
35                              (invoke-restart (second restarts))))))
36                (let ((foo1 (make-condition 'error))
37                      (foo2 (make-condition 'error)))
38                  (restart-case
39                      (with-condition-restarts foo1 (list (find-restart 'res))
40                        (restart-case
41                            (opaque-error foo2)
42                          (res () 'int1)
43                          (res () 'int2)))
44                    (res () 'ext))))))
45          'int2))
46
47 (assert (eq
48          (block nil
49            (macrolet ((opaque-error (arg) `(error ,arg)))
50              (let ((foo1 (make-condition 'error))
51                    (foo2 (make-condition 'error)))
52                (handler-bind
53                    ((error (lambda (c)
54                              (let ((restarts (remove 'res (compute-restarts foo1)
55                                                      :key #'restart-name
56                                                      :test-not #'eql)))
57                                (assert (= (length restarts) 1))
58                                (invoke-restart (first restarts))))))
59                  (restart-case
60                      (with-condition-restarts foo1 (list (find-restart 'res))
61                        (restart-case
62                            (opaque-error foo2)
63                          (res () 'int1)
64                          (res () 'int2)))
65                    (res () 'ext))))))
66          'ext))
67
68 (assert (eq
69          'ext
70          (block nil
71            (let ((visible nil)
72                  (c1 (make-condition 'error))
73                  (c2 (make-condition 'error)))
74              (handler-bind
75                  ((error
76                    (lambda (c)
77                      (declare (ignore c))
78                      (flet ((check-restarts (length)
79                               (assert (= length
80                                          (length (remove 'foo (compute-restarts c1)
81                                                          :key #'restart-name
82                                                          :test-not #'eql))))))
83                        (check-restarts 1)
84                        (setq visible t)
85                        (check-restarts 1)
86                        (invoke-restart (find-restart 'foo c1))))))
87                (restart-case
88                    (restart-case
89                        (error c2)
90                      (foo () 'in1)
91                      (foo () :test (lambda (c) (declare (ignore c)) visible)
92                           'in2))
93                  (foo () 'ext)))))))
94
95 ;;; First argument of CERROR is a format control
96 (assert
97  (eq (block nil
98        (handler-bind
99            ((type-error (lambda (c) (return :failed)))
100             (simple-error (lambda (c)
101                             (return (if (find-restart 'continue)
102                                         :passed
103                                         :failed)))))
104          (cerror (formatter "Continue from ~A") "bug ~A" :bug)))
105      :passed))
106
107 ;;; clauses in HANDLER-CASE are allowed to have declarations (and
108 ;;; indeed, only declarations)
109 (assert
110  (null (handler-case (error "foo") (error () (declare (optimize speed))))))
111
112 (handler-case
113     (handler-bind ((warning #'muffle-warning))
114       (signal 'warning))
115   ;; if it's a control error, it had better be printable
116   (control-error (c) (format nil "~A" c))
117   ;; there had better be an error
118   (:no-error (&rest args) (error "No error: ~S" args)))
119
120 (handler-case
121     (funcall (lambda (x) (check-type x fixnum) x) t)
122   (type-error (c)
123     (assert (and (subtypep (type-error-expected-type c) 'fixnum)
124                  (subtypep 'fixnum (type-error-expected-type c))))
125     (assert (eq (type-error-datum c) t)))
126   (:no-error (&rest rest) (error "no error: ~S" rest)))
127
128 ;;; ANSI specifies TYPE-ERROR if datum and arguments of ERROR are not
129 ;;; designators for a condition. Reported by Bruno Haible on cmucl-imp
130 ;;; 2004-10-12.
131 (flet ((test (&rest args)
132          (multiple-value-bind (res err)
133              (ignore-errors (apply #'error args))
134            (assert (not res))
135            (assert (typep err 'type-error))
136            (assert (not (nth-value 1 (ignore-errors
137                                        (type-error-datum err)))))
138            (assert (not (nth-value 1 (ignore-errors
139                                        (type-error-expected-type err))))))))
140   (test '#:no-such-condition)
141   (test nil)
142   (test t)
143   (test 42)
144   (test (make-instance 'standard-object)))
145
146 ;;; If CERROR is given a condition, any remaining arguments are only
147 ;;; used for the continue format control.
148 (let ((x 0))
149   (handler-bind
150       ((simple-error (lambda (c) (incf x) (continue c))))
151     (cerror "Continue from ~A at ~A"
152             (make-condition 'simple-error :format-control "foo"
153                             :format-arguments nil)
154             'cerror (get-universal-time))
155     (assert (= x 1))))
156
157 (with-test (:name :malformed-restart-case-clause)
158   (assert (eq :ok
159               (handler-case
160                   (macroexpand `(restart-case (error "foo")
161                                   (foo :report "quux" (quux))))
162                 (simple-error (e)
163                   (assert (equal '(restart-case (foo :report "quux" (quux)))
164                                  (simple-condition-format-arguments e)))
165                   :ok)))))
166
167 (with-test (:name :simple-condition-without-args)
168   (let ((sc (make-condition 'simple-condition)))
169     (assert (not (simple-condition-format-control sc)))
170     (assert (not (simple-condition-format-arguments sc)))
171     (assert (stringp (prin1-to-string sc)))
172     (assert
173      (eq :ok
174          (handler-case
175              (princ-to-string sc)
176            (simple-error (c)
177              (when (and (equal "No format-control for ~S"
178                                (simple-condition-format-control c))
179                         (eq sc (car
180                                 (simple-condition-format-arguments c))))
181                :ok)))))))
182
183 (with-test (:name :malformed-simple-condition-printing-type-error)
184   (assert (eq :type-error
185               (handler-case
186                   (princ-to-string
187                    (make-condition 'simple-error :format-control "" :format-arguments 8))
188                 (type-error (e)
189                   (when (and (eq 'list (type-error-expected-type e))
190                              (eql 8 (type-error-datum e)))
191                     :type-error))))))