Commit 7413d9bf authored by pfdietz's avatar pfdietz
Browse files

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)
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