Commit d127e5e4 authored by pfdietz's avatar pfdietz
Browse files

Cleaned up some tests (indentation, T/true issues), and added tests for...

Cleaned up some tests (indentation, T/true issues), and added tests for EQUALP, IDENTITY, and EVERY.
parent 6de3cca4
......@@ -6,8 +6,8 @@
(in-package :cl-test)
(deftest complement.1
(funcall (cl::complement #'identity) nil)
t)
(not (funcall (cl::complement #'identity) nil))
nil)
(deftest complement.2
(funcall (cl::complement #'identity) t)
......
......@@ -177,10 +177,10 @@
;; For everything in *universe*, it is either an atom, or satisfies
;; consp, but not both
(deftest consp-xor-atom-universe
(not (not
(every #'(lambda (x) (or (and (consp x) (not (atom x)))
(and (not (consp x)) (atom x))))
*universe*)))
(notnot
(every #'(lambda (x) (or (and (consp x) (not (atom x)))
(and (not (consp x)) (atom x))))
*universe*))
t)
;; Everything in type cons satisfies consp, and vice versa
......@@ -190,171 +190,169 @@
;; Tests of car, cdr and compound forms
(deftest cons-23
(car '(a))
(car '(a))
a)
(deftest cons-24
(cdr '(a . b))
(cdr '(a . b))
b)
(deftest cons-25
(caar '((a)))
(caar '((a)))
a)
(deftest cons-26
(cdar '((a . b)))
(cdar '((a . b)))
b)
(deftest cons-27
(cadr '(a b))
(cadr '(a b))
b)
(deftest cons-28
(cddr '(a b . c))
(cddr '(a b . c))
c)
(deftest cons-29
(caaar '(((a))))
(caaar '(((a))))
a)
(deftest cons-30
(cdaar '(((a . b))))
(cdaar '(((a . b))))
b)
(deftest cons-31
(cadar (cons (cons 'a (cons 'b 'c)) 'd))
(cadar (cons (cons 'a (cons 'b 'c)) 'd))
b)
(deftest cons-32
(cddar (cons (cons 'a (cons 'b 'c)) 'd))
(cddar (cons (cons 'a (cons 'b 'c)) 'd))
c)
(deftest cons-33
(caadr (cons 'a (cons (cons 'b 'c) 'd)))
(caadr (cons 'a (cons (cons 'b 'c) 'd)))
b)
(deftest cons-34
(caddr (cons 'a (cons 'b (cons 'c 'd))))
(caddr (cons 'a (cons 'b (cons 'c 'd))))
c)
(deftest cons-36
(cdadr (cons 'a (cons (cons 'b 'c) 'd)))
(cdadr (cons 'a (cons (cons 'b 'c) 'd)))
c)
(deftest cons-37
(cdddr (cons 'a (cons 'b (cons 'c 'd))))
(cdddr (cons 'a (cons 'b (cons 'c 'd))))
d)
(defvar *cons-test-4*
(cons (cons (cons (cons 'a 'b)
(cons 'c 'd))
(cons (cons 'e 'f)
(cons 'g 'h)))
(cons (cons (cons 'i 'j)
(cons 'k 'l))
(cons (cons 'm 'n)
(cons 'o 'p)))))
(cons (cons (cons (cons 'a 'b)
(cons 'c 'd))
(cons (cons 'e 'f)
(cons 'g 'h)))
(cons (cons (cons 'i 'j)
(cons 'k 'l))
(cons (cons 'm 'n)
(cons 'o 'p)))))
(deftest cons-38
(caaaar *cons-test-4*)
(caaaar *cons-test-4*)
a)
(deftest cons-39
(cdaaar *cons-test-4*)
(cdaaar *cons-test-4*)
b)
(deftest cons-40
(cadaar *cons-test-4*)
(cadaar *cons-test-4*)
c)
(deftest cons-41
(cddaar *cons-test-4*)
(cddaar *cons-test-4*)
d)
(deftest cons-42
(caadar *cons-test-4*)
(caadar *cons-test-4*)
e)
(deftest cons-43
(cdadar *cons-test-4*)
(cdadar *cons-test-4*)
f)
(deftest cons-44
(caddar *cons-test-4*)
(caddar *cons-test-4*)
g)
(deftest cons-45
(cdddar *cons-test-4*)
(cdddar *cons-test-4*)
h)
;;;
(deftest cons-46
(caaadr *cons-test-4*)
(caaadr *cons-test-4*)
i)
(deftest cons-47
(cdaadr *cons-test-4*)
(cdaadr *cons-test-4*)
j)
(deftest cons-48
(cadadr *cons-test-4*)
(cadadr *cons-test-4*)
k)
(deftest cons-49
(cddadr *cons-test-4*)
(cddadr *cons-test-4*)
l)
(deftest cons-50
(caaddr *cons-test-4*)
(caaddr *cons-test-4*)
m)
(deftest cons-51
(cdaddr *cons-test-4*)
(cdaddr *cons-test-4*)
n)
(deftest cons-52
(cadddr *cons-test-4*)
(cadddr *cons-test-4*)
o)
(deftest cons-53
(cddddr *cons-test-4*)
(cddddr *cons-test-4*)
p)
;; Test rplaca, rplacd
(deftest rplaca-1
(let ((x (cons 'a 'b)))
(let ((y x))
(and (eqt (rplaca x 'c) y)
(eqt x y)
(eqt (car x) 'c)
(eqt (cdr x) 'b)
t)))
(let ((x (cons 'a 'b)))
(let ((y x))
(and (eqt (rplaca x 'c) y)
(eqt x y)
(eqt (car x) 'c)
(eqt (cdr x) 'b))))
t)
(deftest rplacd-1
(let ((x (cons 'a 'b)))
(let ((y x))
(and (eqt (rplacd x 'd) y)
(eqt x y)
(eqt (car x) 'a)
(eqt (cdr x) 'd)
t)))
(let ((x (cons 'a 'b)))
(let ((y x))
(and (eqt (rplacd x 'd) y)
(eqt x y)
(eqt (car x) 'a)
(eqt (cdr x) 'd))))
t)
;; rplaca on a fixnum is a type error
(deftest rplaca-error-1
(let ((x 12340131))
(catch-type-error (rplaca x 1)))
type-error)
(loop for x in *universe*
thereis (and (not (consp x))
(not (eq (catch-type-error (rplaca x 1)) 'type-error))))
nil)
;; rplacd on a fixnum is a type error
(deftest rplacd-error-1
(let ((x 12340132))
(catch-type-error (rplacd x 1)))
type-error)
;; To do: add tests for other invalid arguments
(loop for x in *universe*
thereis (and (not (consp x))
(not (eq (catch-type-error (rplacd x 1)) 'type-error))))
nil)
......@@ -23,7 +23,8 @@
y)
(every #'(lambda (e)
(and (member e x) (member e y)))
z)))
z)
t))
(defun shuffle (x)
(cond
......@@ -130,55 +131,49 @@
("aaa"))
(deftest intersection-10
(not (not
(equal
(sort
(intersection (loop
for i from 0 to 1000 by 3
collect i)
(loop
for i from 0 to 1000 by 7
collect i))
#'<)
(loop for i from 0 to 1000 by 21 collect i))))
(equalt
(sort
(intersection (loop
for i from 0 to 1000 by 3
collect i)
(loop
for i from 0 to 1000 by 7
collect i))
#'<)
(loop for i from 0 to 1000 by 21 collect i))
t)
(deftest intersection-11
(not (not
(equal
(sort
(intersection (loop
for i from 0 to 999 by 5
collect i)
(loop
for i from 0 to 999 by 7
collect i)
:test #'(lambda (a b)
(and (eql a b)
(= (mod a 3) 0))))
#'<)
(loop
for i from 0 to 999 by (* 3 5 7) collect i))))
(equalt
(sort
(intersection (loop
for i from 0 to 999 by 5
collect i)
(loop
for i from 0 to 999 by 7
collect i)
:test #'(lambda (a b)
(and (eql a b)
(= (mod a 3) 0))))
#'<)
(loop for i from 0 to 999 by (* 3 5 7) collect i))
t)
(deftest intersection-11-a
(not (not
(equal
(sort
(intersection (loop
for i from 0 to 999 by 5
collect i)
(loop
for i from 0 to 999 by 7
collect i)
:test-not
#'(lambda (a b)
(not (and (eql a b)
(= (mod a 3) 0)))))
#'<)
(loop
for i from 0 to 999 by (* 3 5 7)
collect i))))
(equalt
(sort
(intersection (loop
for i from 0 to 999 by 5
collect i)
(loop
for i from 0 to 999 by 7
collect i)
:test-not
#'(lambda (a b)
(not (and (eql a b)
(= (mod a 3) 0)))))
#'<)
(loop for i from 0 to 999 by (* 3 5 7) collect i))
t)
;;
......@@ -206,90 +201,88 @@
;;
(deftest intersection-13
(let ((x (copy-list '(0 5 8 13 31 42)))
(y (copy-list '(3 5 42 0 7 100 312 33))))
(not (not
(equal
(sort (copy-list (intersection x y)) #'<)
(sort (copy-list (intersection x y :key #'1+)) #'<)))))
(let ((x (copy-list '(0 5 8 13 31 42)))
(y (copy-list '(3 5 42 0 7 100 312 33))))
(equalt
(sort (copy-list (intersection x y)) #'<)
(sort (copy-list (intersection x y :key #'1+)) #'<)))
t)
;; Same as 13, but with a symbol function designator for :key
(deftest intersection-13-a
(let ((x (copy-list '(0 5 8 13 31 42)))
(y (copy-list '(3 5 42 0 7 100 312 33))))
(not (not
(equal
(sort (copy-list (intersection x y)) #'<)
(sort (copy-list (intersection x y :key '1+)) #'<)))))
(let ((x (copy-list '(0 5 8 13 31 42)))
(y (copy-list '(3 5 42 0 7 100 312 33))))
(equalt
(sort (copy-list (intersection x y)) #'<)
(sort (copy-list (intersection x y :key '1+)) #'<)))
t)
;; Test that a nil key argument is ignored
(deftest intersection-14
(handler-case
(let
((result (intersection (copy-list '(a b c d))
(copy-list '(e c f b g))
:key nil)))
(and
(member 'b result)
(member 'c result)
(every #'(lambda (x) (member x '(b c))) result)
t))
(error (c) c))
(handler-case
(let
((result (intersection (copy-list '(a b c d))
(copy-list '(e c f b g))
:key nil)))
(and
(member 'b result)
(member 'c result)
(every #'(lambda (x) (member x '(b c))) result)
t))
(error (c) c))
t)
;; Test that intersection preserves the order of arguments to :test, :test-not
(deftest intersection-15
(let ((list1 (list 1 2 3 4))
(list2 (list 4 5 6 7)))
(block fail
(intersection
list1 list2
:test
#'(lambda (x y)
(when (< y x) (return-from fail 'fail))
(eql x y)))))
(let ((list1 (list 1 2 3 4))
(list2 (list 4 5 6 7)))
(block fail
(intersection
list1 list2
:test
#'(lambda (x y)
(when (< y x) (return-from fail 'fail))
(eql x y)))))
(4))
(deftest intersection-16
(let ((list1 (list 1 2 3 4))
(list2 (list 4 5 6 7)))
(block fail
(intersection
list1 list2
:key #'identity
:test
#'(lambda (x y)
(when (< y x) (return-from fail 'fail))
(eql x y)))))
(let ((list1 (list 1 2 3 4))
(list2 (list 4 5 6 7)))
(block fail
(intersection
list1 list2
:key #'identity
:test
#'(lambda (x y)
(when (< y x) (return-from fail 'fail))
(eql x y)))))
(4))
(deftest intersection-17
(let ((list1 (list 1 2 3 4))
(list2 (list 4 5 6 7)))
(block fail
(intersection
list1 list2
:test-not
#'(lambda (x y)
(when (< y x) (return-from fail 'fail))
(not (eql x y))))))
(let ((list1 (list 1 2 3 4))
(list2 (list 4 5 6 7)))
(block fail
(intersection
list1 list2
:test-not
#'(lambda (x y)
(when (< y x) (return-from fail 'fail))
(not (eql x y))))))
(4))
(deftest intersection-18
(let ((list1 (list 1 2 3 4))
(list2 (list 4 5 6 7)))
(block fail
(intersection
list1 list2
:key #'identity
:test-not
#'(lambda (x y)
(when (< y x) (return-from fail 'fail))
(not (eql x y))))))
(let ((list1 (list 1 2 3 4))
(list2 (list 4 5 6 7)))
(block fail
(intersection
list1 list2
:key #'identity
:test-not
#'(lambda (x y)
(when (< y x) (return-from fail 'fail))
(not (eql x y))))))
(4))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......@@ -305,211 +298,204 @@
'failed))))
(deftest nintersection-1
(nintersection nil nil)
(nintersection nil nil)
nil)
(deftest nintersection-2
(nintersection (loop for i from 1 to 100 collect i) nil)
(nintersection (loop for i from 1 to 100 collect i) nil)
nil)
(deftest nintersection-3
(nintersection-with-check nil (loop for i from 1 to 100 collect i))
(nintersection-with-check nil (loop for i from 1 to 100 collect i))
nil)
(deftest nintersection-4
(let* ((x (copy-list '(a 1 c 7 b 4 3 z)))
(xc (copy-list x))
(y (copy-list '(3 y c q z a 18)))
(result (nintersection-with-check xc y)))
(and
(not (eqt result 'failed))
(+
(loop
for e in x count
(and (member e y)
(not (member e result))))
(loop
for e in result count
(or (not (member e x))
(not (member e y))))
(loop
for hd on result count
(and (consp hd)
(member (car hd) (cdr hd)))))))
(let* ((x (copy-list '(a 1 c 7 b 4 3 z)))
(xc (copy-list x))
(y (copy-list '(3 y c q z a 18)))
(result (nintersection-with-check xc y)))
(and
(not (eqt result 'failed))
(+
(loop for e in x count
(and (member e y)
(not (member e result))))
(loop for e in result count
(or (not (member e x)) (not (member e y))))
(loop for hd on result count
(and (consp hd)
(member (car hd) (cdr hd)))))))
0)
(deftest nintersection-5
(let* ((x (copy-list '(a a a)))
(y (copy-list '(a a a b b b)))
(result (nintersection-with-check x y)))
(and
(not (eqt result 'failed))
(member 'a result)
(not (member 'b result))))
(let* ((x (copy-list '(a a a)))
(y (copy-list '(a a a b b b)))
(result (nintersection-with-check x y)))
(and
(not (eqt result 'failed))
(member 'a result)
(not (member 'b result))))
t)
(deftest nintersection-6
(nintersection-with-check
(list 1000000000000 'a 'b 'c)
(list (1+ 999999999999) 'd 'e 'f))
(nintersection-with-check
(list 1000000000000 'a 'b 'c)
(list (1+ 999999999999) 'd 'e 'f))
(1000000000000))
(deftest nintersection-7
(nintersection-with-check (list 'a 10 'b 17)
(list 'c 'd 4 'e 'f 10 1 13 'z))
(nintersection-with-check (list 'a 10 'b 17)
(list 'c 'd 4 'e 'f 10 1 13 'z))
(10))
(deftest nintersection-8
(nintersection-with-check
(list 'a (copy-seq "aaa") 'b)
(list 'd (copy-seq "aaa") 'e))
(nintersection-with-check
(list 'a (copy-seq "aaa") 'b)
(list 'd (copy-seq "aaa") 'e))
nil)
(deftest nintersection-9
(nintersection-with-check
(list 'a (copy-seq "aaa") 'b)
(list 'd (copy-seq "aaa") 'e)
:test #'equal)
(nintersection-with-check
(list 'a (copy-seq "aaa") 'b)
(list 'd (copy-seq "aaa") 'e)
:test #'equal)
("aaa"))
(deftest nintersection-9-a
(nintersection-with-check
(list 'a (copy-seq "aaa") 'b)
(list 'd (copy-seq "aaa") 'e)
:test 'equal)
(nintersection-with-check
(list 'a (copy-seq "aaa") 'b)
(list 'd (copy-seq "aaa") 'e)
:test 'equal)
("aaa"))
(deftest nintersection-9-b
(nintersection
(list 'a (copy-seq "aaa") 'b)
(list 'd (copy-seq "aaa") 'e)
:test-not #'(lambda (p q) (not (equal p q))))
(nintersection
(list 'a (copy-seq "aaa") 'b)
(list 'd (copy-seq "aaa") 'e)
:test-not #'(lambda (p q) (not (equal p q))))
("aaa"))
(deftest nintersection-10
(not (not
(equal
(sort
(let ((result
(nintersection-with-check
(loop for i from 0 to 1000 by 3 collect i)
(loop for i from 0 to 1000 by 7 collect i))))
(if (eqt result 'failed) () result))
#'<)
(loop for i from 0 to 1000 by 21 collect i))))
(equalt
(sort