Commit 7413d9bf authored by pfdietz's avatar pfdietz

Add check-type-error, which encapsulates a common idiom. Refactor many tests...

Add check-type-error, which encapsulates a common idiom.  Refactor many tests that use this idiom and extend signals-type-error to more tests.  Add more extended function name error tests.
parent cfbc2a4d
...@@ -92,8 +92,5 @@ ...@@ -92,8 +92,5 @@
t) t)
(deftest acos.error.3 (deftest acos.error.3
(loop for x in *mini-universe* (check-type-error #'acos #'numberp)
unless (or (numberp x)
(eval `(signals-type-error x ',x (acos x))))
collect x)
nil) nil)
...@@ -82,10 +82,7 @@ ...@@ -82,10 +82,7 @@
t) t)
(deftest acosh.error.3 (deftest acosh.error.3
(loop for x in *mini-universe* (check-type-error #'acosh #'numberp)
unless (or (numberp x)
(eval `(signals-type-error x ',x (acosh x))))
collect x)
nil) nil)
......
...@@ -48,10 +48,7 @@ ...@@ -48,10 +48,7 @@
t) t)
(deftest adjustable-array-p.error.4 (deftest adjustable-array-p.error.4
(loop for e in *mini-universe* (check-type-error #'adjustable-array-p #'arrayp)
unless (or (typep e 'array)
(eval `(signals-type-error x ',e (adjustable-array-p x))))
collect e)
nil) nil)
(deftest adjustable-array-p.error.5 (deftest adjustable-array-p.error.5
......
...@@ -272,7 +272,7 @@ the condition to go uncaught if it cannot be classified." ...@@ -272,7 +272,7 @@ the condition to go uncaught if it cannot be classified."
;;; The above is badly designed, since it fails when some signals ;;; The above is badly designed, since it fails when some signals
;;; may be in more than one class/ ;;; may be in more than one class/
(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))
`(handler-bind `(handler-bind
((warning #'(lambda (c) (declare (ignore c)) ((warning #'(lambda (c) (declare (ignore c))
(muffle-warning)))) (muffle-warning))))
...@@ -281,11 +281,13 @@ the condition to go uncaught if it cannot be classified." ...@@ -281,11 +281,13 @@ the condition to go uncaught if it cannot be classified."
(apply #'values (apply #'values
nil nil
(multiple-value-list (multiple-value-list
(if regression-test::*compile-tests* ,(cond
(funcall (compile nil '(lambda () (inline form)
(regression-test::*compile-tests*
`(funcall (compile nil '(lambda ()
(declare (optimize (safety ,safety))) (declare (optimize (safety ,safety)))
,form))) ,form))))
(eval ',form)))) (t `(eval ',form)))))
(,error-name (c) (,error-name (c)
(cond (cond
,@(case error-name ,@(case error-name
...@@ -326,12 +328,13 @@ the condition to go uncaught if it cannot be classified." ...@@ -326,12 +328,13 @@ the condition to go uncaught if it cannot be classified."
(signals-error ,form ,error-name) (signals-error ,form ,error-name)
(signals-error ,form ,error-name :safety 0))) (signals-error ,form ,error-name :safety 0)))
(defmacro signals-type-error (var datum-form form &key (safety 3)) (defmacro signals-type-error (var datum-form form &key (safety 3) (inline nil))
(let ((lambda-form (let ((lambda-form
`(lambda (,var) `(lambda (,var)
(declare (optimize (safety ,safety))) (declare (optimize (safety ,safety)))
,form))) ,form)))
`(let ((,var ,datum-form)) `(let ((,var ,datum-form))
(declare (optimize safety))
(handler-bind (handler-bind
((warning #'(lambda (c) (declare (ignore c)) ((warning #'(lambda (c) (declare (ignore c))
(muffle-warning)))) (muffle-warning))))
...@@ -341,9 +344,11 @@ the condition to go uncaught if it cannot be classified." ...@@ -341,9 +344,11 @@ the condition to go uncaught if it cannot be classified."
nil nil
(multiple-value-list (multiple-value-list
(funcall (funcall
(if regression-test::*compile-tests* ,(cond
(compile nil ',lambda-form) (inline `(function ,lambda-form))
(eval ',lambda-form)) (regression-test::*compile-tests*
`(compile nil ',lambda-form))
(t `(eval ',lambda-form)))
,var))) ,var)))
(type-error (type-error
(c) (c)
...@@ -356,6 +361,23 @@ the condition to go uncaught if it cannot be classified." ...@@ -356,6 +361,23 @@ the condition to go uncaught if it cannot be classified."
(list :is-typep datum expected-type)) (list :is-typep datum expected-type))
(t (printable-p c)))))))))) (t (printable-p c))))))))))
(declaim (special *mini-universe*))
(defun check-type-error* (pred-fn guard-fn &optional (universe *mini-universe*))
"Check that for all elements in some set, either guard-fn is true or
pred-fn signals a type error."
(let (val)
(loop for e in universe
unless (or (funcall guard-fn e)
(equal
(setf val (multiple-value-list
(signals-type-error x e (funcall pred-fn x) :inline t)))
'(t)))
collect (list e val))))
(defmacro check-type-error (&body args)
`(locally (declare (optimize safety)) (check-type-error* ,@args)))
(defun printable-p (obj) (defun printable-p (obj)
"Returns T iff obj can be printed to a string." "Returns T iff obj can be printed to a string."
(with-standard-io-syntax (with-standard-io-syntax
...@@ -1120,3 +1142,5 @@ the condition to go uncaught if it cannot be classified." ...@@ -1120,3 +1142,5 @@ the condition to go uncaught if it cannot be classified."
(double-float double-float-negative-epsilon) (double-float double-float-negative-epsilon)
(long-float long-float-negative-epsilon) (long-float long-float-negative-epsilon)
(rational 0))) (rational 0)))
(defun sequencep (x) (typep x 'sequence))
...@@ -51,10 +51,7 @@ ...@@ -51,10 +51,7 @@
t) t)
(deftest array-dimensions.error.3 (deftest array-dimensions.error.3
(loop for e in *mini-universe* (check-type-error #'array-dimensions #'arrayp)
unless (or (typep e 'array)
(eval `(signals-type-error x ',e (array-dimensions x))))
collect e)
nil) nil)
(deftest array-dimensions.error.4 (deftest array-dimensions.error.4
......
...@@ -116,10 +116,7 @@ ...@@ -116,10 +116,7 @@
t) t)
(deftest array-displacement.error.3 (deftest array-displacement.error.3
(loop for e in *mini-universe* (check-type-error #'array-displacement #'arrayp)
unless (or (typep e 'array)
(eval `(signals-type-error x ',e (array-displacement ',e))))
collect e)
nil) nil)
(deftest array-displacement.error.4 (deftest array-displacement.error.4
......
...@@ -36,10 +36,7 @@ ...@@ -36,10 +36,7 @@
t) t)
(deftest array-rank.error.3 (deftest array-rank.error.3
(loop for e in *mini-universe* (check-type-error #'array-rank #'arrayp)
unless (or (typep e 'array)
(eval `(signals-type-error x ',e (array-rank x))))
collect e)
nil) nil)
(deftest array-rank.error.4 (deftest array-rank.error.4
......
...@@ -45,10 +45,7 @@ ...@@ -45,10 +45,7 @@
t) t)
(deftest array-total-size.error.3 (deftest array-total-size.error.3
(loop for e in *mini-universe* (check-type-error #'array-total-size #'arrayp)
unless (or (typep e 'array)
(eval `(signals-type-error x ',e (array-total-size ',e))))
collect e)
nil) nil)
(deftest array-total-size.error.4 (deftest array-total-size.error.4
......
...@@ -20,17 +20,11 @@ ...@@ -20,17 +20,11 @@
t) t)
(deftest ash.error.4 (deftest ash.error.4
(loop for x in *mini-universe* (check-type-error #'(lambda (x) (ash x 0)) #'integerp)
unless (or (integerp x)
(eval `(signals-type-error x ',x (ash x 0))))
collect x)
nil) nil)
(deftest ash.error.5 (deftest ash.error.5
(loop for x in *mini-universe* (check-type-error #'(lambda (x) (ash 0 x)) #'integerp)
unless (or (integerp x)
(eval `(signals-type-error x ',x (ash 0 x))))
collect x)
nil) nil)
;;; Non-error tests ;;; Non-error tests
...@@ -59,7 +53,7 @@ ...@@ -59,7 +53,7 @@
t) t)
(deftest ash.4 (deftest ash.4
(loop for i from -1 to -1000 (loop for i from -1 downto -1000
always (eql (ash i i) -1)) always (eql (ash i i) -1))
t) t)
......
...@@ -92,10 +92,7 @@ ...@@ -92,10 +92,7 @@
t) t)
(deftest asin.error.3 (deftest asin.error.3
(loop for x in *mini-universe* (check-type-error #'asin #'numberp)
unless (or (numberp x)
(eval `(signals-type-error x ',x (asin x))))
collect x)
nil) nil)
......
...@@ -80,10 +80,7 @@ ...@@ -80,10 +80,7 @@
t) t)
(deftest asinh.error.3 (deftest asinh.error.3
(loop for x in *mini-universe* (check-type-error #'asinh #'numberp)
unless (or (numberp x)
(eval `(signals-type-error x ',x (asinh x))))
collect x)
nil) nil)
......
...@@ -133,24 +133,15 @@ ...@@ -133,24 +133,15 @@
t) t)
(deftest atan.error.3 (deftest atan.error.3
(loop for x in *mini-universe* (check-type-error #'atan #'numberp)
unless (or (numberp x)
(eval `(signals-type-error x ',x (atan x))))
collect x)
nil) nil)
(deftest atan.error.4 (deftest atan.error.4
(loop for x in *mini-universe* (check-type-error #'(lambda (x) (atan x 1)) #'realp)
unless (or (realp x)
(eval `(signals-type-error x ',x (atan x 1))))
collect x)
nil) nil)
(deftest atan.error.5 (deftest atan.error.5
(loop for x in *mini-universe* (check-type-error #'(lambda (x) (atan 1 x)) #'realp)
unless (or (realp x)
(eval `(signals-type-error x ',x (atan 1 x))))
collect x)
nil) nil)
......
...@@ -109,18 +109,5 @@ ...@@ -109,18 +109,5 @@
t) t)
(deftest atanh.error.3 (deftest atanh.error.3
(loop for x in *mini-universe* (check-type-error #'atanh #'numberp)
unless (or (numberp x)
(eval `(signals-type-error x ',x (atanh x))))
collect x)
nil) nil)
...@@ -14,8 +14,8 @@ ...@@ -14,8 +14,8 @@
t) t)
(deftest boundp.error.3 (deftest boundp.error.3
(signals-type-error x 1 (boundp 1)) (check-type-error #'boundp #'symbolp)
t) nil)
(deftest boundp.error.4 (deftest boundp.error.4
(signals-type-error x '(setf car) (boundp x)) (signals-type-error x '(setf car) (boundp x))
......
...@@ -1146,10 +1146,7 @@ ...@@ -1146,10 +1146,7 @@
t) t)
(deftest symbol-package.error.3 (deftest symbol-package.error.3
(loop for x in *mini-universe* (check-type-error #'symbol-package #'symbolp)
for form = `(signals-type-error x ',x (symbol-package x))
unless (or (symbolp x) (eval form))
collect x)
nil) nil)
...@@ -1162,18 +1159,12 @@ ...@@ -1162,18 +1159,12 @@
t) t)
(deftest symbol-plist.error.3 (deftest symbol-plist.error.3
(loop for x in *mini-universe* (check-type-error #'symbol-plist #'symbolp)
for form = `(signals-type-error x ',x (symbol-plist x))
unless (or (symbolp x) (eval form))
collect x)
nil) nil)
(deftest symbol-plist.error.4 (deftest symbol-plist.error.4
(loop for x in *mini-universe* (check-type-error #'(lambda (x) (setf (symbol-plist x) nil))
for form = `(signals-type-error x ',x (setf (symbol-plist x) #'symbolp)
(find-package "CL-USER")))
unless (or (symbolp x) (eval form))
collect x)
nil) nil)
...@@ -1187,17 +1178,11 @@ ...@@ -1187,17 +1178,11 @@
t) t)
(deftest symbol-value.error.3 (deftest symbol-value.error.3
(loop for x in *mini-universe* (check-type-error #'symbol-value #'symbolp)
for form = `(signals-type-error x ',x (symbol-value x))
unless (or (symbolp x) (eval form))
collect x)
nil) nil)
(deftest symbol-value.error.4 (deftest symbol-value.error.4
(loop for x in *mini-universe* (check-type-error #'(lambda (x) (setf (symbol-value x) nil)) #'symbolp)
for form = `(signals-type-error x ',x (setf (symbol-value x) nil))
unless (or (symbolp x) (eval form))
collect x)
nil) nil)
(deftest symbol-value.error.5 (deftest symbol-value.error.5
......
...@@ -60,12 +60,5 @@ ...@@ -60,12 +60,5 @@
t) t)
(deftest clear-input.error.5 (deftest clear-input.error.5
(loop for x in *mini-universe* (check-type-error #'clear-input #'(lambda (x) (typep x '(or stream (member nil t)))))
unless (or (member x '(nil t))
(typep x 'stream)
(equalt
(eval `(multiple-value-list
(signals-type-error x ',x (clear-input x))))
'(t)))
collect x)
nil) nil)
...@@ -49,14 +49,5 @@ ...@@ -49,14 +49,5 @@
t) t)
(deftest clear-output.error.3 (deftest clear-output.error.3
(loop for x in *mini-universe* (check-type-error #'clear-output #'(lambda (x) (typep x '(or stream (member nil t)))))
unless (or (member x '(nil t))
(typep x 'stream)
(equalt
(eval `(multiple-value-list
(signals-type-error x ',x (clear-output x))))
'(t)))
collect x)
nil) nil)
...@@ -120,11 +120,5 @@ ...@@ -120,11 +120,5 @@
t) t)
(deftest copy-pprint-dispatch.error.2 (deftest copy-pprint-dispatch.error.2
(loop for x in *mini-universe* (check-type-error #'copy-pprint-dispatch #'null)
for results = (multiple-value-list
(eval `(signals-type-error x ',x (copy-pprint-dispatch x))))
unless (or (null x)
(equal results '(t)))
collect (list x results))
nil) nil)
...@@ -230,16 +230,8 @@ ...@@ -230,16 +230,8 @@
;;; Error tests ;;; Error tests
(deftest copy-seq.error.1 (deftest copy-seq.error.1
(signals-type-error x 10 (copy-seq x)) (check-type-error #'copy-seq #'sequencep)
t) nil)
(deftest copy-seq.error.2
(signals-type-error x 'a (copy-seq x))
t)
(deftest copy-seq.error.3
(signals-type-error x 13.21 (copy-seq x))
t)
(deftest copy-seq.error.4 (deftest copy-seq.error.4
(signals-error (copy-seq) program-error) (signals-error (copy-seq) program-error)
......
...@@ -167,9 +167,6 @@ ...@@ -167,9 +167,6 @@
t) t)
(deftest cos.error.3 (deftest cos.error.3
(loop for x in *mini-universe* (check-type-error #'cos #'numberp)
unless (or (numberp x)
(eval `(signals-type-error x ',x (cos x))))
collect x)
nil) nil)
...@@ -82,10 +82,7 @@ ...@@ -82,10 +82,7 @@
t) t)
(deftest cosh.error.3 (deftest cosh.error.3
(loop for x in *mini-universe* (check-type-error #'cosh #'numberp)
unless (or (numberp x)
(eval `(signals-type-error x ',x (cosh x))))
collect x)
nil) nil)
......
...@@ -525,16 +525,8 @@ ...@@ -525,16 +525,8 @@
;;; Error tests ;;; Error tests
(deftest count-if-not.error.1 (deftest count-if-not.error.1
(signals-type-error x 1 (count-if-not #'identity x)) (check-type-error #'(lambda (x) (count-if-not #'identity x)) #'sequencep)
t) nil)
(deftest count-if-not.error.2
(signals-type-error x 'a (count-if-not #'identity x))
t)
(deftest count-if-not.error.3
(signals-type-error x #\a (count-if-not #'identity x))
t)
(deftest count-if-not.error.4 (deftest count-if-not.error.4
(signals-error (count-if-not) program-error) (signals-error (count-if-not) program-error)
......
...@@ -524,16 +524,9 @@ ...@@ -524,16 +524,9 @@
;;; Error tests ;;; Error tests
(deftest count-if.error.1 (deftest count-if.error.1
(signals-type-error x 1 (count-if #'identity x)) (check-type-error #'(lambda (x) (count-if #'identity x))
t) #'sequencep)
nil)
(deftest count-if.error.2
(signals-type-error x 'a (count-if #'identity x))
t)
(deftest count-if.error.3
(signals-type-error x #\a (count-if #'identity x))
t)
(deftest count-if.error.4 (deftest count-if.error.4
(signals-error (count-if) program-error) (signals-error (count-if) program-error)
......
...@@ -653,16 +653,8 @@ ...@@ -653,16 +653,8 @@
;;; Error tests ;;; Error tests
(deftest count.error.1 (deftest count.error.1
(signals-type-error x 1 (count 'a x)) (check-type-error #'(lambda (x) (count 'a x)) #'sequencep)
t) nil)
(deftest count.error.2
(signals-type-error x 'a (count 'a x))
t)
(deftest count.error.3
(signals-type-error x #\a (count 'a x))
t)
(deftest count.error.4 (deftest count.error.4
(signals-error (count) program-error) (signals-error (count) program-error)
......
...@@ -11,10 +11,8 @@ ...@@ -11,10 +11,8 @@
a) a)
(deftest ctypecase.2 (deftest ctypecase.2
(signals-type-error (check-type-error #'(lambda (x) (ctypecase x (symbol 'a))) #'symbolp)
x 1 nil)
(ctypecase x (symbol 'a)))
t)
(deftest ctypecase.3 (deftest ctypecase.3
(let ((x 1)) (let ((x 1))
......
...@@ -148,11 +148,11 @@ ...@@ -148,11 +148,11 @@
(car nil) (car nil)
nil) nil)
(deftest car-symbol-error (deftest car.error.1
(signals-type-error x 'a (car x)) (check-type-error #'car #'listp)
t) nil)
(deftest car-symbol-error.2 (deftest car.error.2
(signals-error (locally (car 'a) t) type-error) (signals-error (locally (car 'a) t) type-error)
t) t)
...@@ -174,11 +174,11 @@ ...@@ -174,11 +174,11 @@
(values (cdr (progn (incf i) '(a b))) i)) (values (cdr (progn (incf i) '(a b))) i))
(b) 1) (b) 1)
(deftest cdr-symbol-error (deftest cdr.error.1
(signals-type-error x 'a (cdr x)) (check-type-error #'cdr #'listp)
t) nil)
(deftest cdr-symbol-error.2 (deftest cdr.error.2
(signals-error (locally (cdr 'a) t) type-error) (signals-error (locally (cdr 'a) t) type-error)
t) t)
......
...@@ -10,22 +10,22 @@ ...@@ -10,22 +10,22 @@
2) 2)
(deftest ecase.2 (deftest ecase.2
(signals-error (ecase 1) type-error) (signals-type-error x 1 (ecase x))
t) t)
(deftest ecase.3 (deftest ecase.3
(signals-error (ecase 1 (a 1) (b 2) (c 3)) type-error) (signals-type-error x 1 (ecase x (a 1) (b 2) (c 3)))
t) t)
;;; It is legal to use T or OTHERWISE as key designators ;;; It is legal to use T or OTHERWISE as key designators
;;; in ECASE forms. They have no special meaning here. ;;; in ECASE forms. They have no special meaning here.
(deftest ecase.4 (deftest ecase.4
(signals-error (ecase 1 (t nil)) type-error) (signals-type-error x 1 (ecase x (t nil)))
t) t)
(deftest ecase.5 (deftest ecase.5
(signals-error (ecase 1 (otherwise nil)) type-error) (signals-type-error x 1 (ecase x (otherwise nil)))
t) t)
(deftest ecase.6 (deftest ecase.6
...@@ -45,7 +45,7 @@ ...@@ -45,7 +45,7 @@
a) a)
(deftest ecase.9 (deftest ecase.9
(signals-error (ecase nil (nil 'a)) type-error) (signals-type-error x nil (ecase x (nil 'a)))
t) t)
(deftest ecase.10 (deftest ecase.10
...@@ -57,7 +57,7 @@ ...@@ -57,7 +57,7 @@
1 2 3) 1 2 3)
(deftest ecase.12 (deftest ecase.12
(signals-error (ecase t (a 10)) type-error) (signals-type-error x t (ecase x (a 10)))
t) t)
(deftest ecase.13 (deftest ecase.13
...@@ -70,25 +70,23 @@ ...@@ -70,25 +70,23 @@
1) 1)
(deftest ecase.15 (deftest ecase.15