Remove private keywords from sb-thread:make-mutex.
[sbcl.git] / tests / condition.pure.lisp
blob0e374e9334cb881dde1c249c2688c65849baf3b0
1 ;;;; side-effect-free tests of the condition system
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.
14 (cl:in-package :cl-user)
16 (load "test-util.lisp")
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"))
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))
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 (declare (ignore c))
55 (let ((restarts (remove 'res (compute-restarts foo1)
56 :key #'restart-name
57 :test-not #'eql)))
58 (assert (= (length restarts) 1))
59 (invoke-restart (first restarts))))))
60 (restart-case
61 (with-condition-restarts foo1 (list (find-restart 'res))
62 (restart-case
63 (opaque-error foo2)
64 (res () 'int1)
65 (res () 'int2)))
66 (res () 'ext))))))
67 'ext))
69 (assert (eq
70 'ext
71 (block nil
72 (let ((visible nil)
73 (c1 (make-condition 'error))
74 (c2 (make-condition 'error)))
75 (handler-bind
76 ((error
77 (lambda (c)
78 (declare (ignore c))
79 (flet ((check-restarts (length)
80 (assert (= length
81 (length (remove 'foo (compute-restarts c1)
82 :key #'restart-name
83 :test-not #'eql))))))
84 (check-restarts 1)
85 (setq visible t)
86 (check-restarts 1)
87 (invoke-restart (find-restart 'foo c1))))))
88 (restart-case
89 (restart-case
90 (error c2)
91 (foo () 'in1)
92 (foo () :test (lambda (c) (declare (ignore c)) visible)
93 'in2))
94 (foo () 'ext)))))))
96 ;;; First argument of CERROR is a format control
97 (assert
98 (eq (block nil
99 (handler-bind
100 ((type-error (lambda (c)
101 (declare (ignore c))
102 (return :failed)))
103 (simple-error (lambda (c)
104 (declare (ignore c))
105 (return (if (find-restart 'continue)
106 :passed
107 :failed)))))
108 (cerror (formatter "Continue from ~A") "bug ~A" :bug)))
109 :passed))
111 (with-test (:name (handler-bind :smoke))
112 (let ((called?))
113 (flet ((handler (condition)
114 (declare (ignore condition))
115 (setf called? t)))
116 (macrolet ((test (handler)
117 `(progn
118 (setf called? nil)
119 (handler-bind ((condition ,handler))
120 (signal 'condition))
121 (assert called?))))
122 ;; Test optimized special cases.
123 (test (lambda (condition) (handler condition)))
124 (test #'(lambda (condition) (handler condition)))
125 ;; Test default behavior.
126 ;; (test 'handler) would require function definition => not pure
127 (test #'handler)))))
129 (with-test (:name (handler-bind :malformed-bindings))
130 (flet ((test (binding)
131 (assert (eq :ok
132 (handler-case
133 (macroexpand `(handler-bind (,binding)))
134 (simple-error (e)
135 (assert (equal (list binding)
136 (simple-condition-format-arguments e)))
137 :ok))))))
139 (test 1) ; not even a list
140 (test '()) ; missing condition type and handler
141 (test '(error)) ; missing handler
142 (test '(error #'print :foo)) ; too many elements
145 ;;; clauses in HANDLER-CASE are allowed to have declarations (and
146 ;;; indeed, only declarations)
147 (assert
148 (null (handler-case (error "foo") (error () (declare (optimize speed))))))
150 (handler-case
151 (handler-bind ((warning #'muffle-warning))
152 (signal 'warning))
153 ;; if it's a control error, it had better be printable
154 (control-error (c) (format nil "~A" c))
155 ;; there had better be an error
156 (:no-error (&rest args) (error "No error: ~S" args)))
158 (handler-case
159 (funcall (lambda (x) (check-type x fixnum) x) t)
160 (type-error (c)
161 (assert (and (subtypep (type-error-expected-type c) 'fixnum)
162 (subtypep 'fixnum (type-error-expected-type c))))
163 (assert (eq (type-error-datum c) t)))
164 (:no-error (&rest rest) (error "no error: ~S" rest)))
166 ;;; ANSI specifies TYPE-ERROR if datum and arguments of ERROR are not
167 ;;; designators for a condition. Reported by Bruno Haible on cmucl-imp
168 ;;; 2004-10-12.
169 (flet ((test (&rest args)
170 (multiple-value-bind (res err)
171 (ignore-errors (apply #'error args))
172 (assert (not res))
173 (assert (typep err 'type-error))
174 (assert (not (nth-value 1 (ignore-errors
175 (type-error-datum err)))))
176 (assert (not (nth-value 1 (ignore-errors
177 (type-error-expected-type err))))))))
178 (test '#:no-such-condition)
179 (test nil)
180 (test t)
181 (test 42)
182 (test (make-instance 'standard-object)))
184 ;;; If CERROR is given a condition, any remaining arguments are only
185 ;;; used for the continue format control.
186 (with-test (:name (cerror :condition-object-and-format-arguments))
187 (let ((x 0))
188 (handler-bind
189 ((simple-error (lambda (c) (incf x) (continue c))))
190 (cerror "Continue from ~A at ~A"
191 (make-condition 'simple-error :format-control "foo"
192 :format-arguments nil)
193 'cerror (get-universal-time))
194 (assert (= x 1)))))
196 ;; Test some of the variations permitted by the RESTART-CASE syntax.
197 (with-test (:name (restart-case :smoke))
198 (macrolet
199 ((test (clause &optional (expected ''(:ok)) (args '(:ok)))
200 `(assert (equal ,expected
201 (multiple-value-list
202 (restart-case
203 (handler-bind
204 ((error (lambda (c)
205 (invoke-restart ',(first clause) ,@args))))
206 (error "foo"))
207 ,clause))))))
209 (test (foo (quux) quux))
210 (test (foo (&optional quux) quux))
211 ;; Multiple values should work.
212 (test (foo (a b) (values a b)) '(1 2) (1 2))
213 ;; Although somewhat unlikely, these should be legal and return
214 ;; the respective keyword when the restart is invoked.
215 (test (foo () :report) '(:report) ())
216 (test (foo () :interactive) '(:interactive) ())
217 (test (foo () :test) '(:test) ())
218 ;; Declarations should work normally as part of the restart body.
219 (test (foo (quux) :declare ()) '(nil))
220 (test (foo () :declare () :report "quux") '("quux") ())))
222 (with-test (:name (restart-case :malformed-clauses))
223 (macrolet
224 ((test (clause &optional (expected clause))
225 `(assert (eq :ok
226 (handler-case
227 (macroexpand
228 `(restart-case (error "foo") ,',clause))
229 (simple-error (e)
230 (assert (equal '(restart-case ,expected)
231 (simple-condition-format-arguments e)))
232 :ok))))))
234 (test :report) ; not even a list
235 (test ()) ; empty
236 (test (foo)) ; no lambda-list
237 (test (foo :report)) ; no lambda-list
238 (test (foo :report "quux")) ; no lambda-list
239 (test (foo :report "quux" (quux))) ; confused report and lambda list
242 (with-test (:name :simple-condition-without-args)
243 (let ((sc (make-condition 'simple-condition)))
244 (assert (not (simple-condition-format-control sc)))
245 (assert (not (simple-condition-format-arguments sc)))
246 (assert (stringp (prin1-to-string sc)))
247 (assert
248 (eq :ok
249 (handler-case
250 (princ-to-string sc)
251 (simple-error (c)
252 (when (and (equal "No format-control for ~S"
253 (simple-condition-format-control c))
254 (eq sc (car
255 (simple-condition-format-arguments c))))
256 :ok)))))))
258 (with-test (:name :malformed-simple-condition-printing-type-error)
259 (assert (eq :type-error
260 (handler-case
261 (princ-to-string
262 (make-condition 'simple-error :format-control "" :format-arguments 8))
263 (type-error (e)
264 (when (and (eq 'list (type-error-expected-type e))
265 (eql 8 (type-error-datum e)))
266 :type-error))))))
268 (with-test (:name (:printing-unintitialized-condition :bug-1184586))
269 (prin1-to-string (make-condition 'simple-type-error)))
271 (with-test (:name (:print-undefined-function-condition))
272 (handler-case (funcall '#:foo)
273 (undefined-function (c) (princ-to-string c))))
275 ;; Printing a READER-ERROR while the underlying stream is still open
276 ;; should print the stream position information.
277 (with-test (:name (reader-error :stream-error-position-info :open-stream :bug-1264902))
278 (assert
279 (search
280 "Line: 1, Column: 22, File-Position: 22"
281 (with-input-from-string (stream "no-such-package::symbol")
282 (handler-case
283 (read stream)
284 (reader-error (condition) (princ-to-string condition)))))))
286 ;; Printing a READER-ERROR when the underlying stream has been closed
287 ;; should still work, but the stream information will not be printed.
288 (with-test (:name (reader-error :stream-error-position-info :closed-stream :bug-1264902))
289 (assert
290 (search
291 "Package NO-SUCH-PACKAGE does not exist"
292 (handler-case
293 (with-input-from-string (stream "no-such-package::symbol")
294 (read stream))
295 (reader-error (condition) (princ-to-string condition))))))
297 (with-test (:name (make-condition :non-condition-class))
298 (handler-case
299 (make-condition 'standard-class)
300 (type-error (condition)
301 (assert (search "not a condition class"
302 (princ-to-string condition))))))
304 ;; When called with a symbol not designating a condition class,
305 ;; MAKE-CONDITION used to signal an error which printed as "NIL does
306 ;; not designate a condition class.".
307 (with-test (:name (make-condition :correct-error-for-undefined-condition
308 :bug-1199223))
309 (handler-case
310 (make-condition 'no-such-condition)
311 (type-error (condition)
312 (assert (search (string 'no-such-condition)
313 (princ-to-string condition))))))
315 ;; Using an undefined condition type in a HANDLER-BIND clause should
316 ;; signal an ERROR at runtime. Bug 1378939 was about landing in LDB
317 ;; because of infinite recursion in SIGNAL instead.
319 ;; We suppress the compile-time WARNING to avoid noise when running
320 ;; tests.
321 (locally (declare (muffle-conditions warning))
322 (with-test (:name (handler-bind :undefined-condition-type
323 :bug-1378939))
324 (assert-error
325 (handler-bind ((no-such-condition-class #'print))
326 (error "does not matter")))))
328 ;; Using an undefined condition type in a HANDLER-BIND clause should
329 ;; signal a [STYLE-]WARNING at compile time.
330 (with-test (:name (handler-bind :undefined-condition-type
331 :compile-time-warning))
332 (handler-bind ((warning #'muffle-warning))
333 (assert-signal
334 (compile nil '(lambda () (handler-bind
335 ((no-such-condition-class #'print)))))
336 warning)))
338 ;; Empty bindings in HANDLER-BIND pushed an empty cluster onto
339 ;; *HANDLER-CLUSTERS* which was not expected by SIGNAL (and wasteful).
340 (with-test (:name (handler-bind :empty-bindings :bug-1388707))
341 (multiple-value-bind (value condition)
342 (ignore-errors (handler-bind () (error "Foo")))
343 (assert (null value))
344 (assert (typep condition 'simple-error))))