Commit 224082ac authored by pfdietz's avatar pfdietz

Updated many tests to use CLASSIFY-ERROR in place of HANDLER-BIND. This makes...

Updated many tests to use CLASSIFY-ERROR in place of HANDLER-BIND.  This makes the tests shorter and opens the possibility they can be compiled, since CLASSIFY-ERROR ensures error calls are safe calls.  Added more DO tests.
parent 994b8fc8
......@@ -11,9 +11,9 @@
(loop for f in '(char= char/= char< char> char<= char>=
char-lessp char-greaterp char-equal
char-not-lessp char-not-greaterp char-not-equal)
collect (handler-case (funcall f) (program-error () :caught)))
(:caught :caught :caught :caught :caught :caught
:caught :caught :caught :caught :caught :caught))
collect (classify-error (funcall f)))
(program-error program-error program-error program-error
program-error program-error program-error program-error))
(deftest char=.1
(is-ordered-by +code-chars+ #'(lambda (c1 c2) (not (char= c1 c2))))
......
......@@ -127,5 +127,5 @@
:caught)
(deftest concatenate-error.3
(catch-type-error (concatenate '(vector * 3) '(a b c d e)))
(classify-error (concatenate '(vector * 3) '(a b c d e)))
type-error)
......@@ -113,12 +113,10 @@
;; Check that a null key arg is ignored.
(deftest sublis-8
(handler-case
(check-sublis
'(1 2 a b)
'((1 . 2) (a . b))
:key nil)
(error (c) c))
(check-sublis
'(1 2 a b)
'((1 . 2) (a . b))
:key nil)
(2 2 b b))
;; nsublis
......@@ -187,12 +185,10 @@
;; Check that a null key arg is ignored.
(deftest nsublis-8
(handler-case
(check-nsublis
'(1 2 a b)
'((1 . 2) (a . b))
:key nil)
(error (c) c))
(check-nsublis
'(1 2 a b)
'((1 . 2) (a . b))
:key nil)
(2 2 b b))
(deftest sublis-shared
......@@ -275,11 +271,9 @@
((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo))))
(deftest subst-9
(handler-case
(check-subst 'a 'b
(copy-tree '(a b c d a b))
:key nil)
(error (c) c))
(check-subst 'a 'b
(copy-tree '(a b c d a b))
:key nil)
(a a c d a a))
......@@ -379,20 +373,16 @@
(40 40 40 40))
(deftest subst-if-6
(handler-case
(check-subst-if 'a #'(lambda (x) (eql x 'b))
'((a) (b) (c) (d))
:key nil)
(error (c) c))
((a) (a) (c) (d)))
(check-subst-if 'a #'(lambda (x) (eql x 'b))
'((a) (b) (c) (d))
:key nil)
((a) (a) (c) (d)))
(deftest subst-if-not-5
(handler-case
(check-subst-if-not 'a #'(lambda (x) (not (eql x 'b)))
'((a) (b) (c) (d))
:key nil)
(error (c) c))
((a) (a) (c) (d)))
(check-subst-if-not 'a #'(lambda (x) (not (eql x 'b)))
'((a) (b) (c) (d))
:key nil)
((a) (a) (c) (d)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Check nsubst
......@@ -458,11 +448,9 @@
((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo))))
(deftest nsubst-9
(handler-case
(check-nsubst 'a 'b
(check-nsubst 'a 'b
(copy-tree '(a b c d a b))
:key nil)
(error (c) c))
(a a c d a a))
......@@ -544,17 +532,13 @@
(40 40 40 40))
(deftest nsubst-if-6
(handler-case
(check-nsubst-if 'a #'(lambda (x) (eql x 'b))
(check-nsubst-if 'a #'(lambda (x) (eql x 'b))
'((a) (b) (c) (d))
:key nil)
(error (c) c))
((a) (a) (c) (d)))
((a) (a) (c) (d)))
(deftest nsubst-if-not-5
(handler-case
(check-nsubst-if-not 'a #'(lambda (x) (not (eql x 'b)))
(check-nsubst-if-not 'a #'(lambda (x) (not (eql x 'b)))
'((a) (b) (c) (d))
:key nil)
(error (c) c))
((a) (a) (c) (d)))
((a) (a) (c) (d)))
......@@ -161,23 +161,19 @@
;; Check that a NIL :key argument is the same as no key argument at all
(deftest pushnew-10
(handler-case
(let* ((x (list 'a 'b 'c 'd))
(result (pushnew 'z x :key nil)))
result)
(error (c) c))
(let* ((x (list 'a 'b 'c 'd))
(result (pushnew 'z x :key nil)))
result)
(z a b c d))
;; Check that a NIL :key argument is the same as no key argument at all
(deftest pushnew-11
(handler-case
(let* ((x (copy-tree '((a b) 1 "and" c d e)))
(y (pushnew (copy-tree '(a b)) x
:test 'equal :key nil)))
(and
(eqt x y)
x))
(error (c) c))
(let* ((x (copy-tree '((a b) 1 "and" c d e)))
(y (pushnew (copy-tree '(a b)) x
:test 'equal :key nil)))
(and
(eqt x y)
x))
((a b) 1 "and" c d e))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......@@ -197,9 +193,7 @@
;; Check that a NIL :key argument is the same as no key argument at all
(deftest adjoin-4
(handler-case
(adjoin 'a '(a) :key nil)
(error (c) c))
(adjoin 'a '(a) :key nil)
(a))
(deftest adjoin-5
......@@ -248,24 +242,18 @@
;; Test that a :key of NIL is the same as no key at all
(deftest adjoin-16
(handler-case
(adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a)
:test #'equal :key nil)
(error (c) c))
(aaa "AAA" "aaa" #\a))
(adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a)
:test #'equal :key nil)
(aaa "AAA" "aaa" #\a))
;; Test that a :key of NIL is the same as no key at all
(deftest adjoin-17
(handler-case
(adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a)
:test 'equal :key nil)
(error (c) c))
(aaa "AAA" "aaa" #\a))
(adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a)
:test 'equal :key nil)
(aaa "AAA" "aaa" #\a))
;; Test that a :key of NIL is the same as no key at all
(deftest adjoin-18
(handler-case
(adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a)
:test-not (complement #'equal) :key nil)
(error (c) c))
(aaa "AAA" "aaa" #\a))
(adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a)
:test-not (complement #'equal) :key nil)
(aaa "AAA" "aaa" #\a))
......@@ -138,13 +138,11 @@
0)
(deftest nth-2
(handler-case
(let ((x (loop for i from 1 to 2000 collect i)))
(loop
for i from 0 to 1999 do
(setf (nth i x) (- 1999 i)))
(equal x (loop for i from 1999 downto 0 collect i)))
(error (c) c))
(let ((x (loop for i from 1 to 2000 collect i)))
(loop
for i from 0 to 1999 do
(setf (nth i x) (- 1999 i)))
(equalt x (loop for i from 1999 downto 0 collect i)))
t)
;;; Test side effects, evaluation order in assignment to NTH
......
......@@ -19,18 +19,16 @@
(a b c))
(deftest ldiff-2
(handler-case
(let* ((x (copy-tree '(a b c d e f)))
(xcopy (make-scaffold-copy x)))
(let ((result (ldiff x 'a)))
(and
(check-scaffold-copy x xcopy)
(zerop
(loop
for a on x and b on result count
(eqt a b)))
result)))
(error (c) c))
(let* ((x (copy-tree '(a b c d e f)))
(xcopy (make-scaffold-copy x)))
(let ((result (ldiff x 'a)))
(and
(check-scaffold-copy x xcopy)
(zerop
(loop
for a on x and b on result count
(eqt a b)))
result)))
(a b c d e f))
;; Works when the end of the dotted list is a symbol
......
......@@ -164,14 +164,9 @@
;; Check that a null key argument is ignored
(deftest member-25
(handler-case
(member 'a '(c d a b e) :key nil)
(error (c) c))
(member 'a '(c d a b e) :key nil)
(a b e))
(deftest member-26
(handler-case
(member 'z '(a b c d) :key nil)
(error (c) c))
(member 'z '(a b c d) :key nil)
nil)
......@@ -65,11 +65,8 @@
(h g f e d c b a))
(deftest mapc-7
(handler-case
(mapc (gensym) '(a b c))
(error () 'error))
error)
(classify-error (mapc #'identity 1))
type-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mapcar
......@@ -135,10 +132,8 @@
((h g f e d c b a) (a b c d e f g h)))
(deftest mapcar-7
(handler-case
(mapcar (gensym) '(a b c))
(error () 'error))
error)
(classify-error (mapcar #'identity 1))
type-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mapcan
......@@ -207,174 +202,158 @@
nil)
(deftest mapcan-10
(handler-case
(mapcan (gensym) (copy-list '(a b c)))
(error () 'error))
error)
(deftest mapcan-11
(handler-case
(mapcan 1 (copy-list '(a b c)))
(error () 'error))
error)
(deftest mapcan-12
(handler-case
(mapcan 1.234 (copy-list '(a b c)))
(error () 'error))
error)
(deftest mapcan-13
(handler-case
(mapcan "foo" (copy-list '(a b c)))
(error () 'error))
error)
(classify-error (mapcan #'identity 1))
type-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mapl
(deftest mapl-1
(mapl #'list nil)
(mapl #'list nil)
nil)
(deftest mapl-2
(let* ((a nil)
(x (copy-list '(a b c)))
(xcopy (make-scaffold-copy x))
(result
(mapl #'(lambda (y) (push y a))
x)))
(and
(check-scaffold-copy x xcopy)
(eqt result x)
a))
((c) (b c) (a b c)))
(let* ((a nil)
(x (copy-list '(a b c)))
(xcopy (make-scaffold-copy x))
(result
(mapl #'(lambda (y) (push y a))
x)))
(and
(check-scaffold-copy x xcopy)
(eqt result x)
a))
((c) (b c) (a b c)))
(deftest mapl-3
(let* ((a nil)
(x (copy-list '(a b c d)))
(y (copy-list '(1 2 3 4)))
(xcopy (make-scaffold-copy x))
(ycopy (make-scaffold-copy y))
(result
(mapl #'(lambda (xtail ytail)
(setf a
(append (mapcar #'list xtail ytail)
a)))
x y)))
(and
(eqt result x)
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
a))
(let* ((a nil)
(x (copy-list '(a b c d)))
(y (copy-list '(1 2 3 4)))
(xcopy (make-scaffold-copy x))
(ycopy (make-scaffold-copy y))
(result
(mapl #'(lambda (xtail ytail)
(setf a
(append (mapcar #'list xtail ytail)
a)))
x y)))
(and
(eqt result x)
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
a))
((d 4) (c 3) (d 4) (b 2) (c 3) (d 4)
(a 1) (b 2) (c 3) (d 4)))
(a 1) (b 2) (c 3) (d 4)))
(deftest mapl-4
(let* ((a nil)
(x (copy-list '(a b c d)))
(y (copy-list '(1 2 3 4 5 6 7 8)))
(xcopy (make-scaffold-copy x))
(ycopy (make-scaffold-copy y))
(result
(mapl #'(lambda (xtail ytail)
(setf a
(append (mapcar #'list xtail ytail)
a)))
x y)))
(and
(eqt result x)
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
a))
(let* ((a nil)
(x (copy-list '(a b c d)))
(y (copy-list '(1 2 3 4 5 6 7 8)))
(xcopy (make-scaffold-copy x))
(ycopy (make-scaffold-copy y))
(result
(mapl #'(lambda (xtail ytail)
(setf a
(append (mapcar #'list xtail ytail)
a)))
x y)))
(and
(eqt result x)
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
a))
((d 4) (c 3) (d 4) (b 2) (c 3) (d 4)
(a 1) (b 2) (c 3) (d 4)))
(a 1) (b 2) (c 3) (d 4)))
(deftest mapl-5
(let* ((a nil)
(x (copy-list '(a b c d e f g)))
(y (copy-list '(1 2 3 4)))
(xcopy (make-scaffold-copy x))
(ycopy (make-scaffold-copy y))
(result
(mapl #'(lambda (xtail ytail)
(setf a
(append (mapcar #'list xtail ytail)
a)))
x y)))
(and
(eqt result x)
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
a))
(let* ((a nil)
(x (copy-list '(a b c d e f g)))
(y (copy-list '(1 2 3 4)))
(xcopy (make-scaffold-copy x))
(ycopy (make-scaffold-copy y))
(result
(mapl #'(lambda (xtail ytail)
(setf a
(append (mapcar #'list xtail ytail)
a)))
x y)))
(and
(eqt result x)
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
a))
((d 4) (c 3) (d 4) (b 2) (c 3) (d 4)
(a 1) (b 2) (c 3) (d 4)))
(a 1) (b 2) (c 3) (d 4)))
(deftest mapl-6
(classify-error (mapl #'identity 1))
type-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; maplist
(deftest maplist-1
(maplist #'list nil)
(maplist #'list nil)
nil)
(deftest maplist-2
(let* ((x (copy-list '(a b c)))
(xcopy (make-scaffold-copy x))
(result (maplist #'identity x)))
(and (check-scaffold-copy x xcopy)
result))
(let* ((x (copy-list '(a b c)))
(xcopy (make-scaffold-copy x))
(result (maplist #'identity x)))
(and (check-scaffold-copy x xcopy)
result))
((a b c) (b c) (c)))
(deftest maplist-3
(let* ((x (copy-list '(a b c d)))
(y (copy-list '(1 2 3 4)))
(xcopy (make-scaffold-copy x))
(ycopy (make-scaffold-copy y))
(result
(maplist #'append x y)))
(and
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
result))
(let* ((x (copy-list '(a b c d)))
(y (copy-list '(1 2 3 4)))
(xcopy (make-scaffold-copy x))
(ycopy (make-scaffold-copy y))
(result
(maplist #'append x y)))
(and
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
result))
((a b c d 1 2 3 4)
(b c d 2 3 4)
(c d 3 4)
(d 4)))
(deftest maplist-4
(let* ((x (copy-list '(a b c d)))
(y (copy-list '(1 2 3 4 5)))
(xcopy (make-scaffold-copy x))
(ycopy (make-scaffold-copy y))
(result
(maplist #'append x y)))
(and
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
result))
(let* ((x (copy-list '(a b c d)))
(y (copy-list '(1 2 3 4 5)))
(xcopy (make-scaffold-copy x))
(ycopy (make-scaffold-copy y))
(result
(maplist #'append x y)))
(and
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
result))
((a b c d 1 2 3 4 5)
(b c d 2 3 4 5)
(c d 3 4 5)
(d 4 5)))
(deftest maplist-5
(let* ((x (copy-list '(a b c d e)))
(y (copy-list '(1 2 3 4)))
(xcopy (make-scaffold-copy x))
(ycopy (make-scaffold-copy y))
(result
(maplist #'append x y)))
(and
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
result))
(let* ((x (copy-list '(a b c d e)))
(y (copy-list '(1 2 3 4)))
(xcopy (make-scaffold-copy x))
(ycopy (make-scaffold-copy y))
(result
(maplist #'append x y)))
(and
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
result))
((a b c d e 1 2 3 4)
(b c d e 2 3 4)
(c d e 3 4)
(d e 4)))
(deftest maplist-6
(maplist 'append '(a b c) '(1 2 3))
(maplist 'append '(a b c) '(1 2 3))
((a b c 1 2 3) (b c 2 3) (c 3)))
(deftest maplist-7
......@@ -385,57 +364,54 @@
(a c c e e g g))
(deftest maplist-8
(handler-case
(maplist #'identity 'a)
(error () 'error))
error)
(classify-error (maplist #'identity 'a))
type-error)
(deftest maplist-9
(handler-case
(maplist #'identity 1)
(error () 'error))
error)
(classify-error (maplist #'identity 1))
type-error)
(deftest maplist-10
(handler-case
(maplist #'identity 1.1323)
(error () 'error))
error)
(classify-error (maplist #'identity 1.1323))
type-error)
(deftest maplist-11
(handler-case
(maplist #'identity "abcde")
(error () 'error))
error)
(classify-error (maplist #'identity "abcde"))
type-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mapcan
(deftest mapcon-1
(mapcon #'(lambda (x) (append '(a) x nil)) nil)
(mapcon #'(lambda (x) (append '(a) x nil)) nil)
nil)
(deftest mapcon-2
(let* ((x (copy-list '(1 2 3 4)))
(xcopy (make-scaffold-copy x))
(result
(mapcon #'(lambda (y) (append '(a) y nil)) x)))
(and
(check-scaffold-copy x xcopy)
result))
(let* ((x (copy-list '(1 2 3 4)))
(xcopy (make-scaffold-copy x))
(result
(mapcon #'(lambda (y) (append '(a) y nil)) x)))
(and
(check-scaffold-copy x xcopy)
result))
(a 1 2 3 4 a 2 3 4 a 3 4 a 4))
(deftest mapcon-3
(let* ((x (copy-list '(4 2 3 2 2)))
(y (copy-list '(a b c d e f g h i j k l)))
(xcopy (make-scaffold-copy x))
(ycopy (make-scaffold-copy y))
(result
(mapcon #'(lambda (xt yt)
(subseq yt 0 (car xt)))
x y)))
(and
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
result))
(let* ((x (copy-list '(4 2 3 2 2)))
(y (copy-list '(a b c d e f g h i j k l)))
(xcopy (make-scaffold-copy x))
(ycopy (make-scaffold-copy y))
(result
(mapcon #'(lambda (xt yt)
(subseq yt 0 (car xt)))
x y)))
(and
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
result))
(a b c d b c c d e d e e f))
(deftest mapcon-4
(classify-error (mapcon #'identity 1))
type-error)
......@@ -192,15 +192,13 @@
(6 . c))
(deftest assoc-if-2
(handler-case
(let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d))))
(xcopy (make-scaffold-copy x))
(result (assoc-if #'oddp x :key #'1+)))
(and
(check-scaffold-copy x xcopy)
(eqt result (third x))
result))
(program-error (c) c))
(let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d))))
(xcopy (make-scaffold-copy x))
(result (assoc-if #'oddp x :key #'1+)))
(and
(check-scaffold-copy x xcopy)
(eqt result (third x))
result))
(6 . c))
(deftest assoc-if-3
......@@ -231,15 +229,13 @@
(6 . c))
(deftest assoc-if-not-2
(handler-case
(let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d))))
(xcopy (make-scaffold-copy x))
(result (assoc-if-not #'evenp x :key #'1+)))
(and
(check-scaffold-copy x xcopy)
(eqt result (third x))
result))
(program-error (c) c))
(let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d))))
(xcopy (make-scaffold-copy x))
(result (assoc-if-not #'evenp x :key #'1+)))
(and
(check-scaffold-copy x xcopy)
(eqt result (third x))
result))
(6 . c))
(deftest assoc-if-not-3
......
......@@ -205,15 +205,13 @@
(c . 6))
(deftest rassoc-if-2
(handler-case
(let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d))))
(xcopy (make-scaffold-copy x))
(result (rassoc-if #'oddp x :key #'1+)))
(and
(check-scaffold-copy x xcopy)
(eqt result (third x))
result))
(program-error (c) c))
(let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d))))
(xcopy (make-scaffold-copy x))
(result (rassoc-if #'oddp x :key #'1+)))
(and
(check-scaffold-copy x xcopy)
(eqt result (third x))
result))
(c . 6))
(deftest rassoc-if-3
......@@ -245,15 +243,13 @@
(c . 6))
(deftest rassoc-if-not-2
(handler-case
(let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d))))
(xcopy (make-scaffold-copy x))
(result (rassoc-if-not #'evenp x :key #'1+)))
(and
(check-scaffold-copy x xcopy)
(eqt result (third x))
result))
(program-error (c) c))
(let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d))))
(xcopy (make-scaffold-copy x))
(result (rassoc-if-not #'evenp x :key #'1+)))
(and
(check-scaffold-copy x xcopy)
(eqt result (third x))
result))
(c . 6))
(deftest rassoc-if-not-3
......
......@@ -220,17 +220,15 @@
;; Test that a nil key argument is ignored
(deftest intersection-14
(handler-case