Commit f79956b1 authored by pfdietz's avatar pfdietz
Browse files

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