From 7413d9bf3aabadaf8b7fdf7c831539888c64b89c Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Fri, 6 May 2005 01:13:41 +0000 Subject: [PATCH] Add check-type-error, which encapsulates a common idiom. Refactor many tests that use this idiom and extend signals-type-error to more tests. Add more extended function name error tests. --- ansi-tests/acos.lsp | 5 +-- ansi-tests/acosh.lsp | 5 +-- ansi-tests/adjustable-array-p.lsp | 5 +-- ansi-tests/ansi-aux.lsp | 42 ++++++++++++++++----- ansi-tests/array-dimensions.lsp | 5 +-- ansi-tests/array-displacement.lsp | 5 +-- ansi-tests/array-rank.lsp | 5 +-- ansi-tests/array-total-size.lsp | 5 +-- ansi-tests/ash.lsp | 12 ++---- ansi-tests/asin.lsp | 5 +-- ansi-tests/asinh.lsp | 5 +-- ansi-tests/atan.lsp | 15 ++------ ansi-tests/atanh.lsp | 15 +------- ansi-tests/boundp.lsp | 4 +- ansi-tests/cl-symbols.lsp | 27 +++---------- ansi-tests/clear-input.lsp | 9 +---- ansi-tests/clear-output.lsp | 11 +----- ansi-tests/copy-pprint-dispatch.lsp | 8 +--- ansi-tests/copy-seq.lsp | 12 +----- ansi-tests/cos.lsp | 5 +-- ansi-tests/cosh.lsp | 5 +-- ansi-tests/count-if-not.lsp | 12 +----- ansi-tests/count-if.lsp | 13 ++----- ansi-tests/count.lsp | 12 +----- ansi-tests/ctypecase.lsp | 6 +-- ansi-tests/cxr.lsp | 16 ++++---- ansi-tests/ecase.lsp | 24 ++++++------ ansi-tests/elt.lsp | 2 +- ansi-tests/endp.lsp | 15 ++------ ansi-tests/etypecase.lsp | 2 +- ansi-tests/evenp.lsp | 11 ++---- ansi-tests/every.lsp | 31 +++++---------- ansi-tests/fboundp.lsp | 29 +++++++++++--- ansi-tests/fdefinition.lsp | 12 +++++- ansi-tests/file-length.lsp | 22 +++++------ ansi-tests/fill-pointer.lsp | 9 +---- ansi-tests/find-if-not.lsp | 16 ++------ ansi-tests/find-if.lsp | 16 ++------ ansi-tests/find.lsp | 16 ++------ ansi-tests/finish-output.lsp | 11 ++---- ansi-tests/fmakunbound.lsp | 13 +++++-- ansi-tests/force-output.lsp | 11 ++---- ansi-tests/format-brace.lsp | 18 ++++----- ansi-tests/funcall.lsp | 2 +- ansi-tests/gcd.lsp | 5 +-- ansi-tests/gensym.lsp | 24 +----------- ansi-tests/gentemp.lsp | 9 +---- ansi-tests/get.lsp | 14 +------ ansi-tests/hash-table-rehash-size.lsp | 13 +------ ansi-tests/hash-table-rehash-threshold.lsp | 6 +-- ansi-tests/hash-table-size.lsp | 6 +-- ansi-tests/hash-table-test.lsp | 5 +-- ansi-tests/imagpart.lsp | 5 +-- ansi-tests/input-stream-p.lsp | 6 +-- ansi-tests/integer-length.lsp | 6 +-- ansi-tests/interactive-stream-p.lsp | 6 +-- ansi-tests/isqrt.lsp | 2 +- ansi-tests/lcm.lsp | 5 +-- ansi-tests/ldiff.lsp | 11 +++--- ansi-tests/length.lsp | Bin 4162 -> 3900 bytes ansi-tests/list-length.lsp | 3 +- ansi-tests/logandc1.lsp | 10 +---- 62 files changed, 216 insertions(+), 449 deletions(-) diff --git a/ansi-tests/acos.lsp b/ansi-tests/acos.lsp index 6821bdc0..b8f2bc2d 100644 --- a/ansi-tests/acos.lsp +++ b/ansi-tests/acos.lsp @@ -92,8 +92,5 @@ t) (deftest acos.error.3 - (loop for x in *mini-universe* - unless (or (numberp x) - (eval `(signals-type-error x ',x (acos x)))) - collect x) + (check-type-error #'acos #'numberp) nil) diff --git a/ansi-tests/acosh.lsp b/ansi-tests/acosh.lsp index f36b38de..2af7791c 100644 --- a/ansi-tests/acosh.lsp +++ b/ansi-tests/acosh.lsp @@ -82,10 +82,7 @@ t) (deftest acosh.error.3 - (loop for x in *mini-universe* - unless (or (numberp x) - (eval `(signals-type-error x ',x (acosh x)))) - collect x) + (check-type-error #'acosh #'numberp) nil) diff --git a/ansi-tests/adjustable-array-p.lsp b/ansi-tests/adjustable-array-p.lsp index 0279e8de..6832be79 100644 --- a/ansi-tests/adjustable-array-p.lsp +++ b/ansi-tests/adjustable-array-p.lsp @@ -48,10 +48,7 @@ t) (deftest adjustable-array-p.error.4 - (loop for e in *mini-universe* - unless (or (typep e 'array) - (eval `(signals-type-error x ',e (adjustable-array-p x)))) - collect e) + (check-type-error #'adjustable-array-p #'arrayp) nil) (deftest adjustable-array-p.error.5 diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 6009c9c0..232a2d7a 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -272,7 +272,7 @@ the condition to go uncaught if it cannot be classified." ;;; The above is badly designed, since it fails when some signals ;;; may be in more than one class/ -(defmacro signals-error (form error-name &key (safety 3) (name nil name-p)) +(defmacro signals-error (form error-name &key (safety 3) (name nil name-p) (inline nil)) `(handler-bind ((warning #'(lambda (c) (declare (ignore c)) (muffle-warning)))) @@ -281,11 +281,13 @@ the condition to go uncaught if it cannot be classified." (apply #'values nil (multiple-value-list - (if regression-test::*compile-tests* - (funcall (compile nil '(lambda () + ,(cond + (inline form) + (regression-test::*compile-tests* + `(funcall (compile nil '(lambda () (declare (optimize (safety ,safety))) - ,form))) - (eval ',form)))) + ,form)))) + (t `(eval ',form))))) (,error-name (c) (cond ,@(case error-name @@ -326,12 +328,13 @@ the condition to go uncaught if it cannot be classified." (signals-error ,form ,error-name) (signals-error ,form ,error-name :safety 0))) -(defmacro signals-type-error (var datum-form form &key (safety 3)) +(defmacro signals-type-error (var datum-form form &key (safety 3) (inline nil)) (let ((lambda-form `(lambda (,var) (declare (optimize (safety ,safety))) ,form))) `(let ((,var ,datum-form)) + (declare (optimize safety)) (handler-bind ((warning #'(lambda (c) (declare (ignore c)) (muffle-warning)))) @@ -341,9 +344,11 @@ the condition to go uncaught if it cannot be classified." nil (multiple-value-list (funcall - (if regression-test::*compile-tests* - (compile nil ',lambda-form) - (eval ',lambda-form)) + ,(cond + (inline `(function ,lambda-form)) + (regression-test::*compile-tests* + `(compile nil ',lambda-form)) + (t `(eval ',lambda-form))) ,var))) (type-error (c) @@ -356,6 +361,23 @@ the condition to go uncaught if it cannot be classified." (list :is-typep datum expected-type)) (t (printable-p c)))))))))) +(declaim (special *mini-universe*)) + +(defun check-type-error* (pred-fn guard-fn &optional (universe *mini-universe*)) + "Check that for all elements in some set, either guard-fn is true or + pred-fn signals a type error." + (let (val) + (loop for e in universe + unless (or (funcall guard-fn e) + (equal + (setf val (multiple-value-list + (signals-type-error x e (funcall pred-fn x) :inline t))) + '(t))) + collect (list e val)))) + +(defmacro check-type-error (&body args) + `(locally (declare (optimize safety)) (check-type-error* ,@args))) + (defun printable-p (obj) "Returns T iff obj can be printed to a string." (with-standard-io-syntax @@ -1120,3 +1142,5 @@ the condition to go uncaught if it cannot be classified." (double-float double-float-negative-epsilon) (long-float long-float-negative-epsilon) (rational 0))) + +(defun sequencep (x) (typep x 'sequence)) diff --git a/ansi-tests/array-dimensions.lsp b/ansi-tests/array-dimensions.lsp index f96cb845..98d94cff 100644 --- a/ansi-tests/array-dimensions.lsp +++ b/ansi-tests/array-dimensions.lsp @@ -51,10 +51,7 @@ t) (deftest array-dimensions.error.3 - (loop for e in *mini-universe* - unless (or (typep e 'array) - (eval `(signals-type-error x ',e (array-dimensions x)))) - collect e) + (check-type-error #'array-dimensions #'arrayp) nil) (deftest array-dimensions.error.4 diff --git a/ansi-tests/array-displacement.lsp b/ansi-tests/array-displacement.lsp index 321cb415..ad668be5 100644 --- a/ansi-tests/array-displacement.lsp +++ b/ansi-tests/array-displacement.lsp @@ -116,10 +116,7 @@ t) (deftest array-displacement.error.3 - (loop for e in *mini-universe* - unless (or (typep e 'array) - (eval `(signals-type-error x ',e (array-displacement ',e)))) - collect e) + (check-type-error #'array-displacement #'arrayp) nil) (deftest array-displacement.error.4 diff --git a/ansi-tests/array-rank.lsp b/ansi-tests/array-rank.lsp index c86c9a7a..6126d5e3 100644 --- a/ansi-tests/array-rank.lsp +++ b/ansi-tests/array-rank.lsp @@ -36,10 +36,7 @@ t) (deftest array-rank.error.3 - (loop for e in *mini-universe* - unless (or (typep e 'array) - (eval `(signals-type-error x ',e (array-rank x)))) - collect e) + (check-type-error #'array-rank #'arrayp) nil) (deftest array-rank.error.4 diff --git a/ansi-tests/array-total-size.lsp b/ansi-tests/array-total-size.lsp index 3abb0822..50ab953f 100644 --- a/ansi-tests/array-total-size.lsp +++ b/ansi-tests/array-total-size.lsp @@ -45,10 +45,7 @@ t) (deftest array-total-size.error.3 - (loop for e in *mini-universe* - unless (or (typep e 'array) - (eval `(signals-type-error x ',e (array-total-size ',e)))) - collect e) + (check-type-error #'array-total-size #'arrayp) nil) (deftest array-total-size.error.4 diff --git a/ansi-tests/ash.lsp b/ansi-tests/ash.lsp index 2f57ace2..3f26369f 100644 --- a/ansi-tests/ash.lsp +++ b/ansi-tests/ash.lsp @@ -20,17 +20,11 @@ t) (deftest ash.error.4 - (loop for x in *mini-universe* - unless (or (integerp x) - (eval `(signals-type-error x ',x (ash x 0)))) - collect x) + (check-type-error #'(lambda (x) (ash x 0)) #'integerp) nil) (deftest ash.error.5 - (loop for x in *mini-universe* - unless (or (integerp x) - (eval `(signals-type-error x ',x (ash 0 x)))) - collect x) + (check-type-error #'(lambda (x) (ash 0 x)) #'integerp) nil) ;;; Non-error tests @@ -59,7 +53,7 @@ t) (deftest ash.4 - (loop for i from -1 to -1000 + (loop for i from -1 downto -1000 always (eql (ash i i) -1)) t) diff --git a/ansi-tests/asin.lsp b/ansi-tests/asin.lsp index b3212bc8..7db773c5 100644 --- a/ansi-tests/asin.lsp +++ b/ansi-tests/asin.lsp @@ -92,10 +92,7 @@ t) (deftest asin.error.3 - (loop for x in *mini-universe* - unless (or (numberp x) - (eval `(signals-type-error x ',x (asin x)))) - collect x) + (check-type-error #'asin #'numberp) nil) diff --git a/ansi-tests/asinh.lsp b/ansi-tests/asinh.lsp index ac76d259..9501c01c 100644 --- a/ansi-tests/asinh.lsp +++ b/ansi-tests/asinh.lsp @@ -80,10 +80,7 @@ t) (deftest asinh.error.3 - (loop for x in *mini-universe* - unless (or (numberp x) - (eval `(signals-type-error x ',x (asinh x)))) - collect x) + (check-type-error #'asinh #'numberp) nil) diff --git a/ansi-tests/atan.lsp b/ansi-tests/atan.lsp index bdef875d..54c77b0a 100644 --- a/ansi-tests/atan.lsp +++ b/ansi-tests/atan.lsp @@ -133,24 +133,15 @@ t) (deftest atan.error.3 - (loop for x in *mini-universe* - unless (or (numberp x) - (eval `(signals-type-error x ',x (atan x)))) - collect x) + (check-type-error #'atan #'numberp) nil) (deftest atan.error.4 - (loop for x in *mini-universe* - unless (or (realp x) - (eval `(signals-type-error x ',x (atan x 1)))) - collect x) + (check-type-error #'(lambda (x) (atan x 1)) #'realp) nil) (deftest atan.error.5 - (loop for x in *mini-universe* - unless (or (realp x) - (eval `(signals-type-error x ',x (atan 1 x)))) - collect x) + (check-type-error #'(lambda (x) (atan 1 x)) #'realp) nil) diff --git a/ansi-tests/atanh.lsp b/ansi-tests/atanh.lsp index ec1f2b69..1d4adffe 100644 --- a/ansi-tests/atanh.lsp +++ b/ansi-tests/atanh.lsp @@ -109,18 +109,5 @@ t) (deftest atanh.error.3 - (loop for x in *mini-universe* - unless (or (numberp x) - (eval `(signals-type-error x ',x (atanh x)))) - collect x) + (check-type-error #'atanh #'numberp) nil) - - - - - - - - - - diff --git a/ansi-tests/boundp.lsp b/ansi-tests/boundp.lsp index 122e0d71..84a2a270 100644 --- a/ansi-tests/boundp.lsp +++ b/ansi-tests/boundp.lsp @@ -14,8 +14,8 @@ t) (deftest boundp.error.3 - (signals-type-error x 1 (boundp 1)) - t) + (check-type-error #'boundp #'symbolp) + nil) (deftest boundp.error.4 (signals-type-error x '(setf car) (boundp x)) diff --git a/ansi-tests/cl-symbols.lsp b/ansi-tests/cl-symbols.lsp index 52b13d10..95034a5c 100644 --- a/ansi-tests/cl-symbols.lsp +++ b/ansi-tests/cl-symbols.lsp @@ -1146,10 +1146,7 @@ t) (deftest symbol-package.error.3 - (loop for x in *mini-universe* - for form = `(signals-type-error x ',x (symbol-package x)) - unless (or (symbolp x) (eval form)) - collect x) + (check-type-error #'symbol-package #'symbolp) nil) @@ -1162,18 +1159,12 @@ t) (deftest symbol-plist.error.3 - (loop for x in *mini-universe* - for form = `(signals-type-error x ',x (symbol-plist x)) - unless (or (symbolp x) (eval form)) - collect x) + (check-type-error #'symbol-plist #'symbolp) nil) (deftest symbol-plist.error.4 - (loop for x in *mini-universe* - for form = `(signals-type-error x ',x (setf (symbol-plist x) - (find-package "CL-USER"))) - unless (or (symbolp x) (eval form)) - collect x) + (check-type-error #'(lambda (x) (setf (symbol-plist x) nil)) + #'symbolp) nil) @@ -1187,17 +1178,11 @@ t) (deftest symbol-value.error.3 - (loop for x in *mini-universe* - for form = `(signals-type-error x ',x (symbol-value x)) - unless (or (symbolp x) (eval form)) - collect x) + (check-type-error #'symbol-value #'symbolp) nil) (deftest symbol-value.error.4 - (loop for x in *mini-universe* - for form = `(signals-type-error x ',x (setf (symbol-value x) nil)) - unless (or (symbolp x) (eval form)) - collect x) + (check-type-error #'(lambda (x) (setf (symbol-value x) nil)) #'symbolp) nil) (deftest symbol-value.error.5 diff --git a/ansi-tests/clear-input.lsp b/ansi-tests/clear-input.lsp index 334a659d..73c12f81 100644 --- a/ansi-tests/clear-input.lsp +++ b/ansi-tests/clear-input.lsp @@ -60,12 +60,5 @@ t) (deftest clear-input.error.5 - (loop for x in *mini-universe* - unless (or (member x '(nil t)) - (typep x 'stream) - (equalt - (eval `(multiple-value-list - (signals-type-error x ',x (clear-input x)))) - '(t))) - collect x) + (check-type-error #'clear-input #'(lambda (x) (typep x '(or stream (member nil t))))) nil) diff --git a/ansi-tests/clear-output.lsp b/ansi-tests/clear-output.lsp index b03f6b87..03f0ae80 100644 --- a/ansi-tests/clear-output.lsp +++ b/ansi-tests/clear-output.lsp @@ -49,14 +49,5 @@ t) (deftest clear-output.error.3 - (loop for x in *mini-universe* - unless (or (member x '(nil t)) - (typep x 'stream) - (equalt - (eval `(multiple-value-list - (signals-type-error x ',x (clear-output x)))) - '(t))) - collect x) + (check-type-error #'clear-output #'(lambda (x) (typep x '(or stream (member nil t))))) nil) - - diff --git a/ansi-tests/copy-pprint-dispatch.lsp b/ansi-tests/copy-pprint-dispatch.lsp index 0f383c63..3bb4fbd6 100644 --- a/ansi-tests/copy-pprint-dispatch.lsp +++ b/ansi-tests/copy-pprint-dispatch.lsp @@ -120,11 +120,5 @@ t) (deftest copy-pprint-dispatch.error.2 - (loop for x in *mini-universe* - for results = (multiple-value-list - (eval `(signals-type-error x ',x (copy-pprint-dispatch x)))) - unless (or (null x) - (equal results '(t))) - collect (list x results)) + (check-type-error #'copy-pprint-dispatch #'null) nil) - diff --git a/ansi-tests/copy-seq.lsp b/ansi-tests/copy-seq.lsp index f60bbf7c..8d974b12 100644 --- a/ansi-tests/copy-seq.lsp +++ b/ansi-tests/copy-seq.lsp @@ -230,16 +230,8 @@ ;;; Error tests (deftest copy-seq.error.1 - (signals-type-error x 10 (copy-seq x)) - t) - -(deftest copy-seq.error.2 - (signals-type-error x 'a (copy-seq x)) - t) - -(deftest copy-seq.error.3 - (signals-type-error x 13.21 (copy-seq x)) - t) + (check-type-error #'copy-seq #'sequencep) + nil) (deftest copy-seq.error.4 (signals-error (copy-seq) program-error) diff --git a/ansi-tests/cos.lsp b/ansi-tests/cos.lsp index c38b1b2f..3cd38f6d 100644 --- a/ansi-tests/cos.lsp +++ b/ansi-tests/cos.lsp @@ -167,9 +167,6 @@ t) (deftest cos.error.3 - (loop for x in *mini-universe* - unless (or (numberp x) - (eval `(signals-type-error x ',x (cos x)))) - collect x) + (check-type-error #'cos #'numberp) nil) diff --git a/ansi-tests/cosh.lsp b/ansi-tests/cosh.lsp index 602d0942..60b07581 100644 --- a/ansi-tests/cosh.lsp +++ b/ansi-tests/cosh.lsp @@ -82,10 +82,7 @@ t) (deftest cosh.error.3 - (loop for x in *mini-universe* - unless (or (numberp x) - (eval `(signals-type-error x ',x (cosh x)))) - collect x) + (check-type-error #'cosh #'numberp) nil) diff --git a/ansi-tests/count-if-not.lsp b/ansi-tests/count-if-not.lsp index 70331c5c..ecab1f7e 100644 --- a/ansi-tests/count-if-not.lsp +++ b/ansi-tests/count-if-not.lsp @@ -525,16 +525,8 @@ ;;; Error tests (deftest count-if-not.error.1 - (signals-type-error x 1 (count-if-not #'identity x)) - t) - -(deftest count-if-not.error.2 - (signals-type-error x 'a (count-if-not #'identity x)) - t) - -(deftest count-if-not.error.3 - (signals-type-error x #\a (count-if-not #'identity x)) - t) + (check-type-error #'(lambda (x) (count-if-not #'identity x)) #'sequencep) + nil) (deftest count-if-not.error.4 (signals-error (count-if-not) program-error) diff --git a/ansi-tests/count-if.lsp b/ansi-tests/count-if.lsp index c16577b6..9558dbf6 100644 --- a/ansi-tests/count-if.lsp +++ b/ansi-tests/count-if.lsp @@ -524,16 +524,9 @@ ;;; Error tests (deftest count-if.error.1 - (signals-type-error x 1 (count-if #'identity x)) - t) - -(deftest count-if.error.2 - (signals-type-error x 'a (count-if #'identity x)) - t) - -(deftest count-if.error.3 - (signals-type-error x #\a (count-if #'identity x)) - t) + (check-type-error #'(lambda (x) (count-if #'identity x)) + #'sequencep) + nil) (deftest count-if.error.4 (signals-error (count-if) program-error) diff --git a/ansi-tests/count.lsp b/ansi-tests/count.lsp index d609430a..c2d87356 100644 --- a/ansi-tests/count.lsp +++ b/ansi-tests/count.lsp @@ -653,16 +653,8 @@ ;;; Error tests (deftest count.error.1 - (signals-type-error x 1 (count 'a x)) - t) - -(deftest count.error.2 - (signals-type-error x 'a (count 'a x)) - t) - -(deftest count.error.3 - (signals-type-error x #\a (count 'a x)) - t) + (check-type-error #'(lambda (x) (count 'a x)) #'sequencep) + nil) (deftest count.error.4 (signals-error (count) program-error) diff --git a/ansi-tests/ctypecase.lsp b/ansi-tests/ctypecase.lsp index 9c07604c..0916f4d6 100644 --- a/ansi-tests/ctypecase.lsp +++ b/ansi-tests/ctypecase.lsp @@ -11,10 +11,8 @@ a) (deftest ctypecase.2 - (signals-type-error - x 1 - (ctypecase x (symbol 'a))) - t) + (check-type-error #'(lambda (x) (ctypecase x (symbol 'a))) #'symbolp) + nil) (deftest ctypecase.3 (let ((x 1)) diff --git a/ansi-tests/cxr.lsp b/ansi-tests/cxr.lsp index 6113f87c..7fe6e9fa 100644 --- a/ansi-tests/cxr.lsp +++ b/ansi-tests/cxr.lsp @@ -148,11 +148,11 @@ (car nil) nil) -(deftest car-symbol-error - (signals-type-error x 'a (car x)) - t) +(deftest car.error.1 + (check-type-error #'car #'listp) + nil) -(deftest car-symbol-error.2 +(deftest car.error.2 (signals-error (locally (car 'a) t) type-error) t) @@ -174,11 +174,11 @@ (values (cdr (progn (incf i) '(a b))) i)) (b) 1) -(deftest cdr-symbol-error - (signals-type-error x 'a (cdr x)) - t) +(deftest cdr.error.1 + (check-type-error #'cdr #'listp) + nil) -(deftest cdr-symbol-error.2 +(deftest cdr.error.2 (signals-error (locally (cdr 'a) t) type-error) t) diff --git a/ansi-tests/ecase.lsp b/ansi-tests/ecase.lsp index 6a42ec14..36848484 100644 --- a/ansi-tests/ecase.lsp +++ b/ansi-tests/ecase.lsp @@ -10,22 +10,22 @@ 2) (deftest ecase.2 - (signals-error (ecase 1) type-error) + (signals-type-error x 1 (ecase x)) t) (deftest ecase.3 - (signals-error (ecase 1 (a 1) (b 2) (c 3)) type-error) + (signals-type-error x 1 (ecase x (a 1) (b 2) (c 3))) t) ;;; It is legal to use T or OTHERWISE as key designators ;;; in ECASE forms. They have no special meaning here. (deftest ecase.4 - (signals-error (ecase 1 (t nil)) type-error) + (signals-type-error x 1 (ecase x (t nil))) t) (deftest ecase.5 - (signals-error (ecase 1 (otherwise nil)) type-error) + (signals-type-error x 1 (ecase x (otherwise nil))) t) (deftest ecase.6 @@ -45,7 +45,7 @@ a) (deftest ecase.9 - (signals-error (ecase nil (nil 'a)) type-error) + (signals-type-error x nil (ecase x (nil 'a))) t) (deftest ecase.10 @@ -57,7 +57,7 @@ 1 2 3) (deftest ecase.12 - (signals-error (ecase t (a 10)) type-error) + (signals-type-error x t (ecase x (a 10))) t) (deftest ecase.13 @@ -70,25 +70,23 @@ 1) (deftest ecase.15 - (signals-error (ecase 'otherwise ((t) 10)) type-error) + (signals-type-error x 'otherwise (ecase x ((t) 10))) t) (deftest ecase.16 - (signals-error (ecase t ((otherwise) 10)) type-error) + (signals-type-error x t (ecase x ((otherwise) 10))) t) (deftest ecase.17 - (signals-error (ecase 'a (b 0) (c 1) (otherwise 2)) - type-error) + (signals-type-error x 'a (ecase x (b 0) (c 1) (otherwise 2))) t) (deftest ecase.18 - (signals-error (ecase 'a (b 0) (c 1) ((otherwise) 2)) - type-error) + (signals-type-error x 'a (ecase x (b 0) (c 1) ((otherwise) 2))) t) (deftest ecase.19 - (signals-error (ecase 'a (b 0) (c 1) ((t) 2)) type-error) + (signals-type-error x 'a (ecase x (b 0) (c 1) ((t) 2))) t) (deftest ecase.20 diff --git a/ansi-tests/elt.lsp b/ansi-tests/elt.lsp index c0a1fb22..ff34d76e 100644 --- a/ansi-tests/elt.lsp +++ b/ansi-tests/elt.lsp @@ -10,7 +10,7 @@ ;; elt on lists (deftest elt.1 - (signals-error (elt nil 0) type-error) + (signals-error (elt x 0) type-error) t) (deftest elt.1a diff --git a/ansi-tests/endp.lsp b/ansi-tests/endp.lsp index 76154f47..1b5323ce 100644 --- a/ansi-tests/endp.lsp +++ b/ansi-tests/endp.lsp @@ -26,17 +26,9 @@ i)) nil 1) -(deftest endp-symbol-error - (catch-type-error (endp 'a)) - type-error) - -(deftest endp-fixnum-error - (catch-type-error (endp 1)) - type-error) - -(deftest endp-float-error - (catch-type-error (endp 0.9212d4)) - type-error) +(deftest endp.error.1 + (check-type-error #'endp #'listp) + nil) (deftest endp.error.4 (signals-error (endp) program-error) @@ -49,4 +41,3 @@ (deftest endp.error.6 (signals-error (locally (endp 1)) type-error) t) - diff --git a/ansi-tests/etypecase.lsp b/ansi-tests/etypecase.lsp index 1c212169..9a6337e4 100644 --- a/ansi-tests/etypecase.lsp +++ b/ansi-tests/etypecase.lsp @@ -12,7 +12,7 @@ a) (deftest etypecase.2 - (signals-error (etypecase 1 (symbol 'a)) type-error) + (signals-type-error x 1 (etypecase x (symbol 'a))) t) (deftest etypecase.3 diff --git a/ansi-tests/evenp.lsp b/ansi-tests/evenp.lsp index 37a3f6c0..4d4d1158 100644 --- a/ansi-tests/evenp.lsp +++ b/ansi-tests/evenp.lsp @@ -15,19 +15,16 @@ (signals-error (evenp 0 nil) program-error) t) +(deftest evenp.error.3 + (check-type-error #'evenp #'integerp) + nil) + (deftest evenp.1 (loop for x in *numbers* when (integerp x) do (evenp x)) nil) -(deftest evenp.2 - (loop for x in *mini-universe* - unless (or (integerp x) - (eval `(signals-error (evenp ',x) type-error))) - collect x) - nil) - (deftest evenp.3 (loop for x = (random-fixnum) repeat 10000 diff --git a/ansi-tests/every.lsp b/ansi-tests/every.lsp index cf8b933a..9fed1415 100644 --- a/ansi-tests/every.lsp +++ b/ansi-tests/every.lsp @@ -279,32 +279,19 @@ ;;; Error cases (deftest every.error.1 - (signals-error (every 1 '(a b c)) type-error) - t) + (check-type-error #'(lambda (x) (every x '(a b c))) + #'(lambda (x) (typep x '(or function symbol)))) + nil) (deftest every.error.2 - (signals-error (every #\a '(a b c)) type-error) - t) + (check-type-error #'(lambda (x) (every #'null x)) + #'(lambda (x) (typep x 'sequence))) + nil) (deftest every.error.3 - (signals-error (every #() '(a b c)) type-error) - t) - -(deftest every.error.4 - (signals-error (every #'null 'a) type-error) - t) - -(deftest every.error.5 - (signals-error (every #'null 100) type-error) - t) - -(deftest every.error.6 - (signals-error (every #'null 'a) type-error) - t) - -(deftest every.error.7 - (signals-error (every #'eq () 'a) type-error) - t) + (check-type-error #'(lambda (x) (every #'eq () x)) + #'(lambda (x) (typep x 'sequence))) + nil) (deftest every.error.8 (signals-error (every) program-error) diff --git a/ansi-tests/fboundp.lsp b/ansi-tests/fboundp.lsp index 0d8eb6a1..1ec57151 100644 --- a/ansi-tests/fboundp.lsp +++ b/ansi-tests/fboundp.lsp @@ -51,25 +51,42 @@ t 1) (deftest fboundp.error.1 - (signals-error (fboundp 1) type-error) - t) + (check-type-error #'fboundp #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null)))))) + nil) (deftest fboundp.error.2 - (signals-error (fboundp #\a) type-error) + (signals-type-error x '(x) (fboundp x)) t) (deftest fboundp.error.3 - (signals-error (fboundp '(foo)) type-error) + (signals-type-error x '(setf) (fboundp x)) t) (deftest fboundp.error.4 - (signals-error (fboundp) program-error) + (signals-type-error x '(setf foo . bar) (fboundp x)) t) (deftest fboundp.error.5 - (signals-error (fboundp 'cons nil) program-error) + (signals-type-error x '(setf foo bar) (fboundp x)) t) (deftest fboundp.error.6 + (signals-error (fboundp) program-error) + t) + +(deftest fboundp.error.7 + (signals-error (fboundp 'cons nil) program-error) + t) + +(deftest fboundp.error.8 (signals-error (locally (fboundp 1) t) type-error) t) + +(deftest fboundp.error.9 + (signals-type-error x '(setf . foo) (fboundp x)) + t) + +(deftest fboundp.error.10 + (check-type-error #'(lambda (x) (fboundp `(setf ,x))) + #'symbolp) + nil) diff --git a/ansi-tests/fdefinition.lsp b/ansi-tests/fdefinition.lsp index 274dd637..97781a49 100644 --- a/ansi-tests/fdefinition.lsp +++ b/ansi-tests/fdefinition.lsp @@ -22,8 +22,8 @@ t) (deftest fdefinition.error.4 - (signals-error (fdefinition 10) type-error :name 10) - t) + (check-type-error #'fdefinition #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null)))))) + nil) (deftest fdefinition.error.5 (let ((fn `(setf ,(gensym)))) @@ -35,6 +35,14 @@ (signals-error (locally (fdefinition 10) t) type-error) t) +(deftest fdefinition.error.7 + (check-type-error #'fdefinition (constantly nil) '((setf) (setf . foo) (setf foo . bar) (setf foo bar))) + nil) + +(deftest fdefinition.error.8 + (check-type-error #'(lambda (x) (fdefinition `(setf ,x))) #'symbolp) + nil) + ;;; Non-error cases (deftest fdefinition.1 diff --git a/ansi-tests/file-length.lsp b/ansi-tests/file-length.lsp index 73c36aa5..e087e532 100644 --- a/ansi-tests/file-length.lsp +++ b/ansi-tests/file-length.lsp @@ -21,7 +21,9 @@ unless (or (typep x 'file-stream) (typep x 'broadcast-stream) (handler-case (progn (file-length x) nil) - (type-error () t) + (type-error (c) + (assert (not (typep x (type-error-expected-type c)))) + t) (condition () nil))) collect x) nil) @@ -62,10 +64,8 @@ t) (deftest file-length.error.9 - (signals-error - (let ((s (make-concatenated-stream))) - (unwind-protect (file-length s) (close s))) - type-error) + (signals-type-error s (make-concatenated-stream) + (unwind-protect (file-length s) (close s))) t) (deftest file-length.error.10 @@ -79,18 +79,14 @@ (deftest file-length.error.11 :notes (:assume-no-simple-streams :assume-no-gray-streams) - (signals-error - (let ((s (make-string-input-stream "abcde"))) - (unwind-protect (file-length s) (close s))) - type-error) + (signals-type-error s (make-string-input-stream "abcde") + (unwind-protect (file-length s) (close s))) t) (deftest file-length.error.12 :notes (:assume-no-simple-streams :assume-no-gray-streams) - (signals-error - (let ((s (make-string-output-stream))) - (unwind-protect (file-length s) (close s))) - type-error) + (signals-type-error s (make-string-output-stream) + (unwind-protect (file-length s) (close s))) t) ;;; Non-error tests diff --git a/ansi-tests/fill-pointer.lsp b/ansi-tests/fill-pointer.lsp index e12005a8..b318724b 100644 --- a/ansi-tests/fill-pointer.lsp +++ b/ansi-tests/fill-pointer.lsp @@ -69,13 +69,8 @@ t) (deftest fill-pointer.error.6 - (loop for e in *mini-universe* - when (and (or (not (typep e 'vector)) - (not (array-has-fill-pointer-p e))) - (not (eval `(signals-error - (fill-pointer ',e) - type-error)))) - collect (list e)) + (check-type-error #'fill-pointer #'(lambda (x) (and (vectorp x) + (array-has-fill-pointer-p x)))) nil) (deftest fill-pointer.error.7 diff --git a/ansi-tests/find-if-not.lsp b/ansi-tests/find-if-not.lsp index c774e4de..a657e5d8 100644 --- a/ansi-tests/find-if-not.lsp +++ b/ansi-tests/find-if-not.lsp @@ -519,16 +519,8 @@ ;;; Error tests (deftest find-if-not.error.1 - (signals-error (find-if-not #'null 'b) type-error) - t) - -(deftest find-if-not.error.2 - (signals-error (find-if-not #'identity 10) type-error) - t) - -(deftest find-if-not.error.3 - (signals-error (find-if-not '1+ 1.4) type-error) - t) + (check-type-error #'(lambda (x) (find-if-not #'null x)) #'(lambda (x) (typep x 'sequence))) + nil) (deftest find-if-not.error.4 (signals-error (find-if-not 'identity '(a b c . d)) @@ -593,7 +585,7 @@ a 2 1 2) (deftest find-if-not.order.2 - (let ((i 0) a b c d e f g) + (let ((i 0) a b c d e f) (values (find-if-not (progn (setf a (incf i)) #'identity) (progn (setf b (incf i)) '(nil nil nil a nil nil)) @@ -607,7 +599,7 @@ (deftest find-if-not.order.3 - (let ((i 0) a b c d e f g) + (let ((i 0) a b c d e f) (values (find-if-not (progn (setf a (incf i)) #'identity) (progn (setf b (incf i)) '(nil nil nil a nil nil)) diff --git a/ansi-tests/find-if.lsp b/ansi-tests/find-if.lsp index 01bf0f86..04c87069 100644 --- a/ansi-tests/find-if.lsp +++ b/ansi-tests/find-if.lsp @@ -543,16 +543,8 @@ ;;; Error tests (deftest find-if.error.1 - (signals-error (find-if #'null 'b) type-error) - t) - -(deftest find-if.error.2 - (signals-error (find-if #'identity 10) type-error) - t) - -(deftest find-if.error.3 - (signals-error (find-if '1+ 1.4) type-error) - t) + (check-type-error #'(lambda (x) (find-if #'null x)) #'(lambda (x) (typep x 'sequence))) + nil) (deftest find-if.error.4 (signals-error (find-if 'null '(a b c . d)) type-error) @@ -615,7 +607,7 @@ a 2 1 2) (deftest find-if.order.2 - (let ((i 0) a b c d e f g) + (let ((i 0) a b c d e f) (values (find-if (progn (setf a (incf i)) #'null) (progn (setf b (incf i)) '(nil nil nil a nil nil)) @@ -629,7 +621,7 @@ (deftest find-if.order.3 - (let ((i 0) a b c d e f g) + (let ((i 0) a b c d e f) (values (find-if (progn (setf a (incf i)) #'null) (progn (setf b (incf i)) '(nil nil nil a nil nil)) diff --git a/ansi-tests/find.lsp b/ansi-tests/find.lsp index 803e303e..9825349a 100644 --- a/ansi-tests/find.lsp +++ b/ansi-tests/find.lsp @@ -868,16 +868,8 @@ ;;; Error tests (deftest find.error.1 - (signals-error (find 'a 'b) type-error) - t) - -(deftest find.error.2 - (signals-error (find 'a 10) type-error) - t) - -(deftest find.error.3 - (signals-error (find 'a 1.4) type-error) - t) + (check-type-error #'(lambda (x) (find 'a x)) #'(lambda (x) (typep x 'sequence))) + nil) (deftest find.error.4 (signals-error (find 'e '(a b c . d)) type-error) @@ -940,7 +932,7 @@ a 2 1 2) (deftest find.order.2 - (let ((i 0) a b c d e f g) + (let ((i 0) a b c d e f) (values (find (progn (setf a (incf i)) nil) (progn (setf b (incf i)) '(nil nil nil a nil nil)) @@ -953,7 +945,7 @@ a 6 1 2 3 4 5 6) (deftest find.order.3 - (let ((i 0) a b c d e f g) + (let ((i 0) a b c d e f) (values (find (progn (setf a (incf i)) nil) (progn (setf b (incf i)) '(nil nil nil a nil nil)) diff --git a/ansi-tests/finish-output.lsp b/ansi-tests/finish-output.lsp index 08a2cf77..f6fab14e 100644 --- a/ansi-tests/finish-output.lsp +++ b/ansi-tests/finish-output.lsp @@ -48,12 +48,7 @@ t) (deftest finish-output.error.3 - (loop for x in *mini-universe* - unless (or (member x '(nil t)) - (typep x 'stream) - (equalt - (eval `(multiple-value-list - (signals-error (finish-output ',x) type-error))) - '(t))) - collect x) + (check-type-error #'finish-output + #'(lambda (x) (typep x '(or stream (member nil t))))) nil) + diff --git a/ansi-tests/fmakunbound.lsp b/ansi-tests/fmakunbound.lsp index 9ca7b922..3f7200cd 100644 --- a/ansi-tests/fmakunbound.lsp +++ b/ansi-tests/fmakunbound.lsp @@ -43,15 +43,17 @@ t nil) (deftest fmakunbound.error.1 - (signals-error (fmakunbound 1) type-error) + (check-type-error #'fmakunbound + #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null)))))) t) (deftest fmakunbound.error.2 - (signals-error (fmakunbound #\a) type-error) - t) + (check-type-error #'fmakunbound (constantly nil) + '((setf) (setf . foo) (setf foo . bar) (setf foo bar))) + nil) (deftest fmakunbound.error.3 - (signals-error (fmakunbound '(x)) type-error) + (signals-type-error x '(x) (fmakunbound x)) t) (deftest fmakunbound.error.4 @@ -66,3 +68,6 @@ (signals-error (locally (fmakunbound 1) t) type-error) t) +(deftest fmakunbound.error.7 + (check-type-error #'(lambda (x) (fmakunbound `(setf ,x))) #'symbolp) + t) diff --git a/ansi-tests/force-output.lsp b/ansi-tests/force-output.lsp index f2ec4c66..af3584bc 100644 --- a/ansi-tests/force-output.lsp +++ b/ansi-tests/force-output.lsp @@ -49,13 +49,8 @@ t) (deftest force-output.error.3 - (loop for x in *mini-universe* - unless (or (member x '(nil t)) - (typep x 'stream) - (equalt - (eval `(multiple-value-list - (signals-error (force-output ',x) type-error))) - '(t))) - collect x) + (check-type-error #'force-output + #'(lambda (x) (typep x '(or stream (member nil t))))) nil) + diff --git a/ansi-tests/format-brace.lsp b/ansi-tests/format-brace.lsp index 8c6286c2..6c147bd6 100644 --- a/ansi-tests/format-brace.lsp +++ b/ansi-tests/format-brace.lsp @@ -308,19 +308,19 @@ ;;; Error tests (deftest format.{.error.1 - (signals-error (format nil "~{~A~}" 'A) type-error) + (signals-type-error x 'A (format nil "~{~A~}" x)) t) (deftest format.{.error.2 - (signals-error (format nil "~{~A~}" 1) type-error) + (signals-type-error x 1 (format nil "~{~A~}" x)) t) (deftest format.{.error.3 - (signals-error (format nil "~{~A~}" "foo") type-error) + (signals-type-error x "foo" (format nil "~{~A~}" x)) t) (deftest format.{.error.4 - (signals-error (format nil "~{~A~}" #*01101) type-error) + (signals-type-error x #*01101 (format nil "~{~A~}" x)) t) (deftest format.{.error.5 @@ -332,7 +332,7 @@ t) (deftest format.\:{.error.2 - (signals-error (format nil "~:{~A~}" 'x) type-error) + (signals-type-error x 'x (format nil "~:{~A~}" x)) t) (deftest format.\:{.error.3 @@ -348,19 +348,19 @@ t) (deftest format.\:@.error.1 - (signals-error (format nil "~:@{~A~}" 'x) type-error) + (signals-type-error x 'x (format nil "~:@{~A~}" x)) t) (deftest format.\:@.error.2 - (signals-error (format nil "~:@{~A~}" 0) type-error) + (signals-type-error x 0 (format nil "~:@{~A~}" x)) t) (deftest format.\:@.error.3 - (signals-error (format nil "~:@{~A~}" #*01101) type-error) + (signals-type-error x #*01101 (format nil "~:@{~A~}" x)) t) (deftest format.\:@.error.4 - (signals-error (format nil "~:@{~A~}" "abc") type-error) + (signals-type-error x "abc" (format nil "~:@{~A~}" x)) t) (deftest format.\:@.error.5 diff --git a/ansi-tests/funcall.lsp b/ansi-tests/funcall.lsp index 404a412e..5e0a3b80 100644 --- a/ansi-tests/funcall.lsp +++ b/ansi-tests/funcall.lsp @@ -101,5 +101,5 @@ t) (deftest funcall.error.7 - (signals-error (funcall #'car 'a) type-error) + (signals-type-error x 'a (funcall #'car x)) t) diff --git a/ansi-tests/gcd.lsp b/ansi-tests/gcd.lsp index 9044d7c4..409b07c0 100644 --- a/ansi-tests/gcd.lsp +++ b/ansi-tests/gcd.lsp @@ -11,10 +11,7 @@ ;;; Error tests (deftest gcd.error.1 - (loop for x in *mini-universe* - unless (or (integerp x) - (eval `(signals-error (gcd ',x) type-error))) - collect x) + (check-type-error #'gcd #'integerp) nil) ;;; Non-error tests diff --git a/ansi-tests/gensym.lsp b/ansi-tests/gensym.lsp index 163349b3..9ab82fb8 100644 --- a/ansi-tests/gensym.lsp +++ b/ansi-tests/gensym.lsp @@ -99,28 +99,8 @@ ;;; argument defaults to "G", with NIL causing an error. (deftest gensym.error.1 - (signals-error (gensym 'aaa) type-error) - t) - -(deftest gensym.error.2 - (signals-error (gensym 12.3) type-error) - t) - -(deftest gensym.error.3 - (signals-error (gensym t) type-error) - t) - -(deftest gensym.error.4 - (signals-error (gensym nil) type-error) ;; NIL /= no argument! - t) - -(deftest gensym.error.5 - (signals-error (gensym '(a)) type-error) - t) - -(deftest gensym.error.6 - (signals-error (gensym #\x) type-error) - t) + (check-type-error #'gensym #'(lambda (x) (typep x '(or string unsigned-byte)))) + nil) (deftest gensym.error.7 (signals-error (gensym 10 'foo) program-error) diff --git a/ansi-tests/gentemp.lsp b/ansi-tests/gentemp.lsp index 15a29cc8..d288c0a8 100644 --- a/ansi-tests/gentemp.lsp +++ b/ansi-tests/gentemp.lsp @@ -109,7 +109,7 @@ (deftest gentemp.error.1 (loop for x in *mini-universe* unless (or (stringp x) - (eql (eval `(signals-error (gentemp ',x) type-error)) t)) + (eql (eval `(signals-type-error x ',x (gentemp x))) t)) collect x) nil) @@ -117,15 +117,10 @@ (loop for x in *mini-universe* unless (or (typep x 'package) (string-designator-p x) - (eql (eval `(signals-error (gentemp "T" ',x) type-error)) t)) + (eql (eval `(signals-type-error x ',x (gentemp "T" x))) t)) collect x) nil) (deftest gentemp.error.3 (signals-error (gentemp "" *package* nil) program-error) t) - - - - - \ No newline at end of file diff --git a/ansi-tests/get.lsp b/ansi-tests/get.lsp index 77aff2cd..04eb3c76 100644 --- a/ansi-tests/get.lsp +++ b/ansi-tests/get.lsp @@ -105,19 +105,9 @@ t) (deftest get.error.4 - (loop for x in *mini-universe* - for form = `(signals-error (get ',x :foo) type-error) - unless (or (symbolp x) (eval form)) - collect x) + (check-type-error #'(lambda (x) (get x :foo)) #'symbolp) nil) (deftest get.error.5 - (loop for x in *mini-universe* - for form = `(signals-error (setf (get ',x :foo) nil) type-error) - unless (or (symbolp x) (eval form)) - collect x) + (check-type-error #'(lambda (x) (setf (get x :foo) nil)) #'symbolp) nil) - - - - \ No newline at end of file diff --git a/ansi-tests/hash-table-rehash-size.lsp b/ansi-tests/hash-table-rehash-size.lsp index 463ccb39..b189b0b0 100644 --- a/ansi-tests/hash-table-rehash-size.lsp +++ b/ansi-tests/hash-table-rehash-size.lsp @@ -35,16 +35,5 @@ t) (deftest hash-table-rehash-size.error.3 - (loop for x in *mini-universe* - unless (hash-table-p x) - unless (eval `(signals-error (hash-table-rehash-size ',x) - type-error)) - collect x) + (check-type-error #'hash-table-rehash-size #'hash-table-p) nil) - - - - - - - diff --git a/ansi-tests/hash-table-rehash-threshold.lsp b/ansi-tests/hash-table-rehash-threshold.lsp index 83d819e5..4577e63a 100644 --- a/ansi-tests/hash-table-rehash-threshold.lsp +++ b/ansi-tests/hash-table-rehash-threshold.lsp @@ -35,9 +35,5 @@ t) (deftest hash-table-rehash-threshold.error.3 - (loop for x in *mini-universe* - unless (hash-table-p x) - unless (eval `(signals-error (hash-table-rehash-threshold ',x) - type-error)) - collect x) + (check-type-error #'hash-table-rehash-threshold #'hash-table-p) nil) diff --git a/ansi-tests/hash-table-size.lsp b/ansi-tests/hash-table-size.lsp index e7fe8838..e486eced 100644 --- a/ansi-tests/hash-table-size.lsp +++ b/ansi-tests/hash-table-size.lsp @@ -15,9 +15,5 @@ t) (deftest hash-table-size.error.3 - (loop for x in *mini-universe* - unless (hash-table-p x) - unless (eval `(signals-error (hash-table-size ',x) - type-error)) - collect x) + (check-type-error #'hash-table-size #'hash-table-p) nil) diff --git a/ansi-tests/hash-table-test.lsp b/ansi-tests/hash-table-test.lsp index 39fd5517..fea19a49 100644 --- a/ansi-tests/hash-table-test.lsp +++ b/ansi-tests/hash-table-test.lsp @@ -42,8 +42,5 @@ t) (deftest hash-table-test.error.3 - (loop for x in *mini-universe* - unless (hash-table-p x) - unless (eval `(signals-error (hash-table-test ',x) type-error)) - collect x) + (check-type-error #'hash-table-test #'hash-table-p) nil) diff --git a/ansi-tests/imagpart.lsp b/ansi-tests/imagpart.lsp index 2c04af32..b5fdcd13 100644 --- a/ansi-tests/imagpart.lsp +++ b/ansi-tests/imagpart.lsp @@ -14,10 +14,7 @@ t) (deftest imagpart.error.3 - (loop for x in *mini-universe* - unless (or (numberp x) - (eval `(signals-error (imagpart ',x) type-error))) - collect x) + (check-type-error #'imagpart #'numberp) nil) (deftest imagpart.1 diff --git a/ansi-tests/input-stream-p.lsp b/ansi-tests/input-stream-p.lsp index 75dbfae5..ca5f1d0a 100644 --- a/ansi-tests/input-stream-p.lsp +++ b/ansi-tests/input-stream-p.lsp @@ -36,9 +36,5 @@ t) (deftest input-stream-p.error.3 - (loop for x in *mini-universe* - unless (or (typep x 'stream) - (eval `(signals-error (input-stream-p ',x) - type-error))) - collect x) + (check-type-error #'input-stream-p #'streamp) nil) diff --git a/ansi-tests/integer-length.lsp b/ansi-tests/integer-length.lsp index 7d7d786b..27b8a2aa 100644 --- a/ansi-tests/integer-length.lsp +++ b/ansi-tests/integer-length.lsp @@ -18,11 +18,7 @@ t) (deftest integer-length.error.4 - (loop for x in *mini-universe* - unless (or (integerp x) - (eval `(signals-error (integer-length ',x) - type-error))) - collect x) + (check-type-error #'integer-length #'integerp) nil) (deftest integer-length.1 diff --git a/ansi-tests/interactive-stream-p.lsp b/ansi-tests/interactive-stream-p.lsp index f8b5f642..e29cb0f1 100644 --- a/ansi-tests/interactive-stream-p.lsp +++ b/ansi-tests/interactive-stream-p.lsp @@ -15,11 +15,7 @@ nil) (deftest interactive-stream-p.error.1 - (loop for x in *mini-universe* - unless (or (typep x 'stream) - (eval `(signals-error (interactive-stream-p ',x) - type-error))) - collect x) + (check-type-error #'interactive-stream-p #'streamp) nil) (deftest interactive-stream-p.error.2 diff --git a/ansi-tests/isqrt.lsp b/ansi-tests/isqrt.lsp index 1339e120..e1b7dcfb 100644 --- a/ansi-tests/isqrt.lsp +++ b/ansi-tests/isqrt.lsp @@ -28,7 +28,7 @@ (deftest isqrt.error.5 (loop for x in *mini-universe* unless (or (and (integerp x) (>= x 0)) - (eval `(signals-error (isqrt ',x) type-error))) + (eval `(signals-type-error x ',x (isqrt x)))) collect x) nil) diff --git a/ansi-tests/lcm.lsp b/ansi-tests/lcm.lsp index 3d4862da..b5a85b24 100644 --- a/ansi-tests/lcm.lsp +++ b/ansi-tests/lcm.lsp @@ -9,10 +9,7 @@ (compile-and-load "gcd-aux.lsp") (deftest lcm.error.1 - (loop for x in *mini-universe* - unless (or (integerp x) - (eval `(signals-error (lcm ',x) type-error))) - collect x) + (check-type-error #'lcm #'integerp) nil) (deftest lcm.1 diff --git a/ansi-tests/ldiff.lsp b/ansi-tests/ldiff.lsp index 6714f63e..d682b0f0 100644 --- a/ansi-tests/ldiff.lsp +++ b/ansi-tests/ldiff.lsp @@ -110,26 +110,25 @@ ;; Error checking (deftest ldiff.error.1 - (signals-error (ldiff 10 'a) type-error) + (signals-type-error x 10 (ldiff x 'a)) t) ;; Single atoms are not dotted lists, so the next ;; case should be a type-error (deftest ldiff.error.2 - (signals-error (ldiff 'a 'a) type-error) + (signals-type-error x 'a (ldiff x 'a)) t) (deftest ldiff.error.3 - (signals-error (ldiff (make-array '(10) :initial-element 'a) '(a)) - type-error) + (signals-type-error x (make-array '(10) :initial-element 'a) (ldiff x '(a))) t) (deftest ldiff.error.4 - (signals-error (ldiff 1.23 t) type-error) + (signals-type-error x 1.23 (ldiff x t)) t) (deftest ldiff.error.5 - (signals-error (ldiff #\w 'a) type-error) + (signals-type-error x #\w (ldiff x 'a)) t) (deftest ldiff.error.6 diff --git a/ansi-tests/length.lsp b/ansi-tests/length.lsp index 6b2045378b3b003d06baf8f1b03c6c0d2fe7086a..f9dcd7b57e46b817d86e5d0c57f4cf105a24eb2d 100644 GIT binary patch delta 76 zcmX@4ut#pgeGcp7jMU_8-IB_JRNd5~qWmHSW%ZoYy!4U`AVVW3F*hkCQ9+|ZQ$Yiy cq(GrULA^M&urxI<IaPD=0e<Pt)?Dmt04CEJ_y7O^ delta 114 zcmdlZcSvEweU8ZvoT8ix>WP{PC6xuKljAs57>y>|a7uD27#bjn8H2>Q6b$u{1x+A= X$}z~gO+kX(K;8Pr2>qL_IT_gi`wbnE diff --git a/ansi-tests/list-length.lsp b/ansi-tests/list-length.lsp index aba9f348..36031ea1 100644 --- a/ansi-tests/list-length.lsp +++ b/ansi-tests/list-length.lsp @@ -43,8 +43,7 @@ (loop for x in (list 'a 1 1.0 #\w (make-array '(10)) '(a b . c) (symbol-package 'cons)) - count (not (eqt (catch-type-error (list-length x)) - 'type-error))) + count (not (eval `(signals-type-error x ',x (list-length x))))) 0) (deftest list-length.error.2 diff --git a/ansi-tests/logandc1.lsp b/ansi-tests/logandc1.lsp index f53f7a88..8f124ec9 100644 --- a/ansi-tests/logandc1.lsp +++ b/ansi-tests/logandc1.lsp @@ -10,17 +10,11 @@ ;;; Error tests (deftest logandc1.error.1 - (loop for x in *mini-universe* - unless (or (integerp x) - (eval `(signals-error (logandc1 ',x 0) type-error))) - collect x) + (check-type-error #'(lambda (x) (logandc1 x 0)) #'integerp) nil) (deftest logandc1.error.2 - (loop for x in *mini-universe* - unless (or (integerp x) - (eval `(signals-error (logandc1 0 ',x) type-error))) - collect x) + (check-type-error #'(lambda (x) (logandc1 0 x)) #'integerp) nil) (deftest logandc1.error.3 -- GitLab