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