From cc13e5d67880cc40cc99c12519c6b4ca392a68ca Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Sat, 14 Jun 2003 15:10:40 +0000
Subject: [PATCH] Added tests for TREE-EQUAL, and order of arguments tests for
 :TEST and :TEST-NOT functions in various places.

---
 ansi-tests/adjoin.lsp       |  19 ++++++
 ansi-tests/assoc.lsp        |  10 +++
 ansi-tests/count.lsp        |  33 +++++++++-
 ansi-tests/find.lsp         |  40 ++++++++++++
 ansi-tests/load-cons.lsp    |   1 +
 ansi-tests/load-symbols.lsp |   2 -
 ansi-tests/member.lsp       |   8 +++
 ansi-tests/nsublis.lsp      |  13 ++++
 ansi-tests/nsubst.lsp       |  11 ++++
 ansi-tests/pushnew.lsp      |  31 +++++++++
 ansi-tests/rassoc.lsp       |  10 +++
 ansi-tests/sublis.lsp       |  13 ++++
 ansi-tests/subst.lsp        |  11 ++++
 ansi-tests/tree-equal.lsp   | 125 ++++++++++++++++++++++++++++++++++++
 14 files changed, 324 insertions(+), 3 deletions(-)
 create mode 100644 ansi-tests/tree-equal.lsp

