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 @@
t)
(deftest acos.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-type-error x ',x (acos x))))
collect x)
(check-type-error #'acos #'numberp)
nil)
......@@ -82,10 +82,7 @@
t)
(deftest acosh.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-type-error x ',x (acosh x))))
collect x)
(check-type-error #'acosh #'numberp)
nil)
......
......@@ -48,10 +48,7 @@
t)
(deftest adjustable-array-p.error.4
(loop for e in *mini-universe*
unless (or (typep e 'array)
(eval `(signals-type-error x ',e (adjustable-array-p x))))
collect e)
(check-type-error #'adjustable-array-p #'arrayp)
nil)
(deftest adjustable-array-p.error.5
......
......@@ -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
;;; 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
((warning #'(lambda (c) (declare (ignore c))
(muffle-warning))))
......@@ -281,11 +281,13 @@ the condition to go uncaught if it cannot be classified."
(apply #'values
nil
(multiple-value-list
(if regression-test::*compile-tests*
(funcall (compile nil '(lambda ()
,(cond
(inline form)
(regression-test::*compile-tests*
`(funcall (compile nil '(lambda ()
(declare (optimize (safety ,safety)))
,form)))
(eval ',form))))
,form))))
(t `(eval ',form)))))
(,error-name (c)
(cond
,@(case error-name
......@@ -326,12 +328,13 @@ the condition to go uncaught if it cannot be classified."
(signals-error ,form ,error-name)
(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
`(lambda (,var)
(declare (optimize (safety ,safety)))
,form)))
`(let ((,var ,datum-form))
(declare (optimize safety))
(handler-bind
((warning #'(lambda (c) (declare (ignore c))
(muffle-warning))))
......@@ -341,9 +344,11 @@ the condition to go uncaught if it cannot be classified."
nil
(multiple-value-list
(funcall
(if regression-test::*compile-tests*
(compile nil ',lambda-form)
(eval ',lambda-form))
,(cond
(inline `(function ,lambda-form))
(regression-test::*compile-tests*
`(compile nil ',lambda-form))
(t `(eval ',lambda-form)))
,var)))
(type-error
(c)
......@@ -356,6 +361,23 @@ the condition to go uncaught if it cannot be classified."
(list :is-typep datum expected-type))
(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)
"Returns T iff obj can be printed to a string."
(with-standard-io-syntax
......@@ -1120,3 +1142,5 @@ the condition to go uncaught if it cannot be classified."
(double-float double-float-negative-epsilon)
(long-float long-float-negative-epsilon)
(rational 0)))
(defun sequencep (x) (typep x 'sequence))
......@@ -51,10 +51,7 @@
t)
(deftest array-dimensions.error.3
(loop for e in *mini-universe*
unless (or (typep e 'array)
(eval `(signals-type-error x ',e (array-dimensions x))))
collect e)
(check-type-error #'array-dimensions #'arrayp)
nil)
(deftest array-dimensions.error.4
......
......@@ -116,10 +116,7 @@
t)
(deftest array-displacement.error.3
(loop for e in *mini-universe*
unless (or (typep e 'array)
(eval `(signals-type-error x ',e (array-displacement ',e))))
collect e)
(check-type-error #'array-displacement #'arrayp)
nil)
(deftest array-displacement.error.4
......
......@@ -36,10 +36,7 @@
t)
(deftest array-rank.error.3
(loop for e in *mini-universe*
unless (or (typep e 'array)
(eval `(signals-type-error x ',e (array-rank x))))
collect e)
(check-type-error #'array-rank #'arrayp)
nil)
(deftest array-rank.error.4
......
......@@ -45,10 +45,7 @@
t)
(deftest array-total-size.error.3
(loop for e in *mini-universe*
unless (or (typep e 'array)
(eval `(signals-type-error x ',e (array-total-size ',e))))
collect e)
(check-type-error #'array-total-size #'arrayp)
nil)
(deftest array-total-size.error.4
......
......@@ -20,17 +20,11 @@
t)
(deftest ash.error.4
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-type-error x ',x (ash x 0))))
collect x)
(check-type-error #'(lambda (x) (ash x 0)) #'integerp)
nil)
(deftest ash.error.5
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-type-error x ',x (ash 0 x))))
collect x)
(check-type-error #'(lambda (x) (ash 0 x)) #'integerp)
nil)
;;; Non-error tests
......@@ -59,7 +53,7 @@
t)
(deftest ash.4
(loop for i from -1 to -1000
(loop for i from -1 downto -1000
always (eql (ash i i) -1))
t)
......
......@@ -92,10 +92,7 @@
t)
(deftest asin.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-type-error x ',x (asin x))))
collect x)
(check-type-error #'asin #'numberp)
nil)
......
......@@ -80,10 +80,7 @@
t)
(deftest asinh.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-type-error x ',x (asinh x))))
collect x)
(check-type-error #'asinh #'numberp)
nil)
......
......@@ -133,24 +133,15 @@
t)
(deftest atan.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-type-error x ',x (atan x))))
collect x)
(check-type-error #'atan #'numberp)
nil)
(deftest atan.error.4
(loop for x in *mini-universe*
unless (or (realp x)
(eval `(signals-type-error x ',x (atan x 1))))
collect x)
(check-type-error #'(lambda (x) (atan x 1)) #'realp)
nil)
(deftest atan.error.5
(loop for x in *mini-universe*
unless (or (realp x)
(eval `(signals-type-error x ',x (atan 1 x))))
collect x)
(check-type-error #'(lambda (x) (atan 1 x)) #'realp)
nil)
......
......@@ -109,18 +109,5 @@
t)
(deftest atanh.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-type-error x ',x (atanh x))))
collect x)
(check-type-error #'atanh #'numberp)
nil)
......@@ -14,8 +14,8 @@
t)
(deftest boundp.error.3
(signals-type-error x 1 (boundp 1))
t)
(check-type-error #'boundp #'symbolp)
nil)
(deftest boundp.error.4
(signals-type-error x '(setf car) (boundp x))
......
......@@ -1146,10 +1146,7 @@
t)
(deftest symbol-package.error.3
(loop for x in *mini-universe*
for form = `(signals-type-error x ',x (symbol-package x))
unless (or (symbolp x) (eval form))
collect x)
(check-type-error #'symbol-package #'symbolp)
nil)
......@@ -1162,18 +1159,12 @@
t)
(deftest symbol-plist.error.3
(loop for x in *mini-universe*
for form = `(signals-type-error x ',x (symbol-plist x))
unless (or (symbolp x) (eval form))
collect x)
(check-type-error #'symbol-plist #'symbolp)
nil)
(deftest symbol-plist.error.4
(loop for x in *mini-universe*
for form = `(signals-type-error x ',x (setf (symbol-plist x)
(find-package "CL-USER")))
unless (or (symbolp x) (eval form))
collect x)
(check-type-error #'(lambda (x) (setf (symbol-plist x) nil))
#'symbolp)
nil)
......@@ -1187,17 +1178,11 @@
t)
(deftest symbol-value.error.3
(loop for x in *mini-universe*
for form = `(signals-type-error x ',x (symbol-value x))
unless (or (symbolp x) (eval form))
collect x)
(check-type-error #'symbol-value #'symbolp)
nil)
(deftest symbol-value.error.4
(loop for x in *mini-universe*
for form = `(signals-type-error x ',x (setf (symbol-value x) nil))
unless (or (symbolp x) (eval form))
collect x)
(check-type-error #'(lambda (x) (setf (symbol-value x) nil)) #'symbolp)
nil)
(deftest symbol-value.error.5
......
......@@ -60,12 +60,5 @@
t)
(deftest clear-input.error.5
(loop for x in *mini-universe*
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)
(check-type-error #'clear-input #'(lambda (x) (typep x '(or stream (member nil t)))))
nil)
......@@ -49,14 +49,5 @@
t)
(deftest clear-output.error.3
(loop for x in *mini-universe*
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)
(check-type-error #'clear-output #'(lambda (x) (typep x '(or stream (member nil t)))))
nil)
......@@ -120,11 +120,5 @@
t)
(deftest copy-pprint-dispatch.error.2
(loop for x in *mini-universe*
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))
(check-type-error #'copy-pprint-dispatch #'null)
nil)
......@@ -230,16 +230,8 @@
;;; Error tests
(deftest copy-seq.error.1
(signals-type-error x 10 (copy-seq x))
t)
(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)
(check-type-error #'copy-seq #'sequencep)
nil)
(deftest copy-seq.error.4
(signals-error (copy-seq) program-error)
......
......@@ -167,9 +167,6 @@
t)
(deftest cos.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-type-error x ',x (cos x))))
collect x)
(check-type-error #'cos #'numberp)
nil)
......@@ -82,10 +82,7 @@
t)
(deftest cosh.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-type-error x ',x (cosh x))))
collect x)
(check-type-error #'cosh #'numberp)
nil)
......
......@@ -525,16 +525,8 @@
;;; Error tests
(deftest count-if-not.error.1
(signals-type-error x 1 (count-if-not #'identity x))
t)
(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)
(check-type-error #'(lambda (x) (count-if-not #'identity x)) #'sequencep)
nil)
(deftest count-if-not.error.4
(signals-error (count-if-not) program-error)
......
......@@ -524,16 +524,9 @@
;;; Error tests
(deftest count-if.error.1
(signals-type-error x 1 (count-if #'identity x))
t)
(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)
(check-type-error #'(lambda (x) (count-if #'identity x))
#'sequencep)
nil)
(deftest count-if.error.4
(signals-error (count-if) program-error)
......
......@@ -653,16 +653,8 @@
;;; Error tests
(deftest count.error.1
(signals-type-error x 1 (count 'a x))
t)
(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)
(check-type-error #'(lambda (x) (count 'a x)) #'sequencep)
nil)
(deftest count.error.4
(signals-error (count) program-error)
......
......@@ -11,10 +11,8 @@
a)
(deftest ctypecase.2
(signals-type-error
x 1
(ctypecase x (symbol 'a)))
t)
(check-type-error #'(lambda (x) (ctypecase x (symbol 'a))) #'symbolp)
nil)
(deftest ctypecase.3
(let ((x 1))
......
......@@ -148,11 +148,11 @@
(car nil)
nil)
(deftest car-symbol-error
(signals-type-error x 'a (car x))
t)
(deftest car.error.1
(check-type-error #'car #'listp)
nil)
(deftest car-symbol-error.2
(deftest car.error.2
(signals-error (locally (car 'a) t) type-error)
t)
......@@ -174,11 +174,11 @@
(values (cdr (progn (incf i) '(a b))) i))
(b) 1)
(deftest cdr-symbol-error
(signals-type-error x 'a (cdr x))
t)
(deftest cdr.error.1
(check-type-error #'cdr #'listp)
nil)
(deftest cdr-symbol-error.2
(deftest cdr.error.2
(signals-error (locally (cdr 'a) t) type-error)
t)
......
......@@ -10,22 +10,22 @@
2)
(deftest ecase.2
(signals-error (ecase 1) type-error)
(signals-type-error x 1 (ecase x))
t)
(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)
;;; It is legal to use T or OTHERWISE as key designators
;;; in ECASE forms. They have no special meaning here.
(deftest ecase.4
(signals-error (ecase 1 (t nil)) type-error)
(signals-type-error x 1 (ecase x (t nil)))
t)
(deftest ecase.5
(signals-error (ecase 1 (otherwise nil)) type-error)
(signals-type-error x 1 (ecase x (otherwise nil)))
t)
(deftest ecase.6
......@@ -45,7 +45,7 @@
a)
(deftest ecase.9
(signals-error (ecase nil (nil 'a)) type-error)
(signals-type-error x nil (ecase x (nil 'a)))
t)
(deftest ecase.10
......@@ -57,7 +57,7 @@
1 2 3)
(deftest ecase.12
(signals-error (ecase t (a 10)) type-error)
(signals-type-error x t (ecase x (a 10)))
t)
(deftest ecase.13
......@@ -70,25 +70,23 @@
1)
(deftest ecase.15
(signals-error (ecase 'otherwise ((t) 10)) type-error)
(signals-type-error x 'otherwise (ecase x ((t) 10)))
t)
(deftest ecase.16
(signals-error (ecase t ((otherwise) 10)) type-error)
(signals-type-error x t (ecase x ((otherwise) 10)))
t)
(deftest ecase.17
(signals-error (ecase 'a (b 0) (c 1) (otherwise 2))
type-error)
(signals-type-error x 'a (ecase x (b 0) (c 1) (otherwise 2)))
t)
(deftest ecase.18
(signals-error (ecase 'a (b 0) (c 1) ((otherwise) 2))
type-error)
(signals-type-error x 'a (ecase x (b 0) (c 1) ((otherwise) 2)))
t)
(deftest ecase.19
(signals-error (ecase 'a (b 0) (c 1) ((t) 2)) type-error)
(signals-type-error x 'a (ecase x (b 0) (c 1) ((t) 2)))
t)
(deftest ecase.20
......
......@@ -10,7 +10,7 @@
;; elt on lists
(deftest elt.1
(signals-error (elt nil 0) type-error)
(signals-error (elt x 0) type-error)
t)
(deftest elt.1a
......
......@@ -26,17 +26,9 @@
i))
nil 1)
(deftest endp-symbol-error
(catch-type-error (endp 'a))
type-error)
(deftest endp-fixnum-error
(catch-type-error (endp 1))
type-error)
(deftest endp-float-error
(catch-type-error (endp 0.9212d4))
type-error)
(deftest endp.error.1
(check-type-error #'endp #'listp)
nil)
(deftest endp.error.4
(signals-error (endp) program-error)
......@@ -49,4 +41,3 @@
(deftest endp.error.6
(signals-error (locally (endp 1)) type-error)
t)
......@@ -12,7 +12,7 @@
a)
(deftest etypecase.2
(signals-error (etypecase 1 (symbol 'a)) type-error)
(signals-type-error x 1 (etypecase x (symbol 'a)))
t)
(deftest etypecase.3
......
......@@ -15,19 +15,16 @@
(signals-error (evenp 0 nil) program-error)
t)
(deftest evenp.error.3
(check-type-error #'evenp #'integerp)
nil)
(deftest evenp.1
(loop for x in *numbers*
when (integerp x)
do (evenp x))
nil)
(deftest evenp.2
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (evenp ',x) type-error)))
collect x)
nil)
(deftest evenp.3
(loop for x = (random-fixnum)
repeat 10000
......
......@@ -279,32 +279,19 @@
;;; Error cases
(deftest every.error.1
(signals-error (every 1 '(a b c)) type-error)
t)
(check-type-error #'(lambda (x) (every x '(a b c)))
#'(lambda (x) (typep x '(or function symbol))))
nil)
(deftest every.error.2
(signals-error (every #\a '(a b c)) type-error)
t)
(check-type-error #'(lambda (x) (every #'null x))
#'(lambda (x) (typep x 'sequence)))
nil)
(deftest every.error.3
(signals-error (every #() '(a b c)) type-error)
t)
(deftest every.error.4
(signals-error (every #'null 'a) type-error)
t)
(deftest every.error.5
(signals-error (every #'null 100) type-error)
t)
(deftest every.error.6
(signals-error (every #'null 'a) type-error)
t)
(deftest every.error.7
(signals-error (every #'eq () 'a) type-error)
t)
(check-type-error #'(lambda (x) (every #'eq () x))
#'(lambda (x) (typep x 'sequence)))
nil)
(deftest every.error.8
(signals-error (every) program-error)
......
......@@ -51,25 +51,42 @@
t 1)
(deftest fboundp.error.1
(signals-error (fboundp 1) type-error)
t)
(check-type-error #'fboundp #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null))))))
nil)
(deftest fboundp.error.2
(signals-error (fboundp #\a) type-error)
(signals-type-error x '(x) (fboundp x))
t)
(deftest fboundp.error.3
(signals-error (fboundp '(foo)) type-error)
(signals-type-error x '(setf) (fboundp x))
t)
(deftest fboundp.error.4
(signals-error (fboundp) program-error)
(signals-type-error x '(setf foo . bar) (fboundp x))
t)
(deftest fboundp.error.5
(signals-error (fboundp 'cons nil) program-error)
(signals-type-error x '(setf foo bar) (fboundp x))
t)
(deftest fboundp.error.6
(signals-error (fboundp) program-error)
t)
(deftest fboundp.error.7
(signals-error (fboundp 'cons nil) program-error)
t)
(deftest fboundp.error.8
(signals-error (locally (fboundp 1) t) type-error)
t)
(deftest fboundp.error.9
(signals-type-error x '(setf . foo) (fboundp x))
t)