Commit 68c42c64 authored by pfdietz's avatar pfdietz

Make signals-error check the slots of type-error conditions

parent 3af541c1
......@@ -286,13 +286,54 @@ the condition to go uncaught if it cannot be classified."
(declare (optimize (safety ,safety)))
(eval ',form))))
(,error-name (c) (printable-p c)))))
(,error-name (c)
,@(if (eq error-name 'type-error)
`(((typep (type-error-datum c)
(type-error-expected-type c))
(list (list 'typep (type-error-datum c)
(type-error-expected-type c))
"==> true"))))
(t (printable-p c)))))))
(defmacro signals-error-always (form error-name)
(signals-error ,form ,error-name)
(signals-error ,form ,error-name :safety 0)))
(defmacro signals-type-error (var datum-form form &key (safety 3))
(let ((lambda-form
`(lambda (,var)
(declare (optimize (safety ,safety)))
`(let ((,var ,datum-form))
((warning #'(lambda (c) (declare (ignore c))
; (proclaim '(optimize (safety 3)))
(apply #'values
(if regression-test::*compile-tests*
(compile nil ',lambda-form)
(eval ',lambda-form))
(let ((datum (type-error-datum c))
(expected-type (type-error-expected-type c)))
((not (eql ,var datum))
(list :datum-mismatch ,var datum))
((typep datum expected-type)
(list :is-typep datum expected-type))
(t (printable-p c))))))))))
(defun printable-p (obj)
"Returns T iff obj can be printed to a string."
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment