286 |
(declare (optimize (safety ,safety))) |
(declare (optimize (safety ,safety))) |
287 |
,form))) |
,form))) |
288 |
(eval ',form)))) |
(eval ',form)))) |
289 |
(,error-name (c) (printable-p c))))) |
(,error-name (c) |
290 |
|
(cond |
291 |
|
,@(if (eq error-name 'type-error) |
292 |
|
`(((typep (type-error-datum c) |
293 |
|
(type-error-expected-type c)) |
294 |
|
(values |
295 |
|
nil |
296 |
|
(list (list 'typep (type-error-datum c) |
297 |
|
(type-error-expected-type c)) |
298 |
|
"==> true")))) |
299 |
|
nil) |
300 |
|
(t (printable-p c))))))) |
301 |
|
|
302 |
(defmacro signals-error-always (form error-name) |
(defmacro signals-error-always (form error-name) |
303 |
`(values |
`(values |
304 |
(signals-error ,form ,error-name) |
(signals-error ,form ,error-name) |
305 |
(signals-error ,form ,error-name :safety 0))) |
(signals-error ,form ,error-name :safety 0))) |
306 |
|
|
307 |
|
(defmacro signals-type-error (var datum-form form &key (safety 3)) |
308 |
|
(let ((lambda-form |
309 |
|
`(lambda (,var) |
310 |
|
(declare (optimize (safety ,safety))) |
311 |
|
,form))) |
312 |
|
`(let ((,var ,datum-form)) |
313 |
|
(handler-bind |
314 |
|
((warning #'(lambda (c) (declare (ignore c)) |
315 |
|
(muffle-warning)))) |
316 |
|
; (proclaim '(optimize (safety 3))) |
317 |
|
(handler-case |
318 |
|
(apply #'values |
319 |
|
nil |
320 |
|
(multiple-value-list |
321 |
|
(funcall |
322 |
|
(if regression-test::*compile-tests* |
323 |
|
(compile nil ',lambda-form) |
324 |
|
(eval ',lambda-form)) |
325 |
|
,var))) |
326 |
|
(type-error |
327 |
|
(c) |
328 |
|
(let ((datum (type-error-datum c)) |
329 |
|
(expected-type (type-error-expected-type c))) |
330 |
|
(cond |
331 |
|
((not (eql ,var datum)) |
332 |
|
(list :datum-mismatch ,var datum)) |
333 |
|
((typep datum expected-type) |
334 |
|
(list :is-typep datum expected-type)) |
335 |
|
(t (printable-p c)))))))))) |
336 |
|
|
337 |
(defun printable-p (obj) |
(defun printable-p (obj) |
338 |
"Returns T iff obj can be printed to a string." |
"Returns T iff obj can be printed to a string." |
339 |
(with-standard-io-syntax |
(with-standard-io-syntax |