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 @@ ...@@ -94,10 +94,6 @@
(deftest acos.error.3 (deftest acos.error.3
(loop for x in *mini-universe* (loop for x in *mini-universe*
unless (or (numberp x) unless (or (numberp x)
(eval `(signals-error (acos ',x) type-error))) (eval `(signals-type-error x ',x (acos x))))
collect x) collect x)
nil) nil)
...@@ -84,7 +84,7 @@ ...@@ -84,7 +84,7 @@
(deftest acosh.error.3 (deftest acosh.error.3
(loop for x in *mini-universe* (loop for x in *mini-universe*
unless (or (numberp x) unless (or (numberp x)
(eval `(signals-error (acosh ',x) type-error))) (eval `(signals-type-error x ',x (acosh x))))
collect x) collect x)
nil) nil)
......
...@@ -44,14 +44,13 @@ ...@@ -44,14 +44,13 @@
t) t)
(deftest adjustable-array-p.error.3 (deftest adjustable-array-p.error.3
(signals-error (adjustable-array-p 10) type-error) (signals-type-error x 10 (adjustable-array-p x))
t) t)
(deftest adjustable-array-p.error.4 (deftest adjustable-array-p.error.4
(loop for e in *mini-universe* (loop for e in *mini-universe*
unless (or (typep e 'array) unless (or (typep e 'array)
(eval `(signals-error (adjustable-array-p ',e) (eval `(signals-type-error x ',e (adjustable-array-p x))))
type-error)))
collect e) collect e)
nil) nil)
......
...@@ -53,13 +53,12 @@ ...@@ -53,13 +53,12 @@
(deftest array-dimensions.error.3 (deftest array-dimensions.error.3
(loop for e in *mini-universe* (loop for e in *mini-universe*
unless (or (typep e 'array) unless (or (typep e 'array)
(eval `(signals-error (array-dimensions ',e) (eval `(signals-type-error x ',e (array-dimensions x))))
type-error)))
collect e) collect e)
nil) nil)
(deftest array-dimensions.error.4 (deftest array-dimensions.error.4
(signals-error (array-dimensions nil) type-error) (signals-type-error x nil (array-dimensions x))
t) t)
(deftest array-dimensions.error.5 (deftest array-dimensions.error.5
......
...@@ -118,18 +118,10 @@ ...@@ -118,18 +118,10 @@
(deftest array-displacement.error.3 (deftest array-displacement.error.3
(loop for e in *mini-universe* (loop for e in *mini-universe*
unless (or (typep e 'array) unless (or (typep e 'array)
(eval `(signals-error (array-displacement ',e) (eval `(signals-type-error x ',e (array-displacement ',e))))
type-error)))
collect e) collect e)
nil) nil)
(deftest array-displacement.error.4 (deftest array-displacement.error.4
(signals-error (array-displacement nil) type-error) (signals-type-error x nil (array-displacement x))
t) t)
(deftest array-displacement.error.5
(signals-error (let ((x nil)) (array-displacement x))
type-error)
t)
...@@ -38,7 +38,7 @@ ...@@ -38,7 +38,7 @@
(deftest array-rank.error.3 (deftest array-rank.error.3
(loop for e in *mini-universe* (loop for e in *mini-universe*
unless (or (typep e 'array) unless (or (typep e 'array)
(eval `(signals-error (array-rank ',e) type-error))) (eval `(signals-type-error x ',e (array-rank x))))
collect e) collect e)
nil) nil)
...@@ -47,6 +47,5 @@ ...@@ -47,6 +47,5 @@
t) t)
(deftest array-rank.error.5 (deftest array-rank.error.5
(signals-error (locally (array-rank nil) t) (signals-type-error x nil (locally (array-rank x) t))
type-error)
t) t)
...@@ -47,8 +47,7 @@ ...@@ -47,8 +47,7 @@
(deftest array-total-size.error.3 (deftest array-total-size.error.3
(loop for e in *mini-universe* (loop for e in *mini-universe*
unless (or (typep e 'array) unless (or (typep e 'array)
(eval `(signals-error (array-total-size ',e) (eval `(signals-type-error x ',e (array-total-size ',e))))
type-error)))
collect e) collect e)
nil) nil)
...@@ -57,6 +56,6 @@ ...@@ -57,6 +56,6 @@
t) t)
(deftest array-total-size.error.5 (deftest array-total-size.error.5
(signals-error (locally (array-total-size 0) t) (signals-type-error x 0 (locally (array-total-size x) t))
type-error)
t) t)
...@@ -22,14 +22,14 @@ ...@@ -22,14 +22,14 @@
(deftest ash.error.4 (deftest ash.error.4
(loop for x in *mini-universe* (loop for x in *mini-universe*
unless (or (integerp x) unless (or (integerp x)
(eval `(signals-error (ash ',x 0) type-error))) (eval `(signals-type-error x ',x (ash x 0))))
collect x) collect x)
nil) nil)
(deftest ash.error.5 (deftest ash.error.5
(loop for x in *mini-universe* (loop for x in *mini-universe*
unless (or (integerp x) unless (or (integerp x)
(eval `(signals-error (ash 0 ',x) type-error))) (eval `(signals-type-error x ',x (ash 0 x))))
collect x) collect x)
nil) nil)
......
...@@ -94,7 +94,7 @@ ...@@ -94,7 +94,7 @@
(deftest asin.error.3 (deftest asin.error.3
(loop for x in *mini-universe* (loop for x in *mini-universe*
unless (or (numberp x) unless (or (numberp x)
(eval `(signals-error (asin ',x) type-error))) (eval `(signals-type-error x ',x (asin x))))
collect x) collect x)
nil) nil)
......
...@@ -82,7 +82,7 @@ ...@@ -82,7 +82,7 @@
(deftest asinh.error.3 (deftest asinh.error.3
(loop for x in *mini-universe* (loop for x in *mini-universe*
unless (or (numberp x) unless (or (numberp x)
(eval `(signals-error (asinh ',x) type-error))) (eval `(signals-type-error x ',x (asinh x))))
collect x) collect x)
nil) nil)
......
...@@ -137,13 +137,11 @@ ...@@ -137,13 +137,11 @@
t) t)
(deftest assoc-if-not.error.9 (deftest assoc-if-not.error.9
(signals-error (assoc-if-not #'car '((a b)(c d))) (signals-type-error x 'a (assoc-if-not #'car '((a b)(c d))))
type-error)
t) t)
(deftest assoc-if-not.error.10 (deftest assoc-if-not.error.10
(signals-error (assoc-if-not #'identity '((a b)(c d)) :key #'car) (signals-type-error x 'a (assoc-if-not #'identity '((a b)(c d)) :key #'car))
type-error)
t) t)
(deftest assoc-if-not.error.11 (deftest assoc-if-not.error.11
...@@ -157,5 +155,5 @@ ...@@ -157,5 +155,5 @@
t) t)
(deftest assoc-if-not.error.13 (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) t)
...@@ -140,13 +140,11 @@ ...@@ -140,13 +140,11 @@
t) t)
(deftest assoc-if.error.9 (deftest assoc-if.error.9
(signals-error (assoc-if #'car '((a b)(c d))) (signals-type-error x 'a (assoc-if #'car '((a b)(c d))))
type-error)
t) t)
(deftest assoc-if.error.10 (deftest assoc-if.error.10
(signals-error (assoc-if #'identity '((a b)(c d)) :key #'car) (signals-type-error x 'a (assoc-if #'identity '((a b)(c d)) :key #'car))
type-error)
t) t)
(deftest assoc-if.error.11 (deftest assoc-if.error.11
...@@ -160,5 +158,5 @@ ...@@ -160,5 +158,5 @@
t) t)
(deftest assoc-if.error.13 (deftest assoc-if.error.13
(signals-error (assoc-if #'null 'y) type-error) (signals-type-error x 'y (assoc-if #'null x))
t) t)
...@@ -292,6 +292,6 @@ ...@@ -292,6 +292,6 @@
t) t)
(deftest assoc.error.12 (deftest assoc.error.12
(signals-error (assoc 'x 'y) type-error) (signals-type-error x 'y (assoc 'x x))
t) t)
...@@ -135,21 +135,21 @@ ...@@ -135,21 +135,21 @@
(deftest atan.error.3 (deftest atan.error.3
(loop for x in *mini-universe* (loop for x in *mini-universe*
unless (or (numberp x) unless (or (numberp x)
(eval `(signals-error (atan ',x) type-error))) (eval `(signals-type-error x ',x (atan x))))
collect x) collect x)
nil) nil)
(deftest atan.error.4 (deftest atan.error.4
(loop for x in *mini-universe* (loop for x in *mini-universe*
unless (or (realp x) unless (or (realp x)
(eval `(signals-error (atan ',x 1) type-error))) (eval `(signals-type-error x ',x (atan x 1))))
collect x) collect x)
nil) nil)
(deftest atan.error.5 (deftest atan.error.5
(loop for x in *mini-universe* (loop for x in *mini-universe*
unless (or (realp x) unless (or (realp x)
(eval `(signals-error (atan 1 ',x) type-error))) (eval `(signals-type-error x ',x (atan 1 x))))
collect x) collect x)
nil) nil)
......
...@@ -111,7 +111,7 @@ ...@@ -111,7 +111,7 @@
(deftest atanh.error.3 (deftest atanh.error.3
(loop for x in *mini-universe* (loop for x in *mini-universe*
unless (or (numberp x) unless (or (numberp x)
(eval `(signals-error (atanh ',x) type-error))) (eval `(signals-type-error x ',x (atanh x))))
collect x) collect x)
nil) nil)
......
...@@ -53,18 +53,18 @@ ...@@ -53,18 +53,18 @@
(deftest boole.error.5 (deftest boole.error.5
(let ((bad (loop for i from 1 until (not (member i *boole-vals*))))) (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) t)
(deftest boole.error.6 (deftest boole.error.6
(loop for n in *boole-val-names* (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) collect n)
nil) nil)
(deftest boole.error.7 (deftest boole.error.7
(loop for n in *boole-val-names* (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) collect n)
nil) nil)
......
...@@ -14,19 +14,19 @@ ...@@ -14,19 +14,19 @@
t) t)
(deftest boundp.error.3 (deftest boundp.error.3
(signals-error (boundp 1) type-error) (signals-type-error x 1 (boundp 1))
t) t)
(deftest boundp.error.4 (deftest boundp.error.4
(signals-error (boundp '(setf car)) type-error) (signals-type-error x '(setf car) (boundp x))
t) t)
(deftest boundp.error.5 (deftest boundp.error.5
(signals-error (boundp "abc") type-error) (signals-type-error x "abc" (boundp x))
t) t)
(deftest boundp.error.6 (deftest boundp.error.6
(signals-error (locally (boundp "abc") t) type-error) (signals-type-error x "abc" (locally (boundp x) t))
t) t)
;;; See other tests in cl-symbols.lsp ;;; See other tests in cl-symbols.lsp
......
...@@ -11,28 +11,22 @@ ...@@ -11,28 +11,22 @@
2) 2)
(deftest ccase.2 (deftest ccase.2
(signals-error (let ((x 1)) (ccase x)) type-error) (signals-type-error x 1 (ccase x))
t) t)
(deftest ccase.3 (deftest ccase.3
(signals-error (signals-type-error x 1 (ccase x (a 1) (b 2) (c 3)))
(let ((x 1))(ccase x (a 1) (b 2) (c 3)))
type-error)
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 CCASE forms. They have no special meaning here. ;;; in CCASE forms. They have no special meaning here.
(deftest ccase.4 (deftest ccase.4
(signals-error (signals-type-error x 1 (ccase x (t nil)))
(let ((x 1)) (ccase x (t nil)))
type-error)
t) t)
(deftest ccase.5 (deftest ccase.5
(signals-error (signals-type-error x 1 (ccase x (otherwise nil)))
(let ((x 1)) (ccase x (otherwise nil)))
type-error)
t) t)
(deftest ccase.6 (deftest ccase.6
...@@ -54,9 +48,7 @@ ...@@ -54,9 +48,7 @@
a) a)
(deftest ccase.9 (deftest ccase.9
(signals-error (signals-type-error x nil (ccase x (nil 'a)))
(let (x) (ccase x (nil 'a)))
type-error)
t) t)
(deftest ccase.10 (deftest ccase.10
...@@ -70,9 +62,7 @@ ...@@ -70,9 +62,7 @@
1 2 3) 1 2 3)
(deftest ccase.12 (deftest ccase.12
(signals-error (signals-type-error x t (ccase x (a 10)))
(let ((x t)) (ccase x (a 10)))
type-error)
t) t)
(deftest ccase.13 (deftest ccase.13
...@@ -86,27 +76,19 @@ ...@@ -86,27 +76,19 @@
1) 1)
(deftest ccase.15 (deftest ccase.15
(signals-error (signals-type-error x 'otherwise (ccase x ((t) 10)))
(let ((x 'otherwise)) (ccase x ((t) 10)))
type-error)
t) t)
(deftest ccase.16 (deftest ccase.16
(signals-error (signals-type-error x t (ccase x ((otherwise) 10)))
(let ((x t)) (ccase x ((otherwise) 10)))
type-error)
t) t)
(deftest ccase.17 (deftest ccase.17
(signals-error (signals-type-error x 'a (ccase x (b 0) (c 1) (otherwise 2)))
(let ((x 'a)) (ccase x (b 0) (c 1) (otherwise 2)))
type-error)
t) t)
(deftest ccase.19 (deftest ccase.19
(signals-error (signals-type-error x 'a (ccase x (b 0) (c 1) ((t) 2)))
(let ((x 'a)) (ccase x (b 0) (c 1) ((t) 2)))
type-error)
t) t)
(deftest ccase.20 (deftest ccase.20
......
...@@ -56,6 +56,8 @@ ...@@ -56,6 +56,8 @@
(declare (type function fn)) (declare (type function fn))
(loop for x in *universe* (loop for x in *universe*
always (or (characterp x) 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))))) (eqt (catch-type-error (funcall fn x)) 'type-error)))))
(defun standard-char.5.body () (defun standard-char.5.body ()
......
...@@ -11,16 +11,17 @@ ...@@ -11,16 +11,17 @@
nil a) nil a)
(deftest check-type.2 (deftest check-type.2
(signals-error (signals-type-error x 'a (check-type x integer))
(let ((x 'a))
(check-type x integer))
type-error)
t) t)
(deftest check-type.3 (deftest check-type.3
(let ((x 'a)) (let ((x 'a))
(handler-bind (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))) (values (check-type x number) x)))
nil 15) nil 15)
...@@ -32,21 +33,32 @@ ...@@ -32,21 +33,32 @@
(deftest check-type.5 (deftest check-type.5
(let ((x 'a)) (let ((x 'a))
(handler-bind (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))) (values (check-type x string "a string") x)))
nil "abc") nil "abc")
(deftest check-type.6 (deftest check-type.6
(let ((x 'a)) (let ((x 'a))
(handler-bind (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))) (values (check-type x number) x)))
nil 15) nil 15)
(deftest check-type.7 (deftest check-type.7
(let ((x 'a)) (let ((x 'a))
(handler-bind (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))) (values (check-type x number) x)))
nil 15) nil 15)
...@@ -1147,7 +1147,7 @@ ...@@ -1147,7 +1147,7 @@
(deftest symbol-package.error.3 (deftest symbol-package.error.3
(loop for x in *mini-universe* (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)) unless (or (symbolp x) (eval form))
collect x) collect x)
nil) nil)
...@@ -1163,16 +1163,15 @@ ...@@ -1163,16 +1163,15 @@
(deftest symbol-plist.error.3 (deftest symbol-plist.error.3
(loop for x in *mini-universe* (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)) unless (or (symbolp x) (eval form))
collect x) collect x)
nil) nil)
(deftest symbol-plist.error.4 (deftest symbol-plist.error.4
(loop for x in *mini-universe* (loop for x in *mini-universe*
for form = `(signals-error (setf (symbol-plist ',x) for form = `(signals-type-error x ',x (setf (symbol-plist x)
(find-package "CL-USER")) (find-package "CL-USER")))
type-error)