diff --git a/ansi-tests/adjoin.lsp b/ansi-tests/adjoin.lsp
index 9e000fce..6d3ae5ac 100644
--- a/ansi-tests/adjoin.lsp
+++ b/ansi-tests/adjoin.lsp
@@ -84,6 +84,25 @@
 	  :test-not (complement #'equal) :key nil)
   (aaa "AAA" "aaa" #\a))
 
+;;; Ordering in comparison function
+
+(deftest adjoin.19
+  (adjoin 10 '(1 2 3) :test #'<)
+  (10 1 2 3))
+
+(deftest adjoin.20
+  (adjoin 10 '(1 2 3) :test #'>)
+  (1 2 3))
+
+(deftest adjoin.21
+  (adjoin 10 '(1 2 3) :test-not #'>)
+  (10 1 2 3))
+
+(deftest adjoin.22
+  (adjoin 10 '(1 2 3) :test-not #'<)
+  (1 2 3))
+
+
 (deftest adjoin.order.1
   (let ((i 0) w x y z)
     (values
diff --git a/ansi-tests/assoc.lsp b/ansi-tests/assoc.lsp
index 238084d3..c72fd354 100644
--- a/ansi-tests/assoc.lsp
+++ b/ansi-tests/assoc.lsp
@@ -140,6 +140,16 @@
 		       (eqt x y))))
   (a . 3))
 
+;;; Order of test arguments
+
+(deftest assoc.26
+  (assoc 10 '((1 a) (5 b) (8 c) (11 d) (12 e)) :test #'<)
+  (11 d))
+
+(deftest assoc.27
+  (assoc 10 '((1 a) (5 b) (8 c) (11 d) (12 e)) :test-not #'>=)
+  (11 d))
+
 ;;; Order of argument evaluation
 
 (deftest assoc.order.1
diff --git a/ansi-tests/count.lsp b/ansi-tests/count.lsp
index ede89ed4..057d8249 100644
--- a/ansi-tests/count.lsp
+++ b/ansi-tests/count.lsp
@@ -79,6 +79,14 @@
 	 :test #'(lambda (x y) (declare (ignore x y))  t))
   5)
 
+(deftest count-list.17
+  (count 10 '(1 11 2 4 14 5 18 6 7) :test #'<)
+  3)
+
+(deftest count-list.18
+  (count 10 '(1 11 2 4 14 5 18 6 7) :test-not #'>=)
+  3)
+
 ;;; On vectors
 
 (deftest count-vector.1
@@ -150,11 +158,19 @@
   (count 1 #(1 1 1 1 1 2 1 1)  :test-not #'eql)
   1)
 
-(deftest count-vector16
+(deftest count-vector.16
   (count 1 #(1 1 1 3 1 2 1 1) :start 2 :end 7
 	 :test #'(lambda (x y) (declare (ignore x y)) t))
   5)
 
+(deftest count-vector.17
+  (count 10 #(1 11 2 4 14 5 18 6 7) :test #'<)
+  3)
+
+(deftest count-vector.18
+  (count 10 #(1 11 2 4 14 5 18 6 7) :test-not #'>=)
+  3)
+
 ;;; Non-simple vectors
 
 (deftest count-filled-vector.1
@@ -384,6 +400,13 @@
 	 :end 4)
   3)
 
+(deftest count-bit-vector.21
+  (count 1 #*00001100100 :test #'<=)
+  3)
+
+(deftest count-bit-vector.22
+  (count 1 #*00001100100 :test-not #'>)
+  3)
 
 ;;; Tests on strings
 
@@ -486,6 +509,14 @@
 	 :start 2 :end 5)
   3)
 
+(deftest count-string.21
+  (count #\1 "00001100100" :test #'char<=)
+  3)
+
+(deftest count-string.22
+  (count #\1 "00001100100" :test-not #'char>)
+  3)
+
 ;;; Argument order tests
 
 (deftest count.order.1
diff --git a/ansi-tests/find.lsp b/ansi-tests/find.lsp
index c9de8b08..e8652e87 100644
--- a/ansi-tests/find.lsp
+++ b/ansi-tests/find.lsp
@@ -150,6 +150,14 @@
 	    :start 2 :from-end t)
   (a b))
 
+(deftest find-list.29
+  (find 10 '(1 2 3 8 20 3 1 21 3) :test #'<)
+  20)
+
+(deftest find-list.30
+  (find 10 '(1 2 3 8 20 3 1 21 3) :test-not #'>=)
+  20)
+
 ;;; Tests on vectors
 
 (deftest find-vector.1
@@ -320,6 +328,14 @@
     (loop for i from 1 to 5 collect (find i a :from-end t :key #'car)))
   ((1 1) (2 2) (3 3) (4 4) (5 5)))
 
+(deftest find-vector.31
+  (find 10 #(1 2 3 8 20 3 1 21 3) :test #'<)
+  20)
+
+(deftest find-vector.32
+  (find 10 #(1 2 3 8 20 3 1 21 3) :test-not #'>=)
+  20)
+
 ;;; tests on bit vectors
 
 (deftest find-bit-vector.1
@@ -593,6 +609,22 @@
     (values (find 0 a) (find 0 a :from-end t)))
   0 0)
 
+(deftest find-bit-vector.31
+  (find 2 #*00011010010 :test #'<)
+  nil)
+
+(deftest find-bit-vector.32
+  (find 2 #*0010101101 :test-not #'>=)
+  nil)
+
+(deftest find-bit-vector.33
+  (find 0 #*00011010010 :test #'<)
+  1)
+
+(deftest find-bit-vector.34
+  (find 0 #*0010101101 :test-not #'>=)
+  1)
+
 ;;; strings
 
 (deftest find-string.1
@@ -741,6 +773,14 @@
   (#\a #\b #\c #\d #\e nil nil nil nil nil)
   (#\a #\b #\c #\d #\e nil nil nil nil nil))
 
+(deftest find-string.26
+  (find #\k "abcdmnop" :test #'char<)
+  #\m)
+
+(deftest find-string.27
+  (find #\k "abcdmnop" :test-not #'char>=)
+  #\m)
+
 ;;; Keyword tests
 
 (deftest find.allow-other-keys.1
diff --git a/ansi-tests/load-cons.lsp b/ansi-tests/load-cons.lsp
index 8a1faf74..a0bd1c17 100644
--- a/ansi-tests/load-cons.lsp
+++ b/ansi-tests/load-cons.lsp
@@ -9,6 +9,7 @@
 (load "rplaca.lsp")
 (load "rplacd.lsp")
 (load "copy-tree.lsp")
+(load "tree-equal.lsp")
 (load "sublis.lsp")
 (load "nsublis.lsp")
 (load "subst.lsp")
diff --git a/ansi-tests/load-symbols.lsp b/ansi-tests/load-symbols.lsp
index b56019c6..d8863f00 100644
--- a/ansi-tests/load-symbols.lsp
+++ b/ansi-tests/load-symbols.lsp
@@ -9,5 +9,3 @@
 (load "make-symbol.lsp")
 (load "symbol-name.lsp")
 (load "special-operator-p.lsp")
-
-
diff --git a/ansi-tests/member.lsp b/ansi-tests/member.lsp
index c7b0fe55..2a50ea25 100644
--- a/ansi-tests/member.lsp
+++ b/ansi-tests/member.lsp
@@ -138,6 +138,14 @@
   (member 'z '(a b c d) :key nil)
   nil)
 
+(deftest member.20
+  (member 10 '(1 2 3 4 10 11 14 18) :test #'<)
+  (11 14 18))
+
+(deftest member.21
+  (member 10 '(1 2 3 4 10 11 14 18) :test-not #'>=)
+  (11 14 18))
+
 ;;; Order of evaluation
 
 (deftest member.order.1
diff --git a/ansi-tests/nsublis.lsp b/ansi-tests/nsublis.lsp
index 22ccb51d..d6c15a01 100644
--- a/ansi-tests/nsublis.lsp
+++ b/ansi-tests/nsublis.lsp
@@ -67,6 +67,19 @@
    :key nil)
   (2 2 b b))
 
+(deftest nsublis.10
+  (check-nsublis  (list 0 3 8 20)
+		  '((1 . x) (5 . y) (10 . z))
+		  :test #'(lambda (x y) (and (realp x) (realp y) (< x y))))
+  (x y z 20))
+
+(deftest nsublis.11
+  (check-nsublis  (list 0 3 8 20)
+		  '((1 . x) (5 . y) (10 . z))
+		  :test-not
+		  #'(lambda (x y) (not (and (realp x) (realp y) (< x y)))))
+  (x y z 20))
+
 ;;; Order of argument evaluation
 (deftest nsublis.order.1
   (let ((i 0) w x y z)
diff --git a/ansi-tests/nsubst.lsp b/ansi-tests/nsubst.lsp
index c089e8c8..14436fa2 100644
--- a/ansi-tests/nsubst.lsp
+++ b/ansi-tests/nsubst.lsp
@@ -62,6 +62,17 @@
 		:key nil)
   (a a c d a a))
 
+(deftest nsubst.10
+  (check-nsubst 'x 10 (copy-tree '(1 2 10 20 30 4))
+		:test #'(lambda (x y) (and (realp x) (realp y) (< x y))))
+  (1 2 10 x x 4))
+
+(deftest nsubst.11
+  (check-nsubst 'x 10 (copy-tree '(1 2 10 20 30 4))
+		:test-not #'(lambda (x y)
+			      (not (and (realp x) (realp y) (< x y)))))
+  (1 2 10 x x 4))
+
 ;;; Order of argument evaluation
 (deftest nsubst.order.1
   (let ((i 0) v w x y z)
diff --git a/ansi-tests/pushnew.lsp b/ansi-tests/pushnew.lsp
index b35ae8be..e82216f5 100644
--- a/ansi-tests/pushnew.lsp
+++ b/ansi-tests/pushnew.lsp
@@ -154,6 +154,37 @@
   (a b c) (a b c)
   3 1 3 2)
 
+(deftest pushnew.16
+  (let ((x '(1 2 3)))
+    (values
+     (pushnew 10 x :test #'<=)
+     x))
+  (10 1 2 3)
+  (10 1 2 3))
+
+(deftest pushnew.17
+  (let ((x '(1 2 3)))
+    (values
+     (pushnew 10 x :test #'>)
+     x))
+  (1 2 3)
+  (1 2 3))
+(deftest pushnew.18
+  (let ((x '(1 2 3)))
+    (values
+     (pushnew 10 x :test-not #'>)
+     x))
+  (10 1 2 3)
+  (10 1 2 3))
+
+(deftest pushnew.19
+  (let ((x '(1 2 3)))
+    (values
+     (pushnew 10 x :test-not #'<=)
+     x))
+  (1 2 3)
+  (1 2 3))
+
 (deftest pushnew.order.1
   (let ((x (vector nil nil nil nil))
 	(y (vector 'a 'b 'c 'd))
diff --git a/ansi-tests/rassoc.lsp b/ansi-tests/rassoc.lsp
index 49877d22..9a8f4916 100644
--- a/ansi-tests/rassoc.lsp
+++ b/ansi-tests/rassoc.lsp
@@ -178,6 +178,16 @@
 		      (eqt x y))))
   (3 . a))
 
+(deftest rassoc.26
+  (rassoc 10 '((a . 1) (b . 5) (c . 10) (d . 15) (e . 40))
+	  :test #'<)
+  (d . 15))
+
+(deftest rassoc.27
+  (rassoc 10 '((a . 1) (b . 5) (c . 10) (d . 15) (e . 40))
+	  :test-not #'>=)
+  (d . 15))
+
 ;;; Order of argument evaluation
 
 (deftest rassoc.order.1
diff --git a/ansi-tests/sublis.lsp b/ansi-tests/sublis.lsp
index ccaf27df..5b508a52 100644
--- a/ansi-tests/sublis.lsp
+++ b/ansi-tests/sublis.lsp
@@ -63,6 +63,19 @@
    :key nil)
   (2 2 b b))
 
+(deftest sublis.9
+  (check-sublis  (list 0 3 8 20)
+		 '((1 . x) (5 . y) (10 . z))
+		:test #'(lambda (x y) (and (realp x) (realp y) (< x y))))
+  (x y z 20))
+
+(deftest sublis.10
+  (check-sublis  (list 0 3 8 20)
+		 '((1 . x) (5 . y) (10 . z))
+		:test-not
+		#'(lambda (x y) (not (and (realp x) (realp y) (< x y)))))
+  (x y z 20))
+
 ;;; Order of argument evaluation
 (deftest sublis.order.1
   (let ((i 0) w x y z)
diff --git a/ansi-tests/subst.lsp b/ansi-tests/subst.lsp
index dcdaba80..de9c877f 100644
--- a/ansi-tests/subst.lsp
+++ b/ansi-tests/subst.lsp
@@ -61,6 +61,17 @@
 	       :key nil)
   (a a c d a a))
 
+(deftest subst.10
+  (check-subst 'x 10 (copy-tree '(1 2 10 20 30 4))
+	       :test #'(lambda (x y) (and (realp x) (realp y) (< x y))))
+  (1 2 10 x x 4))
+
+(deftest subst.11
+  (check-subst 'x 10 (copy-tree '(1 2 10 20 30 4))
+	       :test-not #'(lambda (x y)
+			     (not (and (realp x) (realp y) (< x y)))))
+  (1 2 10 x x 4))
+
 ;;; Order of argument evaluation
 (deftest subst.order.1
   (let ((i 0) v w x y z)
diff --git a/ansi-tests/tree-equal.lsp b/ansi-tests/tree-equal.lsp
new file mode 100644
index 00000000..c9bb3aaa
--- /dev/null
+++ b/ansi-tests/tree-equal.lsp
@@ -0,0 +1,125 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sat Jun 14 07:23:03 2003
+;;;; Contains: Tests of TREE-EQUAL
+
+(in-package :cl-test)
+
+(deftest tree-equal.1
+  (notnot-mv (tree-equal 'a 'a))
+  t)
+
+(deftest tree-equal.2
+  (tree-equal 'a 'b)
+  nil)
+
+(deftest tree-equal.3
+  (notnot-mv (tree-equal (list 'a 'b (list 'c 'd))
+			 (list 'a 'b (list 'c 'd))))
+  t)
+
+(deftest tree-equal.4
+  (tree-equal '(a b c d) '(a b c e))
+  nil)
+
+(deftest tree-equal.5
+  (notnot-mv (tree-equal 1 2 :test #'<))
+  t)
+  
+(deftest tree-equal.6
+  (notnot-mv (tree-equal 1 2 :test #'(lambda (x y) (values (< x y) t))))
+  t)
+
+(deftest tree-equal.7
+  (tree-equal 1 2 :test #'>)
+  nil)
+  
+(deftest tree-equal.8
+  (tree-equal (list 1) 2 :test (constantly t))
+  nil)
+
+(deftest tree-equal.9
+  (tree-equal (list 1) (list 2)
+	      :test #'(lambda (x y) (or (and (consp x) (consp y))
+					(eql x y))))
+  nil)
+
+(deftest tree-equal.10
+  (notnot-mv (tree-equal '(10 20 . 30) '(11 22 . 34) :test #'<))
+  t)
+
+(deftest tree-equal.11
+  (let* ((x (list 'a 'b))
+	 (y (list x x))
+	 (z (list (list 'a 'b) (list 'a 'b))))
+    (notnot-mv (tree-equal y z)))
+  t)
+
+(deftest tree-equal.12
+  (tree-equal 'a '(a b))
+  nil)
+
+(deftest tree-equal.13
+  (tree-equal '(a) '(a b))
+  nil)
+
+(deftest tree-equal.14
+  (tree-equal '(a b) '(a))
+  nil)
+
+(deftest tree-equal.15
+  (let ((x (vector 'a 'b 'c))
+	(y (vector 'a' 'b 'c)))
+    (tree-equal x y))
+  nil)
+
+(deftest tree-equal.16
+  (let ((x (copy-seq ""))
+	(y (copy-seq "")))
+    (tree-equal x y))
+  nil)
+
+;;; Keywords tests
+
+(deftest tree-equal.allow-other-keys.1
+  (notnot-mv (tree-equal '(a b) (list 'a 'b) :allow-other-keys nil))
+  t)
+
+(deftest tree-equal.allow-other-keys.2
+  (tree-equal '(a b) (list 'a 'c) :allow-other-keys nil :test #'eql)
+  nil)
+
+(deftest tree-equal.allow-other-keys.3
+  (tree-equal '(a b) (list 'a 'z) :allow-other-keys t :foo t)
+  nil)
+
+(deftest tree-equal.allow-other-keys.4
+  (notnot-mv (tree-equal '(a b) (list 'a 'b) :allow-other-keys t
+			 :allow-other-keys nil :foo t))
+  t)
+
+;;; Error tests
+
+(deftest tree-equal.error.1
+  (classify-error (tree-equal))
+  program-error)
+
+(deftest tree-equal.error.2
+  (classify-error (tree-equal '(a b)))
+  program-error)
+
+(deftest tree-equal.error.3
+  (classify-error (tree-equal '(a b) '(a b) (gensym) t))
+  program-error)
+
+(deftest tree-equal.error.4
+  (classify-error (tree-equal '(a b) '(a b) (gensym) t :allow-other-keys nil))
+  program-error)
+
+
+
+
+
+
+
+    
\ No newline at end of file
-- 
GitLab