Commit e30ff557 authored by pfdietz's avatar pfdietz
Browse files

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