Skip to content
Snippets Groups Projects
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
No related branches found
No related tags found
No related merge requests found
......@@ -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
(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))
t)
(deftest nintersection-11
(not (not
(equal
(sort
(let ((result
(nintersection-with-check
(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))))))
(if (eqt result 'failed) () result))
#'<)
(loop
for i from 0 to 999 by (* 3 5 7) collect i))))
(equalt
(sort
(let ((result
(nintersection-with-check
(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))))))
(if (eqt result 'failed) () result))
#'<)
(loop
for i from 0 to 999 by (* 3 5 7) collect i))
t)
(deftest nintersection-12
(nintersection-12-body 100 100)
(nintersection-12-body 100 100)
nil)
(defun nintersection-12-body (size niters &optional (maxelem (* 2 size)))
(let ((state (make-random-state t)))
(loop
for i from 1 to niters do
(let ((x (shuffle (loop for j from 1 to size collect (random maxelem state))))
(y (shuffle (loop for j from 1 to size collect (random maxelem state)))))
(let ((z (nintersection-with-check (copy-list x) y)))
(when (eqt z 'failed) (return (values x y z)))
(let ((is-good (is-intersection x y z)))
(unless is-good (return (values x y z)))))))
nil))
(loop
for i from 1 to niters do
(let ((x (shuffle (loop for j from 1 to size collect (random maxelem state))))
(y (shuffle (loop for j from 1 to size collect (random maxelem state)))))
(let ((z (nintersection-with-check (copy-list x) y)))
(when (eqt z 'failed) (return (values x y z)))
(let ((is-good (is-intersection x y z)))
(unless is-good (return (values x y z)))))))
nil))
;; Key argument
(deftest nintersection-13
(let ((x '(0 5 8 13 31 42))
(y (copy-list '(3 5 42 0 7 100 312 33))))
(not (not
(equal
(sort (copy-list (nintersection
(copy-list x) y)) #'<)
(sort (copy-list (nintersection
(copy-list x) y :key #'1+)) #'<)))))
(let ((x '(0 5 8 13 31 42))
(y (copy-list '(3 5 42 0 7 100 312 33))))
(equalt
(sort (copy-list (nintersection
(copy-list x) y)) #'<)
(sort (copy-list (nintersection
(copy-list x) y :key #'1+)) #'<)))
t)
;; Check that a nil key argument is ignored
(deftest nintersection-14
(handler-case
(let
((result (nintersection
(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 (nintersection
(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 nintersection preserves the order of arguments to :test, :test-not
(deftest nintersection-15
(let ((list1 (list 1 2 3 4))
(list2 (list 4 5 6 7)))
(block fail
(nintersection
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
(nintersection
list1 list2
:test
#'(lambda (x y)
(when (< y x) (return-from fail 'fail))
(eql x y)))))
(4))
(deftest nintersection-16
(let ((list1 (list 1 2 3 4))
(list2 (list 4 5 6 7)))
(block fail
(nintersection
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
(nintersection
list1 list2
:key #'identity
:test
#'(lambda (x y)
(when (< y x) (return-from fail 'fail))
(eql x y)))))
(4))
(deftest nintersection-17
(let ((list1 (list 1 2 3 4))
(list2 (list 4 5 6 7)))
(block fail
(nintersection
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
(nintersection
list1 list2
:test-not
#'(lambda (x y)
(when (< y x) (return-from fail 'fail))
(not (eql x y))))))
(4))
(deftest nintersection-18
(let ((list1 (list 1 2 3 4))
(list2 (list 4 5 6 7)))
(block fail
(nintersection
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
(nintersection
list1 list2
:key #'identity
:test-not
#'(lambda (x y)
(when (< y x) (return-from fail 'fail))
(not (eql x y))))))
(4))
......@@ -211,7 +211,8 @@
(every #'(lambda (e) (member e x :key key :test test)) z)
(every #'(lambda (e) (or (member e y :key key :test test)
(member e z :key key :test test))) x)
(every #'(lambda (e) (not (member e z :key key :test test))) y)))
(every #'(lambda (e) (not (member e z :key key :test test))) y)
t))
(deftest nset-difference-1
(nset-difference nil nil)
......@@ -323,45 +324,45 @@
(1 2 3 4))
(deftest nset-difference-17
(block fail
(sort
(copy-list
(nset-difference-with-check
'(1 2 3 4) '(e f g h)
:key #'identity
:test #'(lambda (x y)
(when (or (member x '(e f g h))
(member y '(1 2 3 4)))
(return-from fail 'fail))
(eqt x y))))
#'<))
(block fail
(sort
(copy-list
(nset-difference-with-check
'(1 2 3 4) '(e f g h)
:key #'identity
:test #'(lambda (x y)
(when (or (member x '(e f g h))
(member y '(1 2 3 4)))
(return-from fail 'fail))
(eqt x y))))
#'<))
(1 2 3 4))
(deftest nset-difference-18
(block fail
(sort
(copy-list
(nset-difference-with-check
'(1 2 3 4) '(e f g h)
:test-not
#'(lambda (x y)
(when (or (member x '(e f g h))
(member y '(1 2 3 4)))
(return-from fail 'fail))
(not (eqt x y)))))
#'<))
(block fail
(sort
(copy-list
(nset-difference-with-check
'(1 2 3 4) '(e f g h)
:test-not
#'(lambda (x y)
(when (or (member x '(e f g h))
(member y '(1 2 3 4)))
(return-from fail 'fail))
(not (eqt x y)))))
#'<))
(1 2 3 4))
(deftest nset-difference-19
(block fail
(sort (copy-list
(nset-difference-with-check
'(1 2 3 4) '(e f g h)
:test-not
#'(lambda (x y)
(when (or (member x '(e f g h))
(member y '(1 2 3 4)))
(return-from fail 'fail))
(not (eqt x y)))))
#'<))
(block fail
(sort (copy-list
(nset-difference-with-check
'(1 2 3 4) '(e f g h)
:test-not
#'(lambda (x y)
(when (or (member x '(e f g h))
(member y '(1 2 3 4)))
(return-from fail 'fail))
(not (eqt x y)))))
#'<))
(1 2 3 4))
......@@ -24,11 +24,11 @@
(deftest elt-5a (safe-elt '(a b c d e) -4) type-error)
(deftest elt-6
(let ((x (make-int-list 1000)))
(not (not
(every
#'(lambda (i)
(eql i (safe-elt x i)))
x))))
(notnot
(every
#'(lambda (i)
(eql i (safe-elt x i)))
x)))
t)
(deftest elt-7
......@@ -61,11 +61,10 @@
(let ((x (list 'a 'b 'c 'd 'e)))
(let ((y (loop for c on x collect c)))
(setf (elt x 2) 'f)
(not
(not
(every #'eq
y
(loop for c on x collect c))))))
(notnot
(every #'eq
y
(loop for c on x collect c)))))
t)
(deftest elt-12
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Thu Oct 17 22:14:42 2002
;;;; Contains: Tests for EQUALP
(in-package :cl-test)
(deftest equalp.1
(loop for c across +base-chars+
always (loop for d across +base-chars+
always (if (char-equal c d) (equalpt c d)
(not (equalpt c d)))))
t)
(deftest equalp.2
(loop for i from 1 to 100
always (loop for j from 1 to 100
always (if (eqlt i j) (equalpt i j)
(not (equalpt i j)))))
t)
(deftest equalp.3
(equalpt "abc" "ABC")
t)
(deftest equalp.4
(equalpt "abc" "abd")
nil)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Thu Oct 17 23:25:58 2002
;;;; Contains: Tests of EVERY
(in-package :cl-test)
(deftest every.1
(not (every #'identity nil))
nil)
(deftest every.2
(not (every #'identity #()))
nil)
(deftest every.3
(let ((count 0))
(values
(every #'(lambda (x) (incf count) (< x 10))
'(1 2 4 13 5 1))
count))
nil 4)
(deftest every.4
(not (every #'= '(1 2 3 4) '(1 2 3 4 5)))
nil)
(deftest every.5
(not (every #'= '(1 2 3 4 5) '(1 2 3 4)))
nil)
(deftest every.6
(every #'= '(1 2 3 4 5) '(1 2 3 4 6))
nil)
(deftest every.7
(not (every #'(lambda (x y) (or x y))
'(nil t t nil t) #(t nil t t nil nil)))
nil)
(deftest every.8
(let ((x '(1))
(args nil))
(not
(loop for i from 1 below (1- (min 100 call-arguments-limit))
do (push x args)
always (apply #'every #'= args))))
nil)
(deftest every.9
(not (every #'zerop #*000000000000))
nil)
(deftest every.10
(not (every #'zerop #*))
nil)
(deftest every.11
(every #'zerop #*0000010000)
nil)
(deftest every.12
(not (every #'(lambda (x) (eql x #\a)) "aaaaaaaa"))
nil)
(deftest every.13
(not (every #'(lambda (x) (eql x #\a)) ""))
nil)
(deftest every.14
(every #'(lambda (x) (eql x #\a)) "aaaaaabaaaa")
nil)
......@@ -20,13 +20,16 @@
(load "defvar.lsp")
(load "destructuring-bind.lsp")
(load "equal.lsp")
(load "equalp.lsp")
(load "eql.lsp")
(load "every.lsp")
(load "fboundp.lsp")
(load "flet.lsp")
(load "fmakunbound.lsp")
(load "funcall.lsp")
(load "function.lsp")
(load "functionp.lsp")
(load "identity.lsp")
(load "labels.lsp")
(load "lambda-list-keywords.lsp")
(load "lambda-parameters-limit.lsp")
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Thu Oct 17 23:21:11 2002
;;;; Contains: Tests for IDENTITY
(in-package :cl-test)
(deftest identity.1
(loop for x in *universe*
always (eqlt x (identity x)))
t)
(deftest identity.2
(let ((x (ash 1 100)))
(eqlt x (identity x)))
t)
(deftest identity.3
(let ((x 1.00000001))
(eqlt x (identity x)))
t)
......@@ -29,7 +29,7 @@
;; The list returned has only packages in it
(deftest list-all-packages-3
(not (not (every #'packagep (list-all-packages))))
(notnot (every #'packagep (list-all-packages)))
t)
;; It returns a list of the same packages each time it is called
......@@ -155,10 +155,11 @@
t)
(deftest package-nicknames-8
(ignore-errors
(subsetp '("CL-USER")
(package-nicknames "COMMON-LISP-USER")
:test #'string=))
(ignore-errors
(notnot
(subsetp '("CL-USER")
(package-nicknames "COMMON-LISP-USER")
:test #'string=)))
t)
(deftest package-nicknames-9
......
......@@ -10,31 +10,31 @@
;;; intern
(deftest intern-1
(let ((p (make-package "TEMP1")))
(multiple-value-bind (sym1 status1)
(let ((p (make-package "TEMP1")))
(multiple-value-bind (sym1 status1)
(find-symbol "FOO" p)
(intern "FOO" p)
(multiple-value-bind (sym2 status2)
(find-symbol "FOO" p)
(intern "FOO" p)
(multiple-value-bind (sym2 status2)
(find-symbol "FOO" p)
(and (null sym1)
(null status1)
(string= (symbol-name sym2) "FOO")
(eqt (symbol-package sym2) p)
(eqt status2 :internal)
(progn (delete-package p) t)))))
(and (null sym1)
(null status1)
(string= (symbol-name sym2) "FOO")
(eqt (symbol-package sym2) p)
(eqt status2 :internal)
(progn (delete-package p) t)))))
t)
(deftest intern-2
(let ((p (make-package "TEMP1")))
(multiple-value-bind (sym1 status1)
(find-symbol "FOO" "TEMP1")
(intern "FOO" "TEMP1")
(multiple-value-bind (sym2 status2)
(find-symbol "FOO" p)
(and (null sym1)
(null status1)
(string= (symbol-name sym2) "FOO")
(eqt (symbol-package sym2) p)
(eqt status2 :internal)
(progn (delete-package p) t)))))
(let ((p (make-package "TEMP1")))
(multiple-value-bind (sym1 status1)
(find-symbol "FOO" "TEMP1")
(intern "FOO" "TEMP1")
(multiple-value-bind (sym2 status2)
(find-symbol "FOO" p)
(and (null sym1)
(null status1)
(string= (symbol-name sym2) "FOO")
(eqt (symbol-package sym2) p)
(eqt status2 :internal)
(progn (delete-package p) t)))))
t)
......@@ -10,48 +10,48 @@
;;; export
(deftest export-1
(let ((return-value nil))
(ignore-errors (delete-package "TEST1"))
(let ((p (make-package "TEST1")))
(let ((sym (intern "FOO" p)))
(setf return-value (export sym p))
(multiple-value-bind (sym2 status)
(find-symbol "FOO" p)
(prog1
(and sym2
(eqt (symbol-package sym2) p)
(string= (symbol-name sym2) "FOO")
(eqt sym sym2)
(eqt status :external))
(delete-package p)))))
return-value)
(let ((return-value nil))
(ignore-errors (delete-package "TEST1"))
(let ((p (make-package "TEST1")))
(let ((sym (intern "FOO" p)))
(setf return-value (export sym p))
(multiple-value-bind (sym2 status)
(find-symbol "FOO" p)
(prog1
(and sym2
(eqt (symbol-package sym2) p)
(string= (symbol-name sym2) "FOO")
(eqt sym sym2)
(eqt status :external))
(delete-package p)))))
return-value)
t)
(deftest export-2
(progn (ignore-errors (delete-package "TEST1"))
(let ((p (make-package "TEST1")))
(let ((sym (intern "FOO" p)))
(export (list sym) p)
(multiple-value-bind (sym2 status)
(find-symbol "FOO" p)
(prog1
(and sym2
(eqt (symbol-package sym2) p)
(string= (symbol-name sym2) "FOO")
(eqt sym sym2)
(eqt status :external))
(delete-package p))))))
(progn (ignore-errors (delete-package "TEST1"))
(let ((p (make-package "TEST1")))
(let ((sym (intern "FOO" p)))
(export (list sym) p)
(multiple-value-bind (sym2 status)
(find-symbol "FOO" p)
(prog1
(and sym2
(eqt (symbol-package sym2) p)
(string= (symbol-name sym2) "FOO")
(eqt sym sym2)
(eqt status :external))
(delete-package p))))))
t)
(deftest export-3
(handler-case
(progn
(make-package "F")
(let ((sym (intern "FOO" "F")))
(export sym #\F)
(delete-package "F")
t))
(error (c) (delete-package "F") c))
(handler-case
(progn
(make-package "F")
(let ((sym (intern "FOO" "F")))
(export sym #\F)
(delete-package "F")
t))
(error (c) (delete-package "F") c))
t)
;;
......@@ -60,10 +60,10 @@
;; user whether the symbol should be imported.
;;
(deftest export-4
(handler-case
(export 'b::bar "A")
(package-error () 'package-error)
(error (c) c))
(handler-case
(export 'b::bar "A")
(package-error () 'package-error)
(error (c) c))
package-error)
;;
......@@ -72,19 +72,19 @@
;; is exporting a symbol with the same name.
;;
(deftest export-5
(progn
(make-package "TEST1")
(make-package "TEST2" :use '("TEST1"))
(export (intern "X" "TEST2") "TEST2")
(prog1
(handler-case
(let ((sym (intern "X" "TEST1")))
(handler-case
(export sym "TEST1")
(error (c)
(format t "Caught error in EXPORT-5: ~A~%" c)
'caught)))
(error (c) c))
(delete-package "TEST2")
(delete-package "TEST1")))
(progn
(make-package "TEST1")
(make-package "TEST2" :use '("TEST1"))
(export (intern "X" "TEST2") "TEST2")
(prog1
(handler-case
(let ((sym (intern "X" "TEST1")))
(handler-case
(export sym "TEST1")
(error (c)
(format t "Caught error in EXPORT-5: ~A~%" c)
'caught)))
(error (c) c))
(delete-package "TEST2")
(delete-package "TEST1")))
caught)
......@@ -19,17 +19,17 @@
(deftest string.4
(let ((s (string #\a)))
(values (stringp s) s))
(values (notnot (stringp s)) s))
t "a")
(deftest string.5
(let ((s (string "")))
(values (stringp s) s))
(values (notnot (stringp s)) s))
t "")
(deftest string.6
(let ((s (string '|FOO|)))
(values (stringp s) s))
(values (notnot (stringp s)) s))
t "FOO")
(deftest string.7
......@@ -122,7 +122,7 @@
t)
(deftest simple-string-p.2
(not (not (simple-string-p "ancd")))
(notnot (simple-string-p "ancd"))
t)
(deftest simple-string-p.3
......@@ -136,15 +136,15 @@
nil)
(deftest simple-string-p.5
(not (not (simple-string-p (make-array
4 :element-type 'base-char
:initial-contents '(#\a #\a #\a #\b)))))
(notnot (simple-string-p (make-array
4 :element-type 'base-char
:initial-contents '(#\a #\a #\a #\b))))
t)
(deftest simple-string-p.6
(not (not (simple-string-p (make-array
4 :element-type 'standard-char
:initial-contents '(#\a #\a #\a #\b)))))
(notnot (simple-string-p (make-array
4 :element-type 'standard-char
:initial-contents '(#\a #\a #\a #\b))))
t)
(deftest simple-string-p.7
......@@ -166,22 +166,22 @@
t)
(deftest stringp.2
(not (not (stringp "abcd")))
(notnot (stringp "abcd"))
t)
(deftest stringp.3
(not (not (stringp (make-array 4 :element-type 'character
:initial-contents '(#\a #\b #\c #\d)))))
(notnot (stringp (make-array 4 :element-type 'character
:initial-contents '(#\a #\b #\c #\d))))
t)
(deftest stringp.4
(not (not (stringp (make-array 4 :element-type 'base-char
:initial-contents '(#\a #\b #\c #\d)))))
(notnot (stringp (make-array 4 :element-type 'base-char
:initial-contents '(#\a #\b #\c #\d))))
t)
(deftest stringp.5
(not (not (stringp (make-array 4 :element-type 'standard-char
:initial-contents '(#\a #\b #\c #\d)))))
(notnot (stringp (make-array 4 :element-type 'standard-char
:initial-contents '(#\a #\b #\c #\d))))
t)
(deftest stringp.6
......@@ -198,5 +198,5 @@
(s2 (make-array 4 :element-type 'character
:displaced-to s
:displaced-index-offset 2)))
(not (not (stringp s2))))
(notnot (stringp s2)))
t)
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment