diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index c59817cd3ba39a25fbb544f5e113f001c9942945..e7fc50071ddca43673ace457061a993de9349285 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -286,13 +286,54 @@ the condition to go uncaught if it cannot be classified." (declare (optimize (safety ,safety))) ,form))) (eval ',form)))) - (,error-name (c) (printable-p c))))) + (,error-name (c) + (cond + ,@(if (eq error-name 'type-error) + `(((typep (type-error-datum c) + (type-error-expected-type c)) + (values + nil + (list (list 'typep (type-error-datum c) + (type-error-expected-type c)) + "==> true")))) + nil) + (t (printable-p c))))))) (defmacro signals-error-always (form error-name) `(values (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))) + ,form))) + `(let ((,var ,datum-form)) + (handler-bind + ((warning #'(lambda (c) (declare (ignore c)) + (muffle-warning)))) + ; (proclaim '(optimize (safety 3))) + (handler-case + (apply #'values + nil + (multiple-value-list + (funcall + (if regression-test::*compile-tests* + (compile nil ',lambda-form) + (eval ',lambda-form)) + ,var))) + (type-error + (c) + (let ((datum (type-error-datum c)) + (expected-type (type-error-expected-type c))) + (cond + ((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." (with-standard-io-syntax