Commit d127e5e4 authored by pfdietz's avatar pfdietz

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)
This diff is collapsed.
......@@ -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")