Commit f79956b1 authored by pfdietz's avatar pfdietz

Make some checks for tyoe-errors more exacting, checking that the datum is the expected object

parent 740550f6
......@@ -94,10 +94,6 @@
(deftest acos.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-error (acos ',x) type-error)))
(eval `(signals-type-error x ',x (acos x))))
collect x)
nil)
......@@ -84,7 +84,7 @@
(deftest acosh.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-error (acosh ',x) type-error)))
(eval `(signals-type-error x ',x (acosh x))))
collect x)
nil)
......
......@@ -44,14 +44,13 @@
t)
(deftest adjustable-array-p.error.3
(signals-error (adjustable-array-p 10) type-error)
(signals-type-error x 10 (adjustable-array-p x))
t)
(deftest adjustable-array-p.error.4
(loop for e in *mini-universe*
unless (or (typep e 'array)
(eval `(signals-error (adjustable-array-p ',e)
type-error)))
(eval `(signals-type-error x ',e (adjustable-array-p x))))
collect e)
nil)
......
......@@ -53,13 +53,12 @@
(deftest array-dimensions.error.3
(loop for e in *mini-universe*
unless (or (typep e 'array)
(eval `(signals-error (array-dimensions ',e)
type-error)))
(eval `(signals-type-error x ',e (array-dimensions x))))
collect e)
nil)
(deftest array-dimensions.error.4
(signals-error (array-dimensions nil) type-error)
(signals-type-error x nil (array-dimensions x))
t)
(deftest array-dimensions.error.5
......
......@@ -118,18 +118,10 @@
(deftest array-displacement.error.3
(loop for e in *mini-universe*
unless (or (typep e 'array)
(eval `(signals-error (array-displacement ',e)
type-error)))
(eval `(signals-type-error x ',e (array-displacement ',e))))
collect e)
nil)
(deftest array-displacement.error.4
(signals-error (array-displacement nil) type-error)
(signals-type-error x nil (array-displacement x))
t)
(deftest array-displacement.error.5
(signals-error (let ((x nil)) (array-displacement x))
type-error)
t)
......@@ -38,7 +38,7 @@
(deftest array-rank.error.3
(loop for e in *mini-universe*
unless (or (typep e 'array)
(eval `(signals-error (array-rank ',e) type-error)))
(eval `(signals-type-error x ',e (array-rank x))))
collect e)
nil)
......@@ -47,6 +47,5 @@
t)
(deftest array-rank.error.5
(signals-error (locally (array-rank nil) t)
type-error)
(signals-type-error x nil (locally (array-rank x) t))
t)
......@@ -47,8 +47,7 @@
(deftest array-total-size.error.3
(loop for e in *mini-universe*
unless (or (typep e 'array)
(eval `(signals-error (array-total-size ',e)
type-error)))
(eval `(signals-type-error x ',e (array-total-size ',e))))
collect e)
nil)
......@@ -57,6 +56,6 @@
t)
(deftest array-total-size.error.5
(signals-error (locally (array-total-size 0) t)
type-error)
(signals-type-error x 0 (locally (array-total-size x) t))
t)
......@@ -22,14 +22,14 @@
(deftest ash.error.4
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (ash ',x 0) type-error)))
(eval `(signals-type-error x ',x (ash x 0))))
collect x)
nil)
(deftest ash.error.5
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (ash 0 ',x) type-error)))
(eval `(signals-type-error x ',x (ash 0 x))))
collect x)
nil)
......
......@@ -94,7 +94,7 @@
(deftest asin.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-error (asin ',x) type-error)))
(eval `(signals-type-error x ',x (asin x))))
collect x)
nil)
......
......@@ -82,7 +82,7 @@
(deftest asinh.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-error (asinh ',x) type-error)))
(eval `(signals-type-error x ',x (asinh x))))
collect x)
nil)
......
......@@ -137,13 +137,11 @@
t)
(deftest assoc-if-not.error.9
(signals-error (assoc-if-not #'car '((a b)(c d)))
type-error)
(signals-type-error x 'a (assoc-if-not #'car '((a b)(c d))))
t)
(deftest assoc-if-not.error.10
(signals-error (assoc-if-not #'identity '((a b)(c d)) :key #'car)
type-error)
(signals-type-error x 'a (assoc-if-not #'identity '((a b)(c d)) :key #'car))
t)
(deftest assoc-if-not.error.11
......@@ -157,5 +155,5 @@
t)
(deftest assoc-if-not.error.13
(signals-error (assoc-if-not #'identity 'y) type-error)
(signals-type-error x 'y (assoc-if-not #'identity x))
t)
......@@ -140,13 +140,11 @@
t)
(deftest assoc-if.error.9
(signals-error (assoc-if #'car '((a b)(c d)))
type-error)
(signals-type-error x 'a (assoc-if #'car '((a b)(c d))))
t)
(deftest assoc-if.error.10
(signals-error (assoc-if #'identity '((a b)(c d)) :key #'car)
type-error)
(signals-type-error x 'a (assoc-if #'identity '((a b)(c d)) :key #'car))
t)
(deftest assoc-if.error.11
......@@ -160,5 +158,5 @@
t)
(deftest assoc-if.error.13
(signals-error (assoc-if #'null 'y) type-error)
(signals-type-error x 'y (assoc-if #'null x))
t)
......@@ -292,6 +292,6 @@
t)
(deftest assoc.error.12
(signals-error (assoc 'x 'y) type-error)
(signals-type-error x 'y (assoc 'x x))
t)
......@@ -135,21 +135,21 @@
(deftest atan.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-error (atan ',x) type-error)))
(eval `(signals-type-error x ',x (atan x))))
collect x)
nil)
(deftest atan.error.4
(loop for x in *mini-universe*
unless (or (realp x)
(eval `(signals-error (atan ',x 1) type-error)))
(eval `(signals-type-error x ',x (atan x 1))))
collect x)
nil)
(deftest atan.error.5
(loop for x in *mini-universe*
unless (or (realp x)
(eval `(signals-error (atan 1 ',x) type-error)))
(eval `(signals-type-error x ',x (atan 1 x))))
collect x)
nil)
......
......@@ -111,7 +111,7 @@
(deftest atanh.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-error (atanh ',x) type-error)))
(eval `(signals-type-error x ',x (atanh x))))
collect x)
nil)
......
......@@ -53,18 +53,18 @@
(deftest boole.error.5
(let ((bad (loop for i from 1 until (not (member i *boole-vals*)))))
(eval `(signals-error (boole ,bad 1 1) type-error)))
(eval `(signals-type-error x ',bad (boole x 1 1))))
t)
(deftest boole.error.6
(loop for n in *boole-val-names*
unless (eval `(signals-error (boole ,n nil 1) type-error))
unless (eval `(signals-type-error x nil (boole ,n nil 1)))
collect n)
nil)
(deftest boole.error.7
(loop for n in *boole-val-names*
unless (eval `(signals-error (boole ,n 1 nil) type-error))
unless (eval `(signals-type-error x nil (boole ,n 1 nil)))
collect n)
nil)
......
......@@ -14,19 +14,19 @@
t)
(deftest boundp.error.3
(signals-error (boundp 1) type-error)
(signals-type-error x 1 (boundp 1))
t)
(deftest boundp.error.4
(signals-error (boundp '(setf car)) type-error)
(signals-type-error x '(setf car) (boundp x))
t)
(deftest boundp.error.5
(signals-error (boundp "abc") type-error)
(signals-type-error x "abc" (boundp x))
t)
(deftest boundp.error.6
(signals-error (locally (boundp "abc") t) type-error)
(signals-type-error x "abc" (locally (boundp x) t))
t)
;;; See other tests in cl-symbols.lsp
......
......@@ -11,28 +11,22 @@
2)
(deftest ccase.2
(signals-error (let ((x 1)) (ccase x)) type-error)
(signals-type-error x 1 (ccase x))
t)
(deftest ccase.3
(signals-error
(let ((x 1))(ccase x (a 1) (b 2) (c 3)))
type-error)
(signals-type-error x 1 (ccase x (a 1) (b 2) (c 3)))
t)
;;; It is legal to use T or OTHERWISE as key designators
;;; in CCASE forms. They have no special meaning here.
(deftest ccase.4
(signals-error
(let ((x 1)) (ccase x (t nil)))
type-error)
(signals-type-error x 1 (ccase x (t nil)))
t)
(deftest ccase.5
(signals-error
(let ((x 1)) (ccase x (otherwise nil)))
type-error)
(signals-type-error x 1 (ccase x (otherwise nil)))
t)
(deftest ccase.6
......@@ -54,9 +48,7 @@
a)
(deftest ccase.9
(signals-error
(let (x) (ccase x (nil 'a)))
type-error)
(signals-type-error x nil (ccase x (nil 'a)))
t)
(deftest ccase.10
......@@ -70,9 +62,7 @@
1 2 3)
(deftest ccase.12
(signals-error
(let ((x t)) (ccase x (a 10)))
type-error)
(signals-type-error x t (ccase x (a 10)))
t)
(deftest ccase.13
......@@ -86,27 +76,19 @@
1)
(deftest ccase.15
(signals-error
(let ((x 'otherwise)) (ccase x ((t) 10)))
type-error)
(signals-type-error x 'otherwise (ccase x ((t) 10)))
t)
(deftest ccase.16
(signals-error
(let ((x t)) (ccase x ((otherwise) 10)))
type-error)
(signals-type-error x t (ccase x ((otherwise) 10)))
t)
(deftest ccase.17
(signals-error
(let ((x 'a)) (ccase x (b 0) (c 1) (otherwise 2)))
type-error)
(signals-type-error x 'a (ccase x (b 0) (c 1) (otherwise 2)))
t)
(deftest ccase.19
(signals-error
(let ((x 'a)) (ccase x (b 0) (c 1) ((t) 2)))
type-error)
(signals-type-error x 'a (ccase x (b 0) (c 1) ((t) 2)))
t)
(deftest ccase.20
......
......@@ -56,6 +56,8 @@
(declare (type function fn))
(loop for x in *universe*
always (or (characterp x)
;; FIXME -- catch the type error and check that datum
;; is eql to x (and that datum is not in the expected type)
(eqt (catch-type-error (funcall fn x)) 'type-error)))))
(defun standard-char.5.body ()
......
......@@ -11,16 +11,17 @@
nil a)
(deftest check-type.2
(signals-error
(let ((x 'a))
(check-type x integer))
type-error)
(signals-type-error x 'a (check-type x integer))
t)
(deftest check-type.3
(let ((x 'a))
(handler-bind
((type-error #'(lambda (c) (store-value 15 c))))
((type-error #'(lambda (c)
(assert (eql (type-error-datum c) x))
(assert (not (typep x (type-error-expected-type c))))
;; Can we assume the expected-type is NUMBER?
(store-value 15 c))))
(values (check-type x number) x)))
nil 15)
......@@ -32,21 +33,32 @@
(deftest check-type.5
(let ((x 'a))
(handler-bind
((type-error #'(lambda (c) (store-value "abc" c))))
((type-error #'(lambda (c)
(assert (eql (type-error-datum c) x))
(assert (not (typep x (type-error-expected-type c))))
;; Can we assume the expected-type is STRING?
(store-value "abc" c))))
(values (check-type x string "a string") x)))
nil "abc")
(deftest check-type.6
(let ((x 'a))
(handler-bind
((type-error #'(lambda (c) (declare (ignore c)) (store-value 15 nil))))
((type-error #'(lambda (c)
(assert (eql (type-error-datum c) x))
(assert (not (typep x (type-error-expected-type c))))
;; Can we assume the expected-type is NUMBER?
(store-value 15 nil))))
(values (check-type x number) x)))
nil 15)
(deftest check-type.7
(let ((x 'a))
(handler-bind
((type-error #'(lambda (c) (declare (ignore c)) (store-value 15))))
((type-error #'(lambda (c)
(assert (eql (type-error-datum c) x))
(assert (not (typep x (type-error-expected-type c))))
;; Can we assume the expected-type is NUMBER?
(store-value 15))))
(values (check-type x number) x)))
nil 15)
......@@ -1147,7 +1147,7 @@
(deftest symbol-package.error.3
(loop for x in *mini-universe*
for form = `(signals-error (symbol-package ',x) type-error)
for form = `(signals-type-error x ',x (symbol-package x))
unless (or (symbolp x) (eval form))
collect x)
nil)
......@@ -1163,16 +1163,15 @@
(deftest symbol-plist.error.3
(loop for x in *mini-universe*
for form = `(signals-error (symbol-plist ',x) type-error)
for form = `(signals-type-error x ',x (symbol-plist x))
unless (or (symbolp x) (eval form))
collect x)
nil)
(deftest symbol-plist.error.4
(loop for x in *mini-universe*
for form = `(signals-error (setf (symbol-plist ',x)
(find-package "CL-USER"))
type-error)
for form = `(signals-type-error x ',x (setf (symbol-plist x)
(find-package "CL-USER")))
unless (or (symbolp x) (eval form))
collect x)
nil)
......@@ -1189,15 +1188,14 @@
(deftest symbol-value.error.3
(loop for x in *mini-universe*
for form = `(signals-error (symbol-value ',x) type-error)
for form = `(signals-type-error x ',x (symbol-value x))
unless (or (symbolp x) (eval form))
collect x)
nil)
(deftest symbol-value.error.4
(loop for x in *mini-universe*
for form = `(signals-error (setf (symbol-value ',x) nil)
type-error)
for form = `(signals-type-error x ',x (setf (symbol-value x) nil))
unless (or (symbolp x) (eval form))
collect x)
nil)
......
......@@ -65,9 +65,7 @@
(typep x 'stream)
(equalt
(eval `(multiple-value-list
(signals-error (clear-input ',x) type-error)))
(signals-type-error x ',x (clear-input x))))
'(t)))
collect x)
nil)
......@@ -54,7 +54,7 @@
(typep x 'stream)
(equalt
(eval `(multiple-value-list
(signals-error (clear-output ',x) type-error)))
(signals-type-error x ',x (clear-output x))))
'(t)))
collect x)
nil)
......
......@@ -122,9 +122,9 @@
(deftest copy-pprint-dispatch.error.2
(loop for x in *mini-universe*
for results = (multiple-value-list
(eval `(signals-error (copy-pprint-dispatch ',x)
type-error)))
(eval `(signals-type-error x ',x (copy-pprint-dispatch x))))
unless (or (null x)
(equal results '(t)))
collect (list x results))
nil)
......@@ -230,15 +230,15 @@
;;; Error tests
(deftest copy-seq.error.1
(signals-error (copy-seq 10) type-error)
(signals-type-error x 10 (copy-seq x))
t)
(deftest copy-seq.error.2
(signals-error (copy-seq 'a) type-error)
(signals-type-error x 'a (copy-seq x))
t)
(deftest copy-seq.error.3
(signals-error (copy-seq 13.21) type-error)
(signals-type-error x 13.21 (copy-seq x))
t)
(deftest copy-seq.error.4
......@@ -252,5 +252,3 @@
(deftest copy-seq.error.6
(signals-error (locally (copy-seq 10) t) type-error)
t)
......@@ -169,7 +169,7 @@
(deftest cos.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-error (cos ',x) type-error)))
(eval `(signals-type-error x ',x (cos x))))
collect x)
nil)
......@@ -84,7 +84,7 @@
(deftest cosh.error.3
(loop for x in *mini-universe*
unless (or (numberp x)
(eval `(signals-error (cosh ',x) type-error)))
(eval `(signals-type-error x ',x (cosh x))))
collect x)
nil)
......
......@@ -525,15 +525,15 @@
;;; Error tests
(deftest count-if-not.error.1
(signals-error (count-if-not #'identity 1) type-error)
(signals-type-error x 1 (count-if-not #'identity x))
t)
(deftest count-if-not.error.2
(signals-error (count-if-not #'identity 'a) type-error)
(signals-type-error x 'a (count-if-not #'identity x))
t)
(deftest count-if-not.error.3
(signals-error (count-if-not #'identity #\a) type-error)
(signals-type-error x #\a (count-if-not #'identity x))
t)
(deftest count-if-not.error.4
......
......@@ -524,15 +524,15 @@
;;; Error tests
(deftest count-if.error.1
(signals-error (count-if #'identity 1) type-error)
(signals-type-error x 1 (count-if #'identity x))
t)
(deftest count-if.error.2
(signals-error (count-if #'identity 'a) type-error)
(signals-type-error x 'a (count-if #'identity x))
t)
(deftest count-if.error.3
(signals-error (count-if #'identity #\a) type-error)
(signals-type-error x #\a (count-if #'identity x))
t)
(deftest count-if.error.4
......
......@@ -653,15 +653,15 @@
;;; Error tests
(deftest count.error.1
(signals-error (count 'a 1) type-error)
(signals-type-error x 1 (count 'a x))
t)
(deftest count.error.2
(signals-error (count 'a 'a) type-error)
(signals-type-error x 'a (count 'a x))
t)
(deftest count.error.3
(signals-error (count 'a #\a) type-error)
(signals-type-error x #\a (count 'a x))
t)
(deftest count.error.4
......
......@@ -11,10 +11,9 @@
a)
(deftest ctypecase.2
(signals-error
(let ((x 1))
(ctypecase x (symbol 'a)))
type-error)
(signals-type-error
x 1
(ctypecase x (symbol 'a)))
t)
(deftest ctypecase.3
......@@ -69,7 +68,10 @@
(let ((x 1))
(values
(handler-bind
((type-error #'(lambda (c) (store-value 'a c))))
((type-error #'(lambda (c)
(assert (eql (type-error-datum c) 1))
(assert (not (typep 1 (type-error-expected-type c))))
(store-value 'a c))))
(ctypecase x
(symbol :good)
(float :bad)))
......
......@@ -149,7 +149,7 @@
nil)
(deftest car-symbol-error
(signals-error (car 'a) type-error)
(signals-type-error x 'a (car x))
t)
(deftest car-symbol-error.2
......@@ -175,7 +175,7 @@
(b) 1)
(deftest cdr-symbol-error
(signals-error (cdr 'a) type-error)
(signals-type-error x 'a (cdr x))
t)
(deftest cdr-symbol-error.2
......
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