272 |
;;; The above is badly designed, since it fails when some signals |
;;; The above is badly designed, since it fails when some signals |
273 |
;;; may be in more than one class/ |
;;; may be in more than one class/ |
274 |
|
|
275 |
(defmacro signals-error (form error-name &key (safety 3) (name nil name-p)) |
(defmacro signals-error (form error-name &key (safety 3) (name nil name-p) (inline nil)) |
276 |
`(handler-bind |
`(handler-bind |
277 |
((warning #'(lambda (c) (declare (ignore c)) |
((warning #'(lambda (c) (declare (ignore c)) |
278 |
(muffle-warning)))) |
(muffle-warning)))) |
281 |
(apply #'values |
(apply #'values |
282 |
nil |
nil |
283 |
(multiple-value-list |
(multiple-value-list |
284 |
(if regression-test::*compile-tests* |
,(cond |
285 |
(funcall (compile nil '(lambda () |
(inline form) |
286 |
|
(regression-test::*compile-tests* |
287 |
|
`(funcall (compile nil '(lambda () |
288 |
(declare (optimize (safety ,safety))) |
(declare (optimize (safety ,safety))) |
289 |
,form))) |
,form)))) |
290 |
(eval ',form)))) |
(t `(eval ',form))))) |
291 |
(,error-name (c) |
(,error-name (c) |
292 |
(cond |
(cond |
293 |
,@(case error-name |
,@(case error-name |
328 |
(signals-error ,form ,error-name) |
(signals-error ,form ,error-name) |
329 |
(signals-error ,form ,error-name :safety 0))) |
(signals-error ,form ,error-name :safety 0))) |
330 |
|
|
331 |
(defmacro signals-type-error (var datum-form form &key (safety 3)) |
(defmacro signals-type-error (var datum-form form &key (safety 3) (inline nil)) |
332 |
(let ((lambda-form |
(let ((lambda-form |
333 |
`(lambda (,var) |
`(lambda (,var) |
334 |
(declare (optimize (safety ,safety))) |
(declare (optimize (safety ,safety))) |
335 |
,form))) |
,form))) |
336 |
`(let ((,var ,datum-form)) |
`(let ((,var ,datum-form)) |
337 |
|
(declare (optimize safety)) |
338 |
(handler-bind |
(handler-bind |
339 |
((warning #'(lambda (c) (declare (ignore c)) |
((warning #'(lambda (c) (declare (ignore c)) |
340 |
(muffle-warning)))) |
(muffle-warning)))) |
344 |
nil |
nil |
345 |
(multiple-value-list |
(multiple-value-list |
346 |
(funcall |
(funcall |
347 |
(if regression-test::*compile-tests* |
,(cond |
348 |
(compile nil ',lambda-form) |
(inline `(function ,lambda-form)) |
349 |
(eval ',lambda-form)) |
(regression-test::*compile-tests* |
350 |
|
`(compile nil ',lambda-form)) |
351 |
|
(t `(eval ',lambda-form))) |
352 |
,var))) |
,var))) |
353 |
(type-error |
(type-error |
354 |
(c) |
(c) |
361 |
(list :is-typep datum expected-type)) |
(list :is-typep datum expected-type)) |
362 |
(t (printable-p c)))))))))) |
(t (printable-p c)))))))))) |
363 |
|
|
364 |
|
(declaim (special *mini-universe*)) |
365 |
|
|
366 |
|
(defun check-type-error* (pred-fn guard-fn &optional (universe *mini-universe*)) |
367 |
|
"Check that for all elements in some set, either guard-fn is true or |
368 |
|
pred-fn signals a type error." |
369 |
|
(let (val) |
370 |
|
(loop for e in universe |
371 |
|
unless (or (funcall guard-fn e) |
372 |
|
(equal |
373 |
|
(setf val (multiple-value-list |
374 |
|
(signals-type-error x e (funcall pred-fn x) :inline t))) |
375 |
|
'(t))) |
376 |
|
collect (list e val)))) |
377 |
|
|
378 |
|
(defmacro check-type-error (&body args) |
379 |
|
`(locally (declare (optimize safety)) (check-type-error* ,@args))) |
380 |
|
|
381 |
(defun printable-p (obj) |
(defun printable-p (obj) |
382 |
"Returns T iff obj can be printed to a string." |
"Returns T iff obj can be printed to a string." |
383 |
(with-standard-io-syntax |
(with-standard-io-syntax |
1142 |
(double-float double-float-negative-epsilon) |
(double-float double-float-negative-epsilon) |
1143 |
(long-float long-float-negative-epsilon) |
(long-float long-float-negative-epsilon) |
1144 |
(rational 0))) |
(rational 0))) |
1145 |
|
|
1146 |
|
(defun sequencep (x) (typep x 'sequence)) |