Commit e30ff557 authored by pfdietz's avatar pfdietz

More type error refactoring

parent 9365b190
......@@ -1144,3 +1144,14 @@ the condition to go uncaught if it cannot be classified."
(rational 0)))
(defun sequencep (x) (typep x 'sequence))
(defun typef (type) #'(lambda (x) (typep x type)))
(defun package-designator-p (x)
"TRUE if x could be a package designator. The package need not
actually exist."
(or (packagep x)
(handler-case (and (locally (declare (optimize safety))
(string x))
t)
(type-error () nil))))
......@@ -405,3 +405,11 @@
(signals-error (intersection '(a b . c) '(d e f))
type-error)
t)
(deftest intersection.error.13
(check-type-error #'(lambda (x) (intersection x '(a b c))) #'listp)
nil)
(deftest intersection.error.14
(check-type-error #'(lambda (x) (intersection '(a b c) x)) #'listp)
nil)
\ No newline at end of file
......@@ -10,17 +10,15 @@
;;; Error tests
(deftest logand.error.1
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logand ',x) type-error)))
collect x)
(check-type-error #'logand #'integerp)
nil)
(deftest logand.error.2
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logand 0 ',x) type-error)))
collect x)
(check-type-error #'(lambda (x) (logand 0 x)) #'integerp)
nil)
(deftest logand.error.3
(check-type-error #'(lambda (x) (logand x 1)) #'integerp)
nil)
;;; Non-error tests
......
......@@ -10,17 +10,11 @@
;;; Error tests
(deftest logandc2.error.1
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logandc2 ',x 0) type-error)))
collect x)
(check-type-error #'(lambda (x) (logandc2 x 0)) #'integerp)
nil)
(deftest logandc2.error.2
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logandc2 0 ',x) type-error)))
collect x)
(check-type-error #'(lambda (x) (logandc2 0 x)) #'integerp)
nil)
(deftest logandc2.error.3
......
......@@ -22,14 +22,11 @@
t)
(deftest logbitp.error.4
(signals-error (logbitp -1 0) type-error)
t)
(check-type-error #'(lambda (x) (logbitp x 0)) (typef 'unsigned-byte))
nil)
(deftest logbitp.error.5
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logbitp 0 ',x) type-error)))
collect x)
(check-type-error #'(lambda (x) (logbitp 0 x)) #'integerp)
nil)
;;; Non-error tests
......
......@@ -16,10 +16,7 @@
t)
(deftest logcount.error.3
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logcount ',x) type-error)))
collect x)
(check-type-error #'logcount #'integerp)
nil)
;;; Non-error tests
......
......@@ -10,17 +10,11 @@
;;; Error tests
(deftest logeqv.error.1
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logeqv ',x) type-error)))
collect x)
(check-type-error #'logeqv #'integerp)
nil)
(deftest logeqv.error.2
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logeqv 0 ',x) type-error)))
collect x)
(check-type-error #'(lambda (x) (logeqv 0 x)) #'integerp)
nil)
;;; Non-error tests
......
......@@ -29,13 +29,8 @@
;;; Error tests
(deftest logical-pathname.error.1
(loop for x in *mini-universe*
unless (or (stringp x)
(typep x 'stream)
(typep x 'logical-pathname)
(eval `(signals-error (logical-pathname ',x)
type-error)))
collect x)
(check-type-error #'logical-pathname
(typef '(or string stream logical-pathname)))
nil)
(deftest logical-pathname.error.2
......
......@@ -12,17 +12,11 @@
;;; Error tests
(deftest logior.error.1
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logior ',x) type-error)))
collect x)
(check-type-error #'logior #'integerp)
nil)
(deftest logior.error.2
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logior 0 ',x) type-error)))
collect x)
(check-type-error #'(lambda (x) (logior 0 x)) #'integerp)
nil)
;;; Non-error tests
......
......@@ -10,17 +10,11 @@
;;; Error tests
(deftest lognand.error.1
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (lognand ',x 0) type-error)))
collect x)
(check-type-error #'(lambda (x) (lognand x 0)) #'integerp)
nil)
(deftest lognand.error.2
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (lognand 0 ',x) type-error)))
collect x)
(check-type-error #'(lambda (x) (lognand 0 x)) #'integerp)
nil)
(deftest lognand.error.3
......
......@@ -10,17 +10,11 @@
;;; Error tests
(deftest lognor.error.1
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (lognor ',x 0) type-error)))
collect x)
(check-type-error #'(lambda (x) (lognor x 0)) #'integerp)
nil)
(deftest lognor.error.2
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (lognor 0 ',x) type-error)))
collect x)
(check-type-error #'(lambda (x) (lognor 0 x)) #'integerp)
nil)
(deftest lognor.error.3
......
......@@ -10,10 +10,7 @@
;;; Error tests
(deftest lognot.error.1
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (lognot ',x) type-error)))
collect x)
(check-type-error #'lognot #'integerp)
nil)
(deftest lognot.error.2
......
......@@ -10,17 +10,11 @@
;;; Error tests
(deftest logorc1.error.1
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logorc1 ',x 0) type-error)))
collect x)
(check-type-error #'(lambda (x) (logorc1 x 0)) #'integerp)
nil)
(deftest logorc1.error.2
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logorc1 0 ',x) type-error)))
collect x)
(check-type-error #'(lambda (x) (logorc1 0 x)) #'integerp)
nil)
(deftest logorc1.error.3
......
......@@ -10,17 +10,11 @@
;;; Error tests
(deftest logorc2.error.1
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logorc2 ',x 0) type-error)))
collect x)
(check-type-error #'(lambda (x) (logorc2 x 0)) #'integerp)
nil)
(deftest logorc2.error.2
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logorc2 0 ',x) type-error)))
collect x)
(check-type-error #'(lambda (x) (logorc2 0 x)) #'integerp)
nil)
(deftest logorc2.error.3
......
......@@ -20,17 +20,11 @@
t)
(deftest logtest.error.4
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logtest ',x -1) type-error)))
collect x)
(check-type-error #'(lambda (x) (logtest x -1)) #'integerp)
nil)
(deftest logtest.error.5
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logtest -1 ',x) type-error)))
collect x)
(check-type-error #'(lambda (x) (logtest -1 x)) #'integerp)
nil)
;;; Non-error tests
......
......@@ -10,17 +10,11 @@
;;; Error tests
(deftest logxor.error.1
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logxor ',x) type-error)))
collect x)
(check-type-error #'logxor #'integerp)
nil)
(deftest logxor.error.2
(loop for x in *mini-universe*
unless (or (integerp x)
(eval `(signals-error (logxor 0 ',x) type-error)))
collect x)
(check-type-error #'(lambda (x) (logxor 0 x)) #'integerp)
nil)
......
......@@ -88,22 +88,12 @@
;;; Error tests
(deftest make-broadcast-stream.error.1
(loop for x in *mini-universe*
unless (or (and (typep x 'stream) (output-stream-p x))
(handler-case (progn (make-broadcast-stream x) nil)
(type-error () t)
(condition nil)))
collect x)
(check-type-error #'make-broadcast-stream
#'(lambda (x) (and (streamp x) (output-stream-p x))))
nil)
(deftest make-broadcast-stream.error.2
(loop for x in *streams*
unless (or (and (typep x 'stream) (output-stream-p x))
(handler-case (progn (make-broadcast-stream x) nil)
(type-error () t)
(condition nil)))
collect x)
(check-type-error #'make-broadcast-stream
#'(lambda (x) (and (streamp x) (output-stream-p x)))
*streams*)
nil)
......@@ -71,12 +71,8 @@
(deftest make-list.error.1
(catch-type-error (make-list -1))
type-error)
(deftest make-list.error.2
(signals-error (make-list 'a) type-error)
t)
(check-type-error #'make-list (typef 'unsigned-byte))
nil)
(deftest make-list.error.3
(signals-error (make-list) program-error)
......
......@@ -20,10 +20,7 @@
t)
(deftest make-random-state.error.4
(loop for x in *mini-universe*
unless (or (null x) (eq x t) (random-state-p x)
(eval `(signals-error (make-random-state ',x) type-error)))
collect x)
(check-type-error #'make-random-state (typef '(or (member nil t) random-state)))
nil)
;;; Non-error tests
......
......@@ -118,36 +118,8 @@
"ABC" 1)
(deftest make-symbol.error.1
(signals-error (make-symbol nil) type-error)
t)
(deftest make-symbol.error.2
(signals-error (make-symbol 'a) type-error)
t)
(deftest make-symbol.error.3
(signals-error (make-symbol 1) type-error)
t)
(deftest make-symbol.error.4
(signals-error (make-symbol -1) type-error)
t)
(deftest make-symbol.error.5
(signals-error (make-symbol 1.213) type-error)
t)
(deftest make-symbol.error.6
(signals-error (make-symbol -1312.2) type-error)
t)
(deftest make-symbol.error.7
(signals-error (make-symbol #\w) type-error)
t)
(deftest make-symbol.error.8
(signals-error (make-symbol '(a)) type-error)
t)
(check-type-error #'make-symbol #'stringp)
nil)
(deftest make-symbol.error.9
(signals-error (make-symbol) program-error)
......@@ -158,5 +130,5 @@
t)
(deftest make-symbol.error.11
(signals-error (make-symbol '(#\a #\b #\c)) type-error)
(signals-type-error x '(#\a #\b #\c) (make-symbol x))
t)
......@@ -93,9 +93,5 @@
t)
(deftest make-synonym-stream.error.3
(loop for x in *mini-universe*
unless (or (symbolp x)
(eval `(signals-error (make-synonym-stream ',x)
type-error)))
collect x)
(check-type-error #'make-synonym-stream #'symbolp)
nil)
......@@ -218,43 +218,25 @@
t)
(deftest make-two-way-stream.error.4
(loop for x in *mini-universe*
unless (or (and (typep x 'stream) (input-stream-p x))
(eval `(signals-error
(let ((os (make-string-output-stream)))
(make-two-way-stream ',x os))
type-error)))
collect x)
(check-type-error #'(lambda (x) (make-two-way-stream x (make-string-output-stream)))
#'(lambda (x) (and (streamp x) (input-stream-p x))))
nil)
(deftest make-two-way-stream.error.5
(loop for x in *streams*
unless (or (and (typep x 'stream) (input-stream-p x))
(eval `(signals-error
(let ((os (make-string-output-stream)))
(make-two-way-stream ',x os))
type-error)))
collect x)
(check-type-error #'(lambda (x) (make-two-way-stream x (make-string-output-stream)))
#'(lambda (x) (and (streamp x) (input-stream-p x)))
*streams*)
nil)
(deftest make-two-way-stream.error.6
(loop for x in *mini-universe*
unless (or (and (typep x 'stream) (output-stream-p x))
(eval `(signals-error
(let ((is (make-string-input-stream "foo")))
(make-two-way-stream is ',x))
type-error)))
collect x)
(check-type-error #'(lambda (x) (make-two-way-stream (make-string-input-stream "foo") x))
#'(lambda (x) (and (streamp x) (output-stream-p x))))
nil)
(deftest make-two-way-stream.error.7
(loop for x in *streams*
unless (or (and (typep x 'stream) (output-stream-p x))
(eval `(signals-error
(let ((is (make-string-input-stream "foo")))
(make-two-way-stream is ',x))
type-error)))
collect x)
(check-type-error #'(lambda (x) (make-two-way-stream (make-string-input-stream "foo") x))
#'(lambda (x) (and (streamp x) (output-stream-p x)))
*streams*)
nil)
......
......@@ -41,9 +41,5 @@
t)
(deftest makunbound.error.3
(loop for x in *mini-universe*
for form = `(signals-error (makunbound ',x) type-error)
unless (or (symbolp x) (eval form))
collect x)
(check-type-error #'makunbound #'symbolp)
nil)
......@@ -454,8 +454,8 @@
;;; Error cases
(deftest map-into.error.1
(signals-error (map-into 'a #'(lambda () nil)) type-error)
t)
(check-type-error #'(lambda (x) (map-into x (constantly nil))) #'sequencep)
nil)
;;; The next test was changed because if the first argument
;;; is NIL, map-into is said to 'return nil immediately', so
......@@ -469,9 +469,9 @@
nil)
(deftest map-into.error.3
(signals-error (map-into (copy-seq '(a b c)) #'cons '(d e f) 100)
type-error)
t)
(check-type-error #'(lambda (x) (map-into (copy-seq '(a b c)) #'cons '(d e f) x))
#'sequencep)
nil)
(deftest map-into.error.4
(signals-error (map-into) program-error)
......
......@@ -220,6 +220,10 @@
(signals-error-always (map 'symbol #'identity '(a b c)) type-error)
t t)
(deftest map.error.1a
(signals-error (map 'symbol #'identity '(a b c)) type-error)
t)
(deftest map.error.2
(signals-error (map '(vector * 8) #'identity '(a b c)) type-error)
t)
......@@ -268,6 +272,14 @@
t))
t)
(deftest map.error.12
(check-type-error #'(lambda (x) (map 'list #'identity x)) #'sequencep)
nil)
(deftest map.error.13
(check-type-error #'(lambda (x) (map 'vector #'cons '(a b c d) x)) #'sequencep)
nil)
;;; Test mapping on arrays with fill pointers
(deftest map.fill.1
......
......@@ -74,8 +74,8 @@
(a b c) 3 1 2 3)
(deftest mapc.error.1
(signals-error (mapc #'identity 1) type-error)
t)
(check-type-error #'(lambda (x) (mapc #'identity x)) #'listp)
nil)
(deftest mapc.error.2
(signals-error (mapc) program-error)
......
......@@ -88,8 +88,8 @@
1)
(deftest mapcan.error.1
(signals-error (mapcan #'identity 1) type-error)
t)
(check-type-error #'(lambda (x) (mapcan #'identity x)) #'listp)
nil)
(deftest mapcan.error.2
(signals-error (mapcan) program-error)
......
......@@ -81,8 +81,8 @@
3 1 2 3)
(deftest mapcar.error.1
(signals-error (mapcar #'identity 1) type-error)
t)
(check-type-error #'(lambda (x) (mapcar #'identity x)) #'listp)
nil)
(deftest mapcar.error.2
(signals-error (mapcar) program-error)
......
......@@ -54,8 +54,8 @@
3 1 2 3)
(deftest mapcon.error.1
(signals-error (mapcon #'identity 1) type-error)
t)
(check-type-error #'(lambda (x) (mapcon #'identity x)) #'listp)
nil)
(deftest mapcon.error.2
(signals-error (mapcon) program-error)
......
......@@ -100,8 +100,8 @@
(a b c) 3 1 2 3)
(deftest mapl.error.1
(signals-error (mapl #'identity 1) type-error)
t)
(check-type-error #'(lambda (x) (mapl #'identity x)) #'sequencep)
nil)
(deftest mapl.error.2
(signals-error (mapl) program-error)
......
......@@ -95,8 +95,8 @@
(1 2 3) 3 1 2 3)
(deftest maplist.error.1
(signals-error (maplist #'identity 'a) type-error)
t)
(check-type-error #'(lambda (x) (maplist #'identity x)) #'listp)
nil)
(deftest maplist.error.2
(signals-error (maplist #'identity 1) type-error)
......
......@@ -14,10 +14,11 @@
t)
(deftest max.error.2
(loop for x in *mini-universe*
unless (or (realp x)
(eval `(signals-error (max ',x) type-error)))
collect x)
(check-type-error #'max #'realp)
nil)
(deftest max.error.3
(check-type-error #'(lambda (x) (max 0 x)) #'realp)
nil)
;;; Non-error tests
......
......@@ -95,8 +95,8 @@
;;; Error tests
(deftest member-if-not.error.1
(signals-error (member-if-not #'identity 'a) type-error)
t)
(check-type-error #'(lambda (x) (member-if-not #'identity x)) #'listp)
nil)
(deftest member-if-not.error.2
(signals-error (member-if-not) program-error)
......
......@@ -101,8 +101,8 @@
;;; Error cases
(deftest member-if.error.1
(signals-error (member-if #'identity 'a) type-error)
t)
(check-type-error #'(lambda (x) (member-if #'identity x)) #'listp)
nil)
(deftest member-if.error.2
(signals-error (member-if) program-error)
......
......@@ -235,8 +235,8 @@
;;; Error cases
(deftest member.error.1
(signals-error (member 'a 'b) type-error)
t)
(check-type-error #'(lambda (x) (member 'a x)) #'listp)
nil)
(deftest member.error.2
(signals-error (member 'a 1.3) type-error)
......
......@@ -12,17 +12,11 @@
t)
(deftest min.error.2
(loop for x in *mini-universe*
unless (or (realp x)
(eval `(signals-error (min ',x) type-error)))
collect x)
(check-type-error #'min #'realp)
nil)
(deftest min.error.3
(loop for x in *mini-universe*
unless (or (realp x)
(eval `(signals-error (min 0 ',x) type-error)))
collect x)
(check-type-error #'(lambda (x) (min 0 x)) #'realp)
nil)
(deftest min.1
......
......@@ -18,10 +18,7 @@
t)
(deftest minusp.error.4
(loop for x in *mini-universe*
unless (realp x)
unless (eval `(signals-error (minusp ',x) type-error))
collect x)
(check-type-error #'minusp #'realp)
nil)
(deftest minusp.1
......
......@@ -367,3 +367,10 @@
(signals-error (nintersection (list* 1 2 3) (list 4 5 6)) type-error)
t)
(deftest nintersection.error.13
(check-type-error #'(lambda (x) (nintersection x (copy-seq '(a b c)))) #'listp)
nil)
(deftest nintersection.error.14
(check-type-error #'(lambda (x) (nintersection (copy-seq '(a b c)) x)) #'listp)
nil)
\ No newline at end of file
......@@ -267,32 +267,17 @@
;;; Error cases
(deftest notany.error.1
(signals-error (notany 1 '(a b c)) type-error)
t)
(deftest notany.error.2
(signals-error (notany #\a '(a b c)) type-error)
t)
(deftest notany.error.3
(signals-error (notany #() '(a b c)) type-error)
t)
(check-type-error #'(lambda (x) (notany x '(a b c)))
(typef '(or symbol function)))
nil)
(deftest notany.error.4
(signals-error (notany #'null 'a) type-error)
t)
(deftest notany.error.5
(signals-error (notany #'null 100) type-error)
t)
(deftest notany.error.6
(signals-error (notany #'null 'a) type-error)
t)
(check-type-error #'(lambda (x) (notany #'null x)) #'sequencep)
nil)
(deftest notany.error.7
(signals-error (notany #'eq () 'a) type-error)
t)
(check-type-error #'(lambda (x) (notany #'eql () x)) #'sequencep)
nil)
(deftest notany.error.8
(signals-error (notany) program-error)
......
......@@ -270,32 +270,17 @@
;;; Error cases
(deftest notevery.error.1
(signals-error (notevery 1 '(a b c)) type-error)
t)
(deftest notevery.error.2
(signals-error (notevery #\a '(a b c)) type-error)
t)
(deftest notevery.error.3
(signals-error (notevery #() '(a b c)) type-error)
t)</