diff --git a/ansi-tests/acons.lsp b/ansi-tests/acons.lsp new file mode 100644 index 0000000000000000000000000000000000000000..94558d3ddf60e149097cbebf909125073a245682 --- /dev/null +++ b/ansi-tests/acons.lsp @@ -0,0 +1,62 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:26:48 2003 +;;;; Contains: Tests of ACONS + +(in-package :cl-test) + +(deftest acons.1 + (let* ((x (copy-tree '((c . d) (e . f)))) + (xcopy (make-scaffold-copy x)) + (result (acons 'a 'b x))) + (and + (check-scaffold-copy x xcopy) + (eqt (cdr result) x) + result)) + ((a . b) (c . d) (e . f))) + +(deftest acons.2 + (acons 'a 'b nil) + ((a . b))) + +(deftest acons.3 + (acons 'a 'b 'c) + ((a . b) . c)) + +(deftest acons.4 + (acons '((a b)) '(((c d) e) f) '((1 . 2))) + (( ((a b)) . (((c d) e) f)) (1 . 2))) + +(deftest acons.5 + (acons "ancd" 1.143 nil) + (("ancd" . 1.143))) + +(deftest acons.6 + (acons #\R :foo :bar) + ((#\R . :foo) . :bar)) + +(deftest acons.order.1 + (let ((i 0) x y z) + (values + (acons (progn (setf x (incf i)) 'a) + (progn (setf y (incf i)) 'b) + (progn (setf z (incf i)) '((c . d)))) + i x y z)) + ((a . b)(c . d)) + 3 1 2 3) + +(deftest acons.error.1 + (classify-error (acons)) + program-error) + +(deftest acons.error.2 + (classify-error (acons 'a)) + program-error) + +(deftest acons.error.3 + (classify-error (acons 'a 'b)) + program-error) + +(deftest acons.error.4 + (classify-error (acons 'a 'b 'c 'd)) + program-error) diff --git a/ansi-tests/adjoin.lsp b/ansi-tests/adjoin.lsp new file mode 100644 index 0000000000000000000000000000000000000000..9e000fce22e14992cf1f27b6a1798c79ab5bc272 --- /dev/null +++ b/ansi-tests/adjoin.lsp @@ -0,0 +1,173 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:33:20 1998 +;;;; Contains: Tests of ADJOIN + +(in-package :cl-test) + +(deftest adjoin.1 + (adjoin 'a nil) + (a)) + +(deftest adjoin.2 + (adjoin nil nil) + (nil)) + +(deftest adjoin.3 + (adjoin 'a '(a)) + (a)) + +;; Check that a NIL :key argument is the same as no key argument at all +(deftest adjoin.4 + (adjoin 'a '(a) :key nil) + (a)) + +(deftest adjoin.5 + (adjoin 'a '(a) :key #'identity) + (a)) + +(deftest adjoin.6 + (adjoin 'a '(a) :key 'identity) + (a)) + +(deftest adjoin.7 + (adjoin (1+ 11) '(4 3 12 2 1)) + (4 3 12 2 1)) + +;; Check that the test is EQL, not EQ (by adjoining a bignum) +(deftest adjoin.8 + (adjoin (1+ 999999999999) '(4 1 1000000000000 3816734 a "aa")) + (4 1 1000000000000 3816734 a "aa")) + +(deftest adjoin.9 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a)) + ("aaa" aaa "AAA" "aaa" #\a)) + +(deftest adjoin.10 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test #'equal) + (aaa "AAA" "aaa" #\a)) + +(deftest adjoin.11 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test 'equal) + (aaa "AAA" "aaa" #\a)) + +(deftest adjoin.12 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test-not (complement #'equal)) + (aaa "AAA" "aaa" #\a)) + +(deftest adjoin.14 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test #'equal :key #'identity) + (aaa "AAA" "aaa" #\a)) + +(deftest adjoin.15 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test 'equal :key #'identity) + (aaa "AAA" "aaa" #\a)) + +;; Test that a :key of NIL is the same as no key at all +(deftest adjoin.16 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test #'equal :key nil) + (aaa "AAA" "aaa" #\a)) + +;; Test that a :key of NIL is the same as no key at all +(deftest adjoin.17 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test 'equal :key nil) + (aaa "AAA" "aaa" #\a)) + +;; Test that a :key of NIL is the same as no key at all +(deftest adjoin.18 + (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) + :test-not (complement #'equal) :key nil) + (aaa "AAA" "aaa" #\a)) + +(deftest adjoin.order.1 + (let ((i 0) w x y z) + (values + (adjoin (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) '(b c d a e)) + :key (progn (setf y (incf i)) #'identity) + :test (progn (setf z (incf i)) #'eql)) + i w x y z)) + (b c d a e) + 4 1 2 3 4) + +(deftest adjoin.order.2 + (let ((i 0) w x y z p) + (values + (adjoin (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) '(b c d e)) + :test-not (progn (setf y (incf i)) (complement #'eql)) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf p (incf i)) nil)) + i w x y z p)) + (a b c d e) + 5 1 2 3 4 5) + +(deftest adjoin.allow-other-keys.1 + (adjoin 'a '(b c) :bad t :allow-other-keys t) + (a b c)) + +(deftest adjoin.allow-other-keys.2 + (adjoin 'a '(b c) :allow-other-keys t :foo t) + (a b c)) + +(deftest adjoin.allow-other-keys.3 + (adjoin 'a '(b c) :allow-other-keys t) + (a b c)) + +(deftest adjoin.allow-other-keys.4 + (adjoin 'a '(b c) :allow-other-keys nil) + (a b c)) + +(deftest adjoin.allow-other-keys.5 + (adjoin 'a '(b c) :allow-other-keys t :allow-other-keys nil 'bad t) + (a b c)) + +(deftest adjoin.repeat-key + (adjoin 'a '(b c) :test #'eq :test (complement #'eq)) + (a b c)) + +(deftest adjoin.error.1 + (classify-error (adjoin)) + program-error) + +(deftest adjoin.error.2 + (classify-error (adjoin 'a)) + program-error) + +(deftest adjoin.error.3 + (classify-error (adjoin 'a '(b c) :bad t)) + program-error) + +(deftest adjoin.error.4 + (classify-error (adjoin 'a '(b c) :allow-other-keys nil :bad t)) + program-error) + +(deftest adjoin.error.5 + (classify-error (adjoin 'a '(b c) 1 2)) + program-error) + +(deftest adjoin.error.6 + (classify-error (adjoin 'a '(b c) :test)) + program-error) + +(deftest adjoin.error.7 + (classify-error (adjoin 'a '(b c) :test #'identity)) + program-error) + +(deftest adjoin.error.8 + (classify-error (adjoin 'a '(b c) :test-not #'identity)) + program-error) + +(deftest adjoin.error.9 + (classify-error (adjoin 'a '(b c) :key #'cons)) + program-error) + +(deftest adjoin.error.10 + (classify-error (adjoin 'a (list* 'b 'c 'd))) + type-error) + diff --git a/ansi-tests/append.lsp b/ansi-tests/append.lsp new file mode 100644 index 0000000000000000000000000000000000000000..78634cf3ed32e0c18e7de7bcdc502f49efb79ad5 --- /dev/null +++ b/ansi-tests/append.lsp @@ -0,0 +1,62 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:36:46 2003 +;;;; Contains: Tests of APPEND + +(in-package :cl-test) + + +(deftest append.1 + (append) + nil) + +(deftest append.2 + (append 'x) + x) + +(deftest append.3 + (let ((x (list 'a 'b 'c 'd)) + (y (list 'e 'f 'g))) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (append x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)))) + (a b c d e f g)) + +(deftest append.4 + (append (list 'a) (list 'b) (list 'c) + (list 'd) (list 'e) (list 'f) + (list 'g) 'h) + (a b c d e f g . h)) + +(deftest append.5 + (append nil nil nil nil nil nil nil nil 'a) + a) + +(deftest append.6 + (append-6-body) + 0) + +(deftest append.order.1 + (let ((i 0) x y z) + (values + (append (progn (setf x (incf i)) (copy-list '(a b c))) + (progn (setf y (incf i)) (copy-list '(d e f))) + (progn (setf z (incf i)) (copy-list '(g h i)))) + i x y z)) + (a b c d e f g h i) 3 1 2 3) + +(deftest append.order.2 + (let ((i 0)) (values (append (incf i)) i)) + 1 1) + +(deftest append.error.1 + (classify-error (append '(a . b) '(z))) + type-error) + +(deftest append.error.2 + (classify-error (append '(x y z) '(a . b) '(z))) + type-error) diff --git a/ansi-tests/assoc-if-not.lsp b/ansi-tests/assoc-if-not.lsp new file mode 100644 index 0000000000000000000000000000000000000000..abc545fdc20e5ce3c0d85fff776a5fbb4efcd7fc --- /dev/null +++ b/ansi-tests/assoc-if-not.lsp @@ -0,0 +1,142 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:28:37 2003 +;;;; Contains: Tests of ASSOC-IF-NOT + +(in-package :cl-test) + +(deftest assoc-if-not.1 + (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if-not #'oddp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (6 . c)) + +(deftest assoc-if-not.2 + (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if-not #'evenp x :key #'1+))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (6 . c)) + +(deftest assoc-if-not.3 + (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if-not #'oddp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (fourth x)) + result)) + (6 . c)) + +(deftest assoc-if-not.4 + (assoc-if-not #'identity '((a . b) nil (c . d) (nil . e) (f . g))) + (nil . e)) + +;;; Order of argument evaluation tests + +(deftest assoc-if-not.order.1 + (let ((i 0) x y) + (values + (assoc-if-not (progn (setf x (incf i)) #'identity) + (progn (setf y (incf i)) + '((a . 1) (b . 2) (nil . 17) (d . 4)))) + i x y)) + (nil . 17) 2 1 2) + +(deftest assoc-if-not.order.2 + (let ((i 0) x y z) + (values + (assoc-if-not (progn (setf x (incf i)) #'identity) + (progn (setf y (incf i)) + '((a . 1) (b . 2) (nil . 17) (d . 4))) + :key (progn (setf z (incf i)) #'null)) + i x y z)) + (a . 1) 3 1 2 3) + +;;; Keyword tests + +(deftest assoc-if-not.allow-other-keys.1 + (assoc-if-not #'identity + '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) + (nil . 2)) + +(deftest assoc-if-not.allow-other-keys.2 + (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) + :allow-other-keys t :also-bad t) + (nil . 2)) + +(deftest assoc-if-not.allow-other-keys.3 + (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) + :allow-other-keys t :also-bad t :key #'not) + (a . 1)) + +(deftest assoc-if-not.allow-other-keys.4 + (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t) + (nil . 2)) + +(deftest assoc-if-not.allow-other-keys.5 + (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys nil) + (nil . 2)) + +(deftest assoc-if-not.keywords.6 + (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) + :key #'identity :key #'null) + (nil . 2)) + +(deftest assoc-if-not.keywords.7 + (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null) + (nil . 2)) + +;;; Error tests + +(deftest assoc-if-not.error.1 + (classify-error (assoc-if-not)) + program-error) + +(deftest assoc-if-not.error.2 + (classify-error (assoc-if-not #'null)) + program-error) + +(deftest assoc-if-not.error.3 + (classify-error (assoc-if-not #'null nil :bad t)) + program-error) + +(deftest assoc-if-not.error.4 + (classify-error (assoc-if-not #'null nil :key)) + program-error) + +(deftest assoc-if-not.error.5 + (classify-error (assoc-if-not #'null nil 1 1)) + program-error) + +(deftest assoc-if-not.error.6 + (classify-error (assoc-if-not #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest assoc-if-not.error.7 + (classify-error (assoc-if-not #'cons '((a b)(c d)))) + program-error) + +(deftest assoc-if-not.error.8 + (classify-error (assoc-if-not #'identity '((a b)(c d)) :key #'cons)) + program-error) + +(deftest assoc-if-not.error.9 + (classify-error (assoc-if-not #'car '((a b)(c d)))) + type-error) + +(deftest assoc-if-not.error.10 + (classify-error (assoc-if-not #'identity '((a b)(c d)) :key #'car)) + type-error) + +(deftest assoc-if-not.error.11 + (classify-error (assoc-if-not #'identity '((a . b) . c))) + type-error) + diff --git a/ansi-tests/assoc-if.lsp b/ansi-tests/assoc-if.lsp new file mode 100644 index 0000000000000000000000000000000000000000..c148283b66afd58baa98b02758a360137beafc9c --- /dev/null +++ b/ansi-tests/assoc-if.lsp @@ -0,0 +1,140 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:27:57 2003 +;;;; Contains: Tests of ASSOC-IF + +(in-package :cl-test) + + +(deftest assoc-if.1 + (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'evenp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (6 . c)) + +(deftest assoc-if.2 + (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'oddp x :key #'1+))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (6 . c)) + +(deftest assoc-if.3 + (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'evenp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (fourth x)) + result)) + (6 . c)) + +(deftest assoc-if.4 + (assoc-if #'null '((a . b) nil (c . d) (nil . e) (f . g))) + (nil . e)) + +;;; Order of argument evaluation + +(deftest assoc-if.order.1 + (let ((i 0) x y) + (values + (assoc-if (progn (setf x (incf i)) #'null) + (progn (setf y (incf i)) + '((a . 1) (b . 2) (nil . 17) (d . 4)))) + i x y)) + (nil . 17) 2 1 2) + +(deftest assoc-if.order.2 + (let ((i 0) x y z) + (values + (assoc-if (progn (setf x (incf i)) #'null) + (progn (setf y (incf i)) + '((a . 1) (b . 2) (nil . 17) (d . 4))) + :key (progn (setf z (incf i)) #'null)) + i x y z)) + (a . 1) 3 1 2 3) + +;;; Keyword tests + +(deftest assoc-if.allow-other-keys.1 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) + (nil . 2)) + +(deftest assoc-if.allow-other-keys.2 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) + :allow-other-keys t :also-bad t) + (nil . 2)) + +(deftest assoc-if.allow-other-keys.3 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) + :allow-other-keys t :also-bad t :key #'not) + (a . 1)) + +(deftest assoc-if.allow-other-keys.4 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t) + (nil . 2)) + +(deftest assoc-if.allow-other-keys.5 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys nil) + (nil . 2)) + +(deftest assoc-if.keywords.6 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :key #'identity :key #'null) + (nil . 2)) + +(deftest assoc-if.keywords.7 + (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null) + (nil . 2)) + +;;; Error cases + +(deftest assoc-if.error.1 + (classify-error (assoc-if)) + program-error) + +(deftest assoc-if.error.2 + (classify-error (assoc-if #'null)) + program-error) + +(deftest assoc-if.error.3 + (classify-error (assoc-if #'null nil :bad t)) + program-error) + +(deftest assoc-if.error.4 + (classify-error (assoc-if #'null nil :key)) + program-error) + +(deftest assoc-if.error.5 + (classify-error (assoc-if #'null nil 1 1)) + program-error) + +(deftest assoc-if.error.6 + (classify-error (assoc-if #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest assoc-if.error.7 + (classify-error (assoc-if #'cons '((a b)(c d)))) + program-error) + +(deftest assoc-if.error.8 + (classify-error (assoc-if #'identity '((a b)(c d)) :key #'cons)) + program-error) + +(deftest assoc-if.error.9 + (classify-error (assoc-if #'car '((a b)(c d)))) + type-error) + +(deftest assoc-if.error.10 + (classify-error (assoc-if #'identity '((a b)(c d)) :key #'car)) + type-error) + +(deftest assoc-if.error.11 + (classify-error (assoc-if #'null '((a . b) . c))) + type-error) diff --git a/ansi-tests/assoc.lsp b/ansi-tests/assoc.lsp new file mode 100644 index 0000000000000000000000000000000000000000..238084d344138c87bff01ce1850481a5cf98f24f --- /dev/null +++ b/ansi-tests/assoc.lsp @@ -0,0 +1,252 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:27:20 2003 +;;;; Contains: Tests of ASSOC + +(in-package :cl-test) + +(deftest assoc.1 + (assoc nil nil) + nil) + +(deftest assoc.2 + (assoc nil '(nil)) + nil) + +(deftest assoc.3 + (assoc nil '(nil (nil . 2) (a . b))) + (nil . 2)) + +(deftest assoc.4 + (assoc nil '((a . b) (c . d))) + nil) + +(deftest assoc.5 + (assoc 'a '((a . b))) + (a . b)) + +(deftest assoc.6 + (assoc 'a '((:a . b) (#:a . c) (a . d) (a . e) (z . f))) + (a . d)) + +(deftest assoc.7 + (let* ((x (copy-tree '((a . b) (b . c) (c . d)))) + (xcopy (make-scaffold-copy x)) + (result (assoc 'b x))) + (and + (eqt result (second x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest assoc.8 + (assoc 1 '((0 . a) (1 . b) (2 . c))) + (1 . b)) + +(deftest assoc.9 + (assoc (copy-seq "abc") + '((abc . 1) ("abc" . 2) ("abc" . 3))) + nil) + +(deftest assoc.10 + (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c))))) + nil) + +(deftest assoc.11 + (let ((x (list 'a 'b))) + (assoc x `(((a b) c) (,x . d) (,x . e) ((a b) 1)))) + ((a b) . d)) + + +(deftest assoc.12 + (assoc #\e '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)) + :key #'(lambda (x) (char x 1))) + ("aevgd" . 2)) + +(deftest assoc.13 + (assoc nil '(((a) . b) ( nil . c ) ((nil) . d)) + :key #'car) + (nil . c)) + +(deftest assoc.14 + (assoc (copy-seq "abc") + '((abc . 1) ("abc" . 2) ("abc" . 3)) + :test #'equal) + ("abc" . 2)) + +(deftest assoc.15 + (assoc (copy-seq "abc") + '((abc . 1) ("abc" . 2) ("abc" . 3)) + :test #'equalp) + ("abc" . 2)) + +(deftest assoc.16 + (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c)))) + :test #'equal) + ((a) b)) + +(deftest assoc.17 + (assoc (copy-seq "abc") + '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)) + :test-not (complement #'equalp)) + ("abc" . 2)) + +(deftest assoc.18 + (assoc 'a '((a . d)(b . c)) :test-not #'eq) + (b . c)) + +(deftest assoc.19 + (assoc 'a '((a . d)(b . c)) :test (complement #'eq)) + (b . c)) + +(deftest assoc.20 + (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test #'equal) + ("A" . 6)) + +(deftest assoc.21 + (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) + :key #'(lambda (x) (and (stringp x) x)) + :test #'equal) + ("a" . 3)) + +(deftest assoc.22 + (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test-not (complement #'equal)) + ("A" . 6)) + +(deftest assoc.23 + (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) + :key #'(lambda (x) (and (stringp x) x)) + :test-not (complement #'equal)) + ("a" . 3)) + +;; Check that it works when test returns a true value +;; other than T + +(deftest assoc.24 + (assoc 'a '((b . 1) (a . 2) (c . 3)) + :test #'(lambda (x y) (and (eqt x y) 'matched))) + (a . 2)) + +;; Check that the order of the arguments to test is correct + +(deftest assoc.25 + (block fail + (assoc 'a '((b . 1) (c . 2) (a . 3)) + :test #'(lambda (x y) + (unless (eqt x 'a) (return-from fail 'fail)) + (eqt x y)))) + (a . 3)) + +;;; Order of argument evaluation + +(deftest assoc.order.1 + (let ((i 0) x y) + (values + (assoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4)))) + i x y)) + (c . 3) 2 1 2) + +(deftest assoc.order.2 + (let ((i 0) x y z) + (values + (assoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) + :test (progn (setf z (incf i)) #'eq)) + i x y z)) + (c . 3) 3 1 2 3) + +(deftest assoc.order.3 + (let ((i 0) x y) + (values + (assoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) + :test #'eq) + i x y)) + (c . 3) 2 1 2) + +(deftest assoc.order.4 + (let ((i 0) x y z w) + (values + (assoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf w (incf i)) #'not)) + i x y z w)) + (c . 3) 4 1 2 3 4) + +;;; Keyword tests + +(deftest assoc.allow-other-keys.1 + (assoc 'b '((a . 1) (b . 2) (c . 3)) :bad t :allow-other-keys t) + (b . 2)) + +(deftest assoc.allow-other-keys.2 + (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t) + (b . 2)) + +(deftest assoc.allow-other-keys.3 + (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t + :test-not #'eql) + (a . 1)) + +(deftest assoc.allow-other-keys.4 + (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t) + (b . 2)) + +(deftest assoc.allow-other-keys.5 + (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys nil) + (b . 2)) + +(deftest assoc.keywords.6 + (assoc 'b '((a . 1) (b . 2) (c . 3)) :key #'identity :key #'null) + (b . 2)) + +(deftest assoc.keywords.7 + (assoc 'b '((a . 1) (b . 2) (c . 3)) :key nil :key #'null) + (b . 2)) + + +(deftest assoc.error.1 + (classify-error (assoc)) + program-error) + +(deftest assoc.error.2 + (classify-error (assoc nil)) + program-error) + +(deftest assoc.error.3 + (classify-error (assoc nil nil :bad t)) + program-error) + +(deftest assoc.error.4 + (classify-error (assoc nil nil :key)) + program-error) + +(deftest assoc.error.5 + (classify-error (assoc nil nil 1 1)) + program-error) + +(deftest assoc.error.6 + (classify-error (assoc nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest assoc.error.7 + (classify-error (assoc 'a '((a . b)) :test #'identity)) + program-error) + +(deftest assoc.error.8 + (classify-error (assoc 'a '((a . b)) :test-not #'identity)) + program-error) + +(deftest assoc.error.9 + (classify-error (assoc 'a '((a . b)) :key #'cons)) + program-error) + +(deftest assoc.error.10 + (classify-error (assoc 'z '((a . b) . c))) + type-error) + diff --git a/ansi-tests/atom.lsp b/ansi-tests/atom.lsp new file mode 100644 index 0000000000000000000000000000000000000000..574525e726b7f99e001fe91b6c84902a43f0d1bd --- /dev/null +++ b/ansi-tests/atom.lsp @@ -0,0 +1,19 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:28:09 2003 +;;;; Contains: Tests of ATOM + +(in-package :cl-test) + +(deftest atom.order.1 + (let ((i 0)) + (values (atom (progn (incf i) '(a b))) i)) + nil 1) + +(deftest atom.error.1 + (classify-error (atom)) + program-error) + +(deftest atom.error.2 + (classify-error (atom 'a 'b)) + program-error) diff --git a/ansi-tests/butlast.lsp b/ansi-tests/butlast.lsp new file mode 100644 index 0000000000000000000000000000000000000000..b64f809cab54356e4b14d606ed1808238904cae1 --- /dev/null +++ b/ansi-tests/butlast.lsp @@ -0,0 +1,84 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:41:14 2003 +;;;; Contains: Tests of BUTLAST + +(in-package :cl-test) + +(deftest butlast.1 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((xcopy (make-scaffold-copy x))) + (let ((result (butlast x 2))) + (and + (check-scaffold-copy x xcopy) + result)))) + (a b c)) + +(deftest butlast.2 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((xcopy (make-scaffold-copy x))) + (let ((result (butlast x 0))) + (and + (check-scaffold-copy x xcopy) + result)))) + (a b c d e)) + +(deftest butlast.3 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((xcopy (make-scaffold-copy x))) + (let ((result (butlast x 5))) + (and + (check-scaffold-copy x xcopy) + result)))) + nil) + +(deftest butlast.4 + (let ((x (list 'a 'b 'c 'd 'e))) + (let ((xcopy (make-scaffold-copy x))) + (let ((result (butlast x 6))) + (and + (check-scaffold-copy x xcopy) + result)))) + nil) + +(deftest butlast.5 + (butlast (copy-tree '(a b c . d)) 1) + (a b)) + +(deftest butlast.order.1 + (let ((i 0) x y) + (values + (butlast (progn (setf x (incf i)) + (list 'a 'b 'c 'd 'e)) + (progn (setf y (incf i)) + 2)) + i x y)) + (a b c) 2 1 2) + +(deftest butlast.order.2 + (let ((i 0)) + (values + (butlast (progn (incf i) '(a b c d))) + i)) + (a b c) 1) + +(deftest butlast.error.1 + (classify-error (butlast (copy-tree '(a b c d)) 'a)) + type-error) + +(deftest butlast.error.2 + (classify-error (butlast 'a 0)) + type-error) + +(deftest butlast.error.3 + (classify-error (butlast)) + program-error) + +(deftest butlast.error.4 + (classify-error (butlast '(a b c) 3 3)) + program-error) + +(deftest butlast.error.5 + (classify-error (locally (butlast 'a 0) t)) + type-error) + diff --git a/ansi-tests/cons-aux.lsp b/ansi-tests/cons-aux.lsp index 265b698b21739f973214dba122560bc94970f03e..becd75319a726ef6da5ab7cd4604d98dd0428528 100644 --- a/ansi-tests/cons-aux.lsp +++ b/ansi-tests/cons-aux.lsp @@ -82,3 +82,11 @@ unless (equal result1 result2) return (list (list 'remove-duplicates (list 'sort (cons fn args) '<) "...") "actual: " result2 "should be: " result1))) + +(defun rev-assoc-list (x) + (cond + ((null x) nil) + ((null (car x)) + (cons nil (rev-assoc-list (cdr x)))) + (t + (acons (cdar x) (caar x) (rev-assoc-list (cdr x)))))) diff --git a/ansi-tests/cons-test-01.lsp b/ansi-tests/cons-test-01.lsp index c665a81713bca33b6ad071c85284c50a7a79ccc4..41141e608694f1637512fabccb06b162ef0e7adb 100644 --- a/ansi-tests/cons-test-01.lsp +++ b/ansi-tests/cons-test-01.lsp @@ -123,334 +123,3 @@ (deftest no-cons-fns-are-macros (some #'macro-function *cons-fns*) nil) - -;; Various easy tests of cons -(deftest cons-of-symbols - (cons 'a 'b) - (a . b)) - -(deftest cons-with-nil - (cons 'a nil) - (a)) - -;; successive calls to cons produces results that are equal, but not eq -(deftest cons-eq-equal - (let ((x (cons 'a 'b)) - (y (cons 'a 'b))) - (and (not (eqt x y)) - (equalt x y))) - t) - -;; list can be expressed as a bunch of conses (with nil) -(deftest cons-equal-list - (equalt (cons 'a (cons 'b (cons 'c nil))) - (list 'a 'b 'c)) - t) - -;;; Order of evaluation of cons arguments -(deftest cons.order.1 - (let ((i 0)) (values (cons (incf i) (incf i)) i)) - (1 . 2) 2) - -;; Lists satisfy consp -(deftest consp-list - (notnot-mv (consp '(a))) - t) - -;; cons satisfies consp -(deftest consp-cons - (notnot-mv (consp (cons nil nil))) - t) - -;; nil is not a consp -(deftest consp-nil - (consp nil) - nil) - -;; The empty list is not a cons -(deftest consp-empty-list - (consp (list)) - nil) - -;; A single element list is a cons -(deftest consp-single-element-list - (notnot-mv (consp (list 'a))) - t) - -;; For everything in *universe*, it is either an atom, or satisfies -;; consp, but not both -(deftest consp-xor-atom-universe - (notnot-mv - (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 -(deftest consp-cons-universe - (check-type-predicate 'consp 'cons) - 0) - -(deftest consp.order.1 - (let ((i 0)) - (values (consp (incf i)) i)) - nil 1) - -(deftest consp.error.1 - (classify-error (consp)) - program-error) - -(deftest consp.error.2 - (classify-error (consp 'a 'b)) - program-error) - -(deftest atom.order.1 - (let ((i 0)) - (values (atom (progn (incf i) '(a b))) i)) - nil 1) - -(deftest atom.error.1 - (classify-error (atom)) - program-error) - -(deftest atom.error.2 - (classify-error (atom 'a 'b)) - program-error) - -;; Tests of car, cdr and compound forms -(deftest cons.23 - (car '(a)) - a) - -(deftest cons.24 - (cdr '(a . b)) - b) - -(deftest cons.25 - (caar '((a))) - a) - -(deftest cons.26 - (cdar '((a . b))) - b) - -(deftest cons.27 - (cadr '(a b)) - b) - -(deftest cons.28 - (cddr '(a b . c)) - c) - -(deftest cons.29 - (caaar '(((a)))) - a) - -(deftest cons.30 - (cdaar '(((a . b)))) - b) - -(deftest cons.31 - (cadar (cons (cons 'a (cons 'b 'c)) 'd)) - b) - -(deftest cons.32 - (cddar (cons (cons 'a (cons 'b 'c)) 'd)) - c) - -(deftest cons.33 - (caadr (cons 'a (cons (cons 'b 'c) 'd))) - b) - -(deftest cons.34 - (caddr (cons 'a (cons 'b (cons 'c 'd)))) - c) - -(deftest cons.36 - (cdadr (cons 'a (cons (cons 'b 'c) 'd))) - c) - -(deftest cons.37 - (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))))) - - -(deftest cons.38 - (caaaar *cons-test-4*) - a) - -(deftest cons.39 - (cdaaar *cons-test-4*) - b) - -(deftest cons.40 - (cadaar *cons-test-4*) - c) - -(deftest cons.41 - (cddaar *cons-test-4*) - d) - -(deftest cons.42 - (caadar *cons-test-4*) - e) - -(deftest cons.43 - (cdadar *cons-test-4*) - f) - -(deftest cons.44 - (caddar *cons-test-4*) - g) - -(deftest cons.45 - (cdddar *cons-test-4*) - h) - -;;; - -(deftest cons.46 - (caaadr *cons-test-4*) - i) - -(deftest cons.47 - (cdaadr *cons-test-4*) - j) - -(deftest cons.48 - (cadadr *cons-test-4*) - k) - -(deftest cons.49 - (cddadr *cons-test-4*) - l) - -(deftest cons.50 - (caaddr *cons-test-4*) - m) - -(deftest cons.51 - (cdaddr *cons-test-4*) - n) - -(deftest cons.52 - (cadddr *cons-test-4*) - o) - -(deftest cons.53 - (cddddr *cons-test-4*) - p) - -(deftest cons.error.1 - (classify-error (cons)) - program-error) - -(deftest cons.error.2 - (classify-error (cons 'a)) - program-error) - -(deftest cons.error.3 - (classify-error (cons 'a 'b 'c)) - program-error) - -;; 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) - -(deftest rplaca.order.1 - (let ((x (cons 'a 'b)) - (i 0) a b) - (values - (rplaca (progn (setf a (incf i)) x) - (progn (setf b (incf i)) 'c)) - i a b)) - (c . b) 2 1 2) - -(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) - -(deftest rplacd.order.1 - (let ((x (cons 'a 'b)) - (i 0) a b) - (values - (rplacd (progn (setf a (incf i)) x) - (progn (setf b (incf i)) 'c)) - i a b)) - (a . c) 2 1 2) - -;; rplaca on a fixnum is a type error -(deftest rplaca.error.1 - (loop for x in *universe* - thereis (and (not (consp x)) - (not (eq (catch-type-error (rplaca x 1)) 'type-error)))) - nil) - -(deftest rplaca.error.2 - (classify-error (rplaca)) - program-error) - -(deftest rplaca.error.3 - (classify-error (rplaca (cons 'a 'b))) - program-error) - -(deftest rplaca.error.4 - (classify-error (rplaca (cons 'a 'b) (cons 'c 'd) 'garbage)) - program-error) - -(deftest rplaca.error.5 - (classify-error (rplaca 'a 1)) - type-error) - -(deftest rplaca.error.6 - (classify-error (locally (rplaca 'a 1) t)) - type-error) - -;; rplacd on a fixnum is a type error -(deftest rplacd.error.1 - (loop for x in *universe* - thereis (and (not (consp x)) - (not (eq (catch-type-error (rplacd x 1)) 'type-error)))) - nil) - -(deftest rplacd.error.2 - (classify-error (rplacd)) - program-error) - -(deftest rplacd.error.3 - (classify-error (rplacd (cons 'a 'b))) - program-error) - -(deftest rplacd.error.4 - (classify-error (rplacd (cons 'a 'b) (cons 'c 'd) 'garbage)) - program-error) - -(deftest rplacd.error.5 - (classify-error (rplacd 'a 1)) - type-error) - -(deftest rplacd.error.6 - (classify-error (locally (rplacd 'a 1) t)) - type-error) diff --git a/ansi-tests/cons-test-02.lsp b/ansi-tests/cons-test-02.lsp deleted file mode 100644 index a018bc1e6fbcf53b4c6cc89b6a2b53f95d4e9254..0000000000000000000000000000000000000000 --- a/ansi-tests/cons-test-02.lsp +++ /dev/null @@ -1,1127 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:30:50 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 2 - -(in-package :cl-test) - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; copy-tree - -;; Try copy-tree on a tree containing elements of various kinds -(deftest copy-tree.1 - (let ((x (cons 'a (list (cons 'b 'c) - (cons 1 1.2) - (list (list "abcde" - (make-array '(10) :initial-element (cons 'e 'f))) - 'g))))) - (let ((y (copy-tree x))) - (check-cons-copy x y))) - t) - -;; Try copy-tree on *universe* -(deftest copy-tree.2 - (let* ((x (copy-list *universe*)) - (y (copy-tree x))) - (check-cons-copy x y)) - t) - -(deftest copy-tree.order.1 - (let ((i 0)) - (values - (copy-tree (progn (incf i) '(a b c))) - i)) - (a b c) 1) - -(deftest copy-tree.error.1 - (classify-error (copy-tree)) - program-error) - -(deftest copy-tree.error.2 - (classify-error (copy-tree 'a 'b)) - program-error) - -;;; - -(deftest sublis.1 - (check-sublis '((a b) g (d e 10 g h) 15 . g) - '((e . e2) (g . 17))) - ((a b) 17 (d e2 10 17 h) 15 . 17)) - -(deftest sublis.2 - (check-sublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) - '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) - :test #'equal) - (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b)))) - -(deftest sublis.3 - (check-sublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) - '((30 . "foo"))) - (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) - -(deftest sublis.4 - (check-sublis (sublis - (copy-tree '((a . 2) (b . 4) (c . 1))) - (copy-tree '(a b c d e (a b c a d b) f))) - '((t . "yes")) - :key #'(lambda (x) (and (typep x 'integer) - (evenp x)))) - ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) - -(deftest sublis.5 - (check-sublis '("fee" (("fee" "Fie" "foo")) - fie ("fee" "fie")) - `((,(copy-seq "fie") . #\f))) - ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) - -(deftest sublis.6 - (check-sublis '("fee" fie (("fee" "Fie" "foo") 1) - ("fee" "fie")) - `((,(copy-seq "fie") . #\f)) - :test 'equal) - ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) - -(deftest sublis.7 - (check-sublis '(("aa" a b) - (z "bb" d) - ((x . "aa"))) - `((,(copy-seq "aa") . 1) - (,(copy-seq "bb") . 2)) - :test 'equal - :key #'(lambda (x) (if (consp x) (car x) - '*not-present*))) - (1 (z . 2) ((x . "aa")))) - -;; Check that a null key arg is ignored. - -(deftest sublis.8 - (check-sublis - '(1 2 a b) - '((1 . 2) (a . b)) - :key nil) - (2 2 b b)) - -;;; Order of argument evaluation -(deftest sublis.order.1 - (let ((i 0) w x y z) - (values - (sublis - (progn (setf w (incf i)) - '((a . z))) - (progn (setf x (incf i)) - (copy-tree '(a b c d))) - :test (progn (setf y (incf i)) #'eql) - :key (progn (setf z (incf i)) #'identity)) - i w x y z)) - (z b c d) - 4 1 2 3 4) - -(deftest sublis.order.2 - (let ((i 0) w x y z) - (values - (sublis - (progn (setf w (incf i)) - '((a . z))) - (progn (setf x (incf i)) - (copy-tree '(a b c d))) - :key (progn (setf y (incf i)) #'identity) - :test-not (progn (setf z (incf i)) (complement #'eql)) - ) - i w x y z)) - (z b c d) - 4 1 2 3 4) - - -;;; Keyword tests - -(deftest sublis.allow-other-keys.1 - (sublis nil 'a :bad t :allow-other-keys t) - a) - -(deftest sublis.allow-other-keys.2 - (sublis nil 'a :allow-other-keys t :bad t) - a) - -(deftest sublis.allow-other-keys.3 - (sublis nil 'a :allow-other-keys t) - a) - -(deftest sublis.allow-other-keys.4 - (sublis nil 'a :allow-other-keys nil) - a) - -(deftest sublis.allow-other-keys.5 - (sublis nil 'a :allow-other-keys t :allow-other-keys t :bad t) - a) - -(deftest sublis.keywords.6 - (sublis '((1 . a)) (list 0 1 2) :key #'(lambda (x) (if (numberp x) (1+ x) x)) - :key #'identity) - (a 1 2)) - - -;; Argument error cases - -(deftest sublis.error.1 - (classify-error (sublis)) - program-error) - -(deftest sublis.error.2 - (classify-error (sublis nil)) - program-error) - -(deftest sublis.error.3 - (classify-error (sublis nil 'a :test)) - program-error) - -(deftest sublis.error.4 - (classify-error (sublis nil 'a :bad-keyword t)) - program-error) - -(deftest sublis.error.5 - (classify-error (sublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :test #'identity)) - program-error) - -(deftest sublis.error.6 - (classify-error (sublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :key #'cons)) - program-error) - -(deftest sublis.error.7 - (classify-error (sublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :test-not #'identity)) - program-error) - -(deftest sublis.error.8 - (classify-error (sublis '((a . 1) . bad) - (list 'a 'b 'c 'd))) - type-error) - -;; nsublis - -(deftest nsublis.1 - (check-nsublis '((a b) g (d e 10 g h) 15 . g) - '((e . e2) (g . 17))) - ((a b) 17 (d e2 10 17 h) 15 . 17)) - -(deftest nsublis.2 - (check-nsublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) - '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) - :test #'equal) - (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b)))) - -(deftest nsublis.3 - (check-nsublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) - '((30 . "foo"))) - (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) - -(deftest nsublis.4 - (check-nsublis - (nsublis (copy-tree '((a . 2) (b . 4) (c . 1))) - (copy-tree '(a b c d e (a b c a d b) f))) - '((t . "yes")) - :key #'(lambda (x) (and (typep x 'integer) - (evenp x)))) - ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) - -(deftest nsublis.5 - (check-nsublis '("fee" (("fee" "Fie" "foo")) - fie ("fee" "fie")) - `((,(copy-seq "fie") . #\f))) - ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) - -(deftest nsublis.6 - (check-nsublis '("fee" fie (("fee" "Fie" "foo") 1) - ("fee" "fie")) - `((,(copy-seq "fie") . #\f)) - :test 'equal) - ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) - -(deftest nsublis.7 - (check-nsublis '(("aa" a b) - (z "bb" d) - ((x . "aa"))) - `((,(copy-seq "aa") . 1) - (,(copy-seq "bb") . 2)) - :test 'equal - :key #'(lambda (x) (if (consp x) (car x) - '*not-present*))) - (1 (z . 2) ((x . "aa")))) - -(deftest nsublis.8 - (nsublis nil 'a :bad-keyword t :allow-other-keys t) - a) - -;; Check that a null key arg is ignored. - -(deftest nsublis.9 - (check-nsublis - '(1 2 a b) - '((1 . 2) (a . b)) - :key nil) - (2 2 b b)) - -;;; Order of argument evaluation -(deftest nsublis.order.1 - (let ((i 0) w x y z) - (values - (nsublis - (progn (setf w (incf i)) - '((a . z))) - (progn (setf x (incf i)) - (copy-tree '(a b c d))) - :test (progn (setf y (incf i)) #'eql) - :key (progn (setf z (incf i)) #'identity)) - i w x y z)) - (z b c d) - 4 1 2 3 4) - -(deftest nsublis.order.2 - (let ((i 0) w x y z) - (values - (nsublis - (progn (setf w (incf i)) - '((a . z))) - (progn (setf x (incf i)) - (copy-tree '(a b c d))) - :key (progn (setf y (incf i)) #'identity) - :test-not (progn (setf z (incf i)) (complement #'eql)) - ) - i w x y z)) - (z b c d) - 4 1 2 3 4) - -;;; Keyword tests - -(deftest nsublis.allow-other-keys.1 - (nsublis nil 'a :bad t :allow-other-keys t) - a) - -(deftest nsublis.allow-other-keys.2 - (nsublis nil 'a :allow-other-keys t :bad t) - a) - -(deftest nsublis.allow-other-keys.3 - (nsublis nil 'a :allow-other-keys t) - a) - -(deftest nsublis.allow-other-keys.4 - (nsublis nil 'a :allow-other-keys nil) - a) - -(deftest nsublis.allow-other-keys.5 - (nsublis nil 'a :allow-other-keys t :allow-other-keys t :bad t) - a) - -(deftest nsublis.keywords.6 - (nsublis '((1 . a)) (list 0 1 2) - :key #'(lambda (x) (if (numberp x) (1+ x) x)) - :key #'identity) - (a 1 2)) - -;; Argument error cases - -(deftest nsublis.error.1 - (classify-error (nsublis)) - program-error) - -(deftest nsublis.error.2 - (classify-error (nsublis nil)) - program-error) - -(deftest nsublis.error.3 - (classify-error (nsublis nil 'a :test)) - program-error) - -(deftest nsublis.error.4 - (classify-error (nsublis nil 'a :bad-keyword t)) - program-error) - -(deftest nsublis.error.5 - (classify-error (nsublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :test #'identity)) - program-error) - -(deftest nsublis.error.6 - (classify-error (nsublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :key #'cons)) - program-error) - -(deftest nsublis.error.7 - (classify-error (nsublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :test-not #'identity)) - program-error) - -(deftest nsublis.error.8 - (classify-error (nsublis '((a . 1) . bad) - (list 'a 'b 'c 'd))) - type-error) - -;;;;;; - -(deftest sublis.shared - (let* ((shared-piece (list 'a 'b)) - (a (list shared-piece shared-piece))) - (check-sublis a '((a . b) (b . a)))) - ((b a) (b a))) - -(defvar *subst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) - -(deftest subst.1 - (check-subst "Z" 30 (copy-tree *subst-tree-1*)) - (10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) - -(deftest subst.2 - (check-subst "A" 0 (copy-tree *subst-tree-1*)) - (10 (30 20 10) (20 10) (10 20 30 40))) - -(deftest subst.3 - (check-subst "Z" 100 (copy-tree *subst-tree-1*) :test-not #'eql) - "Z") - -(deftest subst.4 - (check-subst 'grape 'dick - '(melville wrote (moby dick))) - (melville wrote (moby grape))) - -(deftest subst.5 - (check-subst 'cha-cha-cha 'nil '(melville wrote (moby dick))) - (melville wrote (moby dick . cha-cha-cha) . cha-cha-cha)) - -(deftest subst.6 - (check-subst - '(1 2) '(foo . bar) - '((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) - :test #'equal) - ((foo . baz) (1 2) (bar . foo) (baz 1 2))) - -(deftest subst.7 - (check-subst - 'foo "aaa" - '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) - :key #'(lambda (x) (if (and (numberp x) (evenp x)) - "aaa" - nil)) - :test #'string=) - ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) - -(deftest subst.8 - (check-subst - 'foo nil - '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) - :key #'(lambda (x) (if (and (numberp x) (evenp x)) - (copy-seq "aaa") - nil)) - :test-not #'equal) - ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) - -(deftest subst.9 - (check-subst 'a 'b - (copy-tree '(a b c d a b)) - :key nil) - (a a c d a a)) - -;;; Order of argument evaluation -(deftest subst.order.1 - (let ((i 0) v w x y z) - (values - (subst (progn (setf v (incf i)) 'b) - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) - :key (progn (setf y (incf i)) #'identity) - :test (progn (setf z (incf i)) #'eql)) - i v w x y z)) - ((10 b . b) b b c ((b)) z) - 5 1 2 3 4 5) - -(deftest subst.order.2 - (let ((i 0) v w x y z) - (values - (subst (progn (setf v (incf i)) 'b) - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) - :test-not (progn (setf y (incf i)) (complement #'eql)) - :key (progn (setf z (incf i)) #'identity) - ) - i v w x y z)) - ((10 b . b) b b c ((b)) z) - 5 1 2 3 4 5) - - - -;;; Keyword tests for subst - -(deftest subst.allow-other-keys.1 - (subst 'a 'b (list 'a 'b 'c) :bad t :allow-other-keys t) - (a a c)) - -(deftest subst.allow-other-keys.2 - (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t) - (a a c)) - -(deftest subst.allow-other-keys.3 - (subst 'a 'b (list 'a 'b 'c) :allow-other-keys nil) - (a a c)) - -(deftest subst.allow-other-keys.4 - (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t :bad t) - (a a c)) - -(deftest subst.allow-other-keys.5 - (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t :allow-other-keys nil - :bad t) - (a a c)) - -(deftest subst.keywords.6 - (subst 'a 'b (list 'a 'b 'c) :test #'eq :test (complement #'eq)) - (a a c)) - - -;;; Tests for subst-if, subst-if-not - -(deftest subst-if.1 - (check-subst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) - a) - -(deftest subst-if-not.1 - (check-subst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) - ((x) - ((x) (x) x) - ((x) (x) (x) x) - ((x) (x) (x) (x) x) - x)) - -(deftest subst-if.2 - (check-subst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) - (17 (17 17) (17 17 17) (17 nil 17 17 17))) - -(deftest subst-if.3 - (check-subst-if '(z) - (complement #'consp) - '(a (a b) (c d e) (f g h i))) - ((z) - ((z) (z) z) - ((z) (z) (z) z) - ((z) (z) (z) (z) z) - z)) - -(deftest subst-if-not.2 - (check-subst-if-not 'a (complement #'listp) - '((100 1) (2 3) (4 3 2 1) (a b c))) - a) - -(deftest subst-if.4 - (check-subst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) - :key #'listp) - b) - -(deftest subst-if-not.3 - (check-subst-if-not 'c #'identity - '((100 1) (2 3) (4 3 2 1) (a b c)) - :key (complement #'listp)) - c) - -(deftest subst-if.5 - (check-subst-if 4 #'(lambda (x) (eql x 1)) - '((1 3) (1) (1 10 20 30) (1 3 x y)) - :key #'(lambda (x) - (and (consp x) - (car x)))) - (4 4 4 4)) - -(deftest subst-if-not.4 - (check-subst-if-not - 40 - #'(lambda (x) (not (eql x 17))) - '((17) (17 22) (17 22 31) (17 21 34 54)) - :key #'(lambda (x) - (and (consp x) - (car x)))) - (40 40 40 40)) - -(deftest subst-if.6 - (check-subst-if 'a #'(lambda (x) (eql x 'b)) - '((a) (b) (c) (d)) - :key nil) - ((a) (a) (c) (d))) - -(deftest subst-if-not.5 - (check-subst-if-not 'a #'(lambda (x) (not (eql x 'b))) - '((a) (b) (c) (d)) - :key nil) - ((a) (a) (c) (d))) - -(deftest subst-if.7 - (let ((i 0) w x y z) - (values - (subst-if - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) #'(lambda (x) (eql x 'b))) - (progn (setf y (incf i)) (copy-list '(1 2 a b c))) - :key (progn (setf z (incf i)) #'identity)) - i w x y z)) - (1 2 a a c) - 4 1 2 3 4) - -(deftest subst-if-not.7 - (let ((i 0) w x y z) - (values - (subst-if-not - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) #'(lambda (x) (not (eql x 'b)))) - (progn (setf y (incf i)) (copy-list '(1 2 a b c))) - :key (progn (setf z (incf i)) #'identity)) - i w x y z)) - (1 2 a a c) - 4 1 2 3 4) - - - -;;; Keyword tests for subst-if - -(deftest subst-if.allow-other-keys.1 - (subst-if 'a #'null nil :bad t :allow-other-keys t) - a) - -(deftest subst-if.allow-other-keys.2 - (subst-if 'a #'null nil :allow-other-keys t) - a) - -(deftest subst-if.allow-other-keys.3 - (subst-if 'a #'null nil :allow-other-keys nil) - a) - -(deftest subst-if.allow-other-keys.4 - (subst-if 'a #'null nil :allow-other-keys t :bad t) - a) - -(deftest subst-if.allow-other-keys.5 - (subst-if 'a #'null nil :allow-other-keys t :allow-other-keys nil :bad t) - a) - -(deftest subst-if.keywords.6 - (subst-if 'a #'null nil :key nil :key (constantly 'b)) - a) - -;;; Keywords tests for subst-if-not - -(deftest subst-if-not.allow-other-keys.1 - (subst-if-not 'a #'identity nil :bad t :allow-other-keys t) - a) - -(deftest subst-if-not.allow-other-keys.2 - (subst-if-not 'a #'identity nil :allow-other-keys t) - a) - -(deftest subst-if-not.allow-other-keys.3 - (subst-if-not 'a #'identity nil :allow-other-keys nil) - a) - -(deftest subst-if-not.allow-other-keys.4 - (subst-if-not 'a #'identity nil :allow-other-keys t :bad t) - a) - -(deftest subst-if-not.allow-other-keys.5 - (subst-if-not 'a #'identity nil :allow-other-keys t :allow-other-keys nil :bad t) - a) - -(deftest subst-if-not.keywords.6 - (subst-if-not 'a #'identity nil :key nil :key (constantly 'b)) - a) - - -(defvar *nsubst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) - -(deftest nsubst.1 - (check-nsubst "Z" 30 (copy-tree *nsubst-tree-1*)) - (10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) - -(deftest nsubst.2 - (check-nsubst "A" 0 (copy-tree *nsubst-tree-1*)) - (10 (30 20 10) (20 10) (10 20 30 40))) - -(deftest nsubst.3 - (check-nsubst "Z" 100 (copy-tree *nsubst-tree-1*) :test-not #'eql) - "Z") - -(deftest nsubst.4 - (check-nsubst 'grape 'dick - '(melville wrote (moby dick))) - (melville wrote (moby grape))) - -(deftest nsubst.5 - (check-nsubst 'cha-cha-cha 'nil '(melville wrote (moby dick))) - (melville wrote (moby dick . cha-cha-cha) . cha-cha-cha)) - -(deftest nsubst.6 - (check-nsubst - '(1 2) '(foo . bar) - '((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) - :test #'equal) - ((foo . baz) (1 2) (bar . foo) (baz 1 2))) - -(deftest nsubst.7 - (check-nsubst - 'foo "aaa" - '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) - :key #'(lambda (x) (if (and (numberp x) (evenp x)) - "aaa" - nil)) - :test #'string=) - ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) - -(deftest nsubst.8 - (check-nsubst - 'foo nil - '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) - :key #'(lambda (x) (if (and (numberp x) (evenp x)) - (copy-seq "aaa") - nil)) - :test-not #'equal) - ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) - -(deftest nsubst.9 - (check-nsubst 'a 'b - (copy-tree '(a b c d a b)) - :key nil) - (a a c d a a)) - -;;; Order of argument evaluation -(deftest nsubst.order.1 - (let ((i 0) v w x y z) - (values - (nsubst (progn (setf v (incf i)) 'b) - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) - :key (progn (setf y (incf i)) #'identity) - :test (progn (setf z (incf i)) #'eql)) - i v w x y z)) - ((10 b . b) b b c ((b)) z) - 5 1 2 3 4 5) - -(deftest nsubst.order.2 - (let ((i 0) v w x y z) - (values - (nsubst (progn (setf v (incf i)) 'b) - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) - :test-not (progn (setf y (incf i)) (complement #'eql)) - :key (progn (setf z (incf i)) #'identity) - ) - i v w x y z)) - ((10 b . b) b b c ((b)) z) - 5 1 2 3 4 5) - -;;; Keyword tests for nsubst - -(deftest nsubst.allow-other-keys.1 - (nsubst 'a 'b (list 'a 'b 'c) :bad t :allow-other-keys t) - (a a c)) - -(deftest nsubst.allow-other-keys.2 - (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t) - (a a c)) - -(deftest nsubst.allow-other-keys.3 - (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys nil) - (a a c)) - -(deftest nsubst.allow-other-keys.4 - (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t :bad t) - (a a c)) - -(deftest nsubst.allow-other-keys.5 - (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t :allow-other-keys nil - :bad t) - (a a c)) - -(deftest nsubst.keywords.6 - (nsubst 'a 'b (list 'a 'b 'c) :test #'eq :test (complement #'eq)) - (a a c)) - -;;; Tests for nsubst-if, nsubst-if-not - -(deftest nsubst-if.1 - (check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) - a) - -(deftest nsubst-if-not.1 - (check-nsubst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) - ((x) - ((x) (x) x) - ((x) (x) (x) x) - ((x) (x) (x) (x) x) - x)) - -(deftest nsubst-if.2 - (check-nsubst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) - (17 (17 17) (17 17 17) (17 nil 17 17 17))) - -(deftest nsubst-if.3 - (check-nsubst-if '(z) - (complement #'consp) - '(a (a b) (c d e) (f g h i))) - ((z) - ((z) (z) z) - ((z) (z) (z) z) - ((z) (z) (z) (z) z) - z)) - -(deftest nsubst-if-not.2 - (check-nsubst-if-not 'a (complement #'listp) - '((100 1) (2 3) (4 3 2 1) (a b c))) - a) - -(deftest nsubst-if.4 - (check-nsubst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) - :key #'listp) - b) - -(deftest nsubst-if-not.3 - (check-nsubst-if-not 'c #'identity - '((100 1) (2 3) (4 3 2 1) (a b c)) - :key (complement #'listp)) - c) - -(deftest nsubst-if.5 - (check-nsubst-if 4 #'(lambda (x) (eql x 1)) - '((1 3) (1) (1 10 20 30) (1 3 x y)) - :key #'(lambda (x) - (and (consp x) - (car x)))) - (4 4 4 4)) - -(deftest nsubst-if-not.4 - (check-nsubst-if-not - 40 - #'(lambda (x) (not (eql x 17))) - '((17) (17 22) (17 22 31) (17 21 34 54)) - :key #'(lambda (x) - (and (consp x) - (car x)))) - (40 40 40 40)) - -(deftest nsubst-if.6 - (check-nsubst-if 'a #'(lambda (x) (eql x 'b)) - '((a) (b) (c) (d)) - :key nil) - ((a) (a) (c) (d))) - -(deftest nsubst-if-not.5 - (check-nsubst-if-not 'a #'(lambda (x) (not (eql x 'b))) - '((a) (b) (c) (d)) - :key nil) - ((a) (a) (c) (d))) - -(deftest nsubst-if.7 - (nsubst-if 'a #'null nil :bad t :allow-other-keys t) - a) - -(deftest nsubst-if-not.6 - (nsubst-if-not 'a #'null nil :bad t :allow-other-keys t) - nil) - -(deftest nsubst-if.8 - (let ((i 0) w x y z) - (values - (nsubst-if - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) #'(lambda (x) (eql x 'b))) - (progn (setf y (incf i)) (copy-list '(1 2 a b c))) - :key (progn (setf z (incf i)) #'identity)) - i w x y z)) - (1 2 a a c) - 4 1 2 3 4) - -(deftest nsubst-if-not.7 - (let ((i 0) w x y z) - (values - (nsubst-if-not - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) #'(lambda (x) (not (eql x 'b)))) - (progn (setf y (incf i)) (copy-list '(1 2 a b c))) - :key (progn (setf z (incf i)) #'identity)) - i w x y z)) - (1 2 a a c) - 4 1 2 3 4) - -;;; Keyword tests for nsubst-if - -(deftest nsubst-if.allow-other-keys.1 - (nsubst-if 'a #'null nil :bad t :allow-other-keys t) - a) - -(deftest nsubst-if.allow-other-keys.2 - (nsubst-if 'a #'null nil :allow-other-keys t) - a) - -(deftest nsubst-if.allow-other-keys.3 - (nsubst-if 'a #'null nil :allow-other-keys nil) - a) - -(deftest nsubst-if.allow-other-keys.4 - (nsubst-if 'a #'null nil :allow-other-keys t :bad t) - a) - -(deftest nsubst-if.allow-other-keys.5 - (nsubst-if 'a #'null nil :allow-other-keys t :allow-other-keys nil :bad t) - a) - -(deftest nsubst-if.keywords.6 - (nsubst-if 'a #'null nil :key nil :key (constantly 'b)) - a) - -;;; Keywords tests for nsubst-if-not - -(deftest nsubst-if-not.allow-other-keys.1 - (nsubst-if-not 'a #'identity nil :bad t :allow-other-keys t) - a) - -(deftest nsubst-if-not.allow-other-keys.2 - (nsubst-if-not 'a #'identity nil :allow-other-keys t) - a) - -(deftest nsubst-if-not.allow-other-keys.3 - (nsubst-if-not 'a #'identity nil :allow-other-keys nil) - a) - -(deftest nsubst-if-not.allow-other-keys.4 - (nsubst-if-not 'a #'identity nil :allow-other-keys t :bad t) - a) - -(deftest nsubst-if-not.allow-other-keys.5 - (nsubst-if-not 'a #'identity nil :allow-other-keys t :allow-other-keys nil :bad t) - a) - -(deftest nsubst-if-not.keywords.6 - (nsubst-if-not 'a #'identity nil :key nil :key (constantly 'b)) - a) - -;;; Error cases - -;;; subst -(deftest subst.error.1 - (classify-error (subst)) - program-error) - -(deftest subst.error.2 - (classify-error (subst 'a)) - program-error) - -(deftest subst.error.3 - (classify-error (subst 'a 'b)) - program-error) - -(deftest subst.error.4 - (classify-error (subst 'a 'b nil :foo nil)) - program-error) - -(deftest subst.error.5 - (classify-error (subst 'a 'b nil :test)) - program-error) - -(deftest subst.error.6 - (classify-error (subst 'a 'b nil 1)) - program-error) - -(deftest subst.error.7 - (classify-error (subst 'a 'b nil :bad t :allow-other-keys nil)) - program-error) - -(deftest subst.error.8 - (classify-error (subst 'a 'b (list 'a 'b) :test #'identity)) - program-error) - -(deftest subst.error.9 - (classify-error (subst 'a 'b (list 'a 'b) :test-not #'identity)) - program-error) - -(deftest subst.error.10 - (classify-error (subst 'a 'b (list 'a 'b) :key #'equal)) - program-error) - -;;; nsubst -(deftest nsubst.error.1 - (classify-error (nsubst)) - program-error) - -(deftest nsubst.error.2 - (classify-error (nsubst 'a)) - program-error) - -(deftest nsubst.error.3 - (classify-error (nsubst 'a 'b)) - program-error) - -(deftest nsubst.error.4 - (classify-error (nsubst 'a 'b nil :foo nil)) - program-error) - -(deftest nsubst.error.5 - (classify-error (nsubst 'a 'b nil :test)) - program-error) - -(deftest nsubst.error.6 - (classify-error (nsubst 'a 'b nil 1)) - program-error) - -(deftest nsubst.error.7 - (classify-error (nsubst 'a 'b nil :bad t :allow-other-keys nil)) - program-error) - -(deftest nsubst.error.8 - (classify-error (nsubst 'a 'b (list 'a 'b) :test #'identity)) - program-error) - -(deftest nsubst.error.9 - (classify-error (nsubst 'a 'b (list 'a 'b) :test-not #'identity)) - program-error) - -(deftest nsubst.error.10 - (classify-error (nsubst 'a 'b (list 'a 'b) :key #'equal)) - program-error) - -;;; subst-if -(deftest subst-if.error.1 - (classify-error (subst-if)) - program-error) - -(deftest subst-if.error.2 - (classify-error (subst-if 'a)) - program-error) - -(deftest subst-if.error.3 - (classify-error (subst-if 'a #'null)) - program-error) - -(deftest subst-if.error.4 - (classify-error (subst-if 'a #'null nil :foo nil)) - program-error) - -(deftest subst-if.error.5 - (classify-error (subst-if 'a #'null nil :test)) - program-error) - -(deftest subst-if.error.6 - (classify-error (subst-if 'a #'null nil 1)) - program-error) - -(deftest subst-if.error.7 - (classify-error (subst-if 'a #'null nil :bad t :allow-other-keys nil)) - program-error) - -(deftest subst-if.error.8 - (classify-error (subst-if 'a #'null (list 'a nil 'c) :key #'cons)) - program-error) - -;;; subst-if-not -(deftest subst-if-not.error.1 - (classify-error (subst-if-not)) - program-error) - -(deftest subst-if-not.error.2 - (classify-error (subst-if-not 'a)) - program-error) - -(deftest subst-if-not.error.3 - (classify-error (subst-if-not 'a #'null)) - program-error) - -(deftest subst-if-not.error.4 - (classify-error (subst-if-not 'a #'null nil :foo nil)) - program-error) - -(deftest subst-if-not.error.5 - (classify-error (subst-if-not 'a #'null nil :test)) - program-error) - -(deftest subst-if-not.error.6 - (classify-error (subst-if-not 'a #'null nil 1)) - program-error) - -(deftest subst-if-not.error.7 - (classify-error (subst-if-not 'a #'null nil - :bad t :allow-other-keys nil)) - program-error) - -(deftest subst-if-not.error.8 - (classify-error (subst-if-not 'a #'null (list 'a nil 'c) :key #'cons)) - program-error) - -;;; nsubst-if -(deftest nsubst-if.error.1 - (classify-error (nsubst-if)) - program-error) - -(deftest nsubst-if.error.2 - (classify-error (nsubst-if 'a)) - program-error) - -(deftest nsubst-if.error.3 - (classify-error (nsubst-if 'a #'null)) - program-error) - -(deftest nsubst-if.error.4 - (classify-error (nsubst-if 'a #'null nil :foo nil)) - program-error) - -(deftest nsubst-if.error.5 - (classify-error (nsubst-if 'a #'null nil :test)) - program-error) - -(deftest nsubst-if.error.6 - (classify-error (nsubst-if 'a #'null nil 1)) - program-error) - -(deftest nsubst-if.error.7 - (classify-error (nsubst-if 'a #'null nil :bad t :allow-other-keys nil)) - program-error) - -(deftest nsubst-if.error.8 - (classify-error (nsubst-if 'a #'null (list 'a nil 'c) :key #'cons)) - program-error) - - -;;; nsubst-if-not -(deftest nsubst-if-not.error.1 - (classify-error (nsubst-if-not)) - program-error) - -(deftest nsubst-if-not.error.2 - (classify-error (nsubst-if-not 'a)) - program-error) - -(deftest nsubst-if-not.error.3 - (classify-error (nsubst-if-not 'a #'null)) - program-error) - -(deftest nsubst-if-not.error.4 - (classify-error (nsubst-if-not 'a #'null nil :foo nil)) - program-error) - -(deftest nsubst-if-not.error.5 - (classify-error (nsubst-if-not 'a #'null nil :test)) - program-error) - -(deftest nsubst-if-not.error.6 - (classify-error (nsubst-if-not 'a #'null nil 1)) - program-error) - -(deftest nsubst-if-not.error.7 - (classify-error (nsubst-if-not 'a #'null nil - :bad t :allow-other-keys nil)) - program-error) - -(deftest nsubst-if-not.error.8 - (classify-error (nsubst-if-not 'a #'null (list 'a nil 'c) :key #'cons)) - program-error) - diff --git a/ansi-tests/cons-test-03.lsp b/ansi-tests/cons-test-03.lsp index 43ddb610e6aa1bcb0e5aba727f69523e7c8be151..1aa54ccc1eae1c3610e8abe67fb3c09358165f3f 100644 --- a/ansi-tests/cons-test-03.lsp +++ b/ansi-tests/cons-test-03.lsp @@ -5,199 +5,6 @@ (in-package :cl-test) -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; copy-list - -(deftest copy-list.1 - (check-copy-list '(a b c d)) - (a b c d)) - -;; Check that copy-list works on dotted lists - -(deftest copy-list.2 - (check-copy-list '(a . b)) - (a . b)) - -(deftest copy-list.3 - (check-copy-list '(a b c . d)) - (a b c . d)) - -(deftest copy-list.4 - (let ((i 0)) - (values (copy-list (progn (incf i) '(a b c))) - i)) - (a b c) 1) - -(deftest copy-list.error.1 - (classify-error (copy-list)) - program-error) - -(deftest copy-list.error.2 - (classify-error (copy-list nil nil)) - program-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; list, list* - -(deftest list.1 - (list 'a 'b 'c) - (a b c)) - -(deftest list.2 - (list) - nil) - -(deftest list.order.1 - (let ((i 0)) - (list (incf i) (incf i) (incf i) (incf i))) - (1 2 3 4)) - -(deftest list.order.2 - (let ((i 0)) - (list (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i))) - (1 2 3 4 5 6 7 8)) - -(deftest list.order.3 - (let ((i 0)) - (list (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i))) - (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)) - -(deftest list*.1 - (list* 1 2 3) - (1 2 . 3)) - -(deftest list*.2 - (list* 'a) - a) - -(deftest list-list*.1 - (list* 'a 'b 'c (list 'd 'e 'f)) - (a b c d e f)) - -(deftest list*.3 - (list* 1) - 1) - -(deftest list*.order.1 - (let ((i 0)) - (list* (incf i) (incf i) (incf i) (incf i))) - (1 2 3 . 4)) - -(deftest list*.order.2 - (let ((i 0)) - (list* (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i))) - (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 . 16)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; list-length - -(deftest list-length-nil - (list-length nil) - 0) - -(deftest list-length-list - (list-length '(a b c d e f)) - 6) - -;; check that list-length returns nil -;; on a circular list - -(deftest list-length-circular-list - (let ((x (cons nil nil))) - (let ((y (list* 1 2 3 4 5 6 7 8 9 x))) - (setf (cdr x) y) - (let ((z (list* 'a 'b 'c 'd 'e y))) - (list-length z)))) - nil) - -(deftest list-length.order.1 - (let ((i 0)) - (values (list-length (progn (incf i) '(a b c))) i)) - 3 1) - - -;; Check that list-length produces a type-error -;; on arguments that are not proper lists or circular lists - -(deftest list-length.error.1 - (loop - for x in (list 'a 1 1.0 #\w (make-array '(10)) - '(a b . c) (symbol-package 'cons)) - count (not (eqt (catch-type-error (list-length x)) - 'type-error))) - 0) - -(deftest list-length.error.2 - (classify-error (list-length)) - program-error) - -(deftest list-length.error.3 - (classify-error (list-length nil nil)) - program-error) - -(deftest list-length.error.4 - (classify-error (list-length 'a)) - type-error) - -(deftest list-length.error.5 - (classify-error (locally (list-length 'a) t)) - type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; listp - -;; Check listp against various simple cases - -(deftest listp-nil - (notnot-mv (listp nil)) - t) - -(deftest listp-symbol - (listp 'a) - nil) - -(deftest listp-singleton-list - (notnot-mv (listp '(a))) - t) - -(deftest listp-circular-list - (let ((x (cons nil nil))) - (setf (cdr x) x) - (notnot-mv (listp x))) - t) - -(deftest listp-longer-list - (notnot-mv (listp '(a b c d e f g h))) - t) - -;;; Check that (listp x) == (typep x 'list) - -(deftest listp-universe - (check-type-predicate 'listp 'list) - 0) - -(deftest listp.order.1 - (let ((i 0)) - (values (listp (incf i)) i)) - nil 1) - -(deftest listp.error.1 - (classify-error (listp)) - program-error) - -(deftest listp.error.2 - (classify-error (listp nil nil)) - program-error) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (typep <obj> 'list) @@ -224,102 +31,3 @@ (deftest typep-longer-list-list (notnot-mv (typep '(a b c d e f g h) 'list)) t) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; make-list - -(deftest make-list-empty.1 - (make-list 0) - nil) - -(deftest make-list-empty.2 - (make-list 0 :initial-element 'a) - nil) - -(deftest make-list-no-initial-element - (make-list 6) - (nil nil nil nil nil nil)) - -(deftest make-list-with-initial-element - (make-list 6 :initial-element 'a) - (a a a a a a)) - -(deftest make-list.allow-other-keys.1 - (make-list 5 :allow-other-keys t :foo 'a) - (nil nil nil nil nil)) - -(deftest make-list.allow-other-keys.2 - (make-list 5 :bar nil :allow-other-keys t) - (nil nil nil nil nil)) - -(deftest make-list.allow-other-keys.3 - (make-list 5 :allow-other-keys nil) - (nil nil nil nil nil)) - -(deftest make-list.allow-other-keys.4 - (make-list 5 :allow-other-keys t :allow-other-keys nil 'bad t) - (nil nil nil nil nil)) - -(deftest make-list.allow-other-keys.5 - (make-list 5 :allow-other-keys t) - (nil nil nil nil nil)) - -(deftest make-list-repeated-keyword - (make-list 5 :initial-element 'a :initial-element 'b) - (a a a a a)) - -(deftest make-list.order.1 - (let ((i 0) x y) - (values - (make-list (progn (setf x (incf i)) 5) - :initial-element - (progn (setf y (incf i)) 'a)) - i x y)) - (a a a a a) - 2 1 2) - -(deftest make-list.order.2 - (let ((i 0) x y z) - (values - (make-list (progn (setf x (incf i)) 5) - :initial-element - (progn (setf y (incf i)) 'a) - :initial-element - (progn (setf z (incf i)) 'b)) - i x y z)) - (a a a a a) - 3 1 2 3) - - -(deftest make-list.error.1 - (catch-type-error (make-list -1)) - type-error) - -(deftest make-list.error.2 - (classify-error (make-list 'a)) - type-error) - -(deftest make-list.error.3 - (classify-error (make-list)) - program-error) - -(deftest make-list.error.4 - (classify-error (make-list 5 :bad t)) - program-error) - -(deftest make-list.error.5 - (classify-error (make-list 5 :initial-element)) - program-error) - -(deftest make-list.error.6 - (classify-error (make-list 5 1 2)) - program-error) - -(deftest make-list.error.7 - (classify-error (make-list 5 :bad t :allow-other-keys nil)) - program-error) - -(deftest make-list.error.8 - (classify-error (locally (make-list 'a) t)) - type-error) diff --git a/ansi-tests/cons-test-04.lsp b/ansi-tests/cons-test-04.lsp deleted file mode 100644 index 7162c8409e225d064d518eddc7566048a27ef254..0000000000000000000000000000000000000000 --- a/ansi-tests/cons-test-04.lsp +++ /dev/null @@ -1,417 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:33:20 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 4 - -(in-package :cl-test) - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; push -;;; There will be a separate test suite -;;; for ACCESSORS x SETF-like macros - -;;; See also places.lsp - -(deftest push.1 - (let ((x nil)) - (push 'a x)) - (a)) - -(deftest push.2 - (let ((x 'b)) - (push 'a x) - (push 'c x)) - (c a . b)) - -(deftest push.3 - (let ((x (copy-tree '(a)))) - (push x x) - (and - (eqt (car x) (cdr x)) - x)) - ((a) a)) - -(deftest push.order.1 - (let ((x (list nil)) (i 0) a b) - (values - (push (progn (setf a (incf i)) 'z) - (car (progn (setf b (incf i)) x))) - x - i a b)) - (z) ((z)) 2 1 2) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; pop - -(deftest pop.1 - (let ((x (copy-tree '(a b c)))) - (let ((y (pop x))) - (list x y))) - ((b c) a)) - -(deftest pop.2 - (let ((x nil)) - (let ((y (pop x))) - (list x y))) - (nil nil)) - -;;; Confirm argument is executed just once. -(deftest pop.order.1 - (let ((i 0) - (a (vector (list 'a 'b 'c)))) - (pop (aref a (progn (incf i) 0))) - (values a i)) - #((b c)) 1) - -(deftest push-and-pop - (let* ((x (copy-tree '(a b))) - (y x)) - (push 'c x) - (and - (eqt (cdr x) y) - (pop x))) - c) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; pushnew - -;;; See also places.lsp - -(deftest pushnew.1 - (let ((x nil)) - (let ((y (pushnew 'a x))) - (and - (eqt x y) - (equal x '(a)) - t))) - t) - -(deftest pushnew.2 - (let* ((x (copy-tree '(b c d a k f q))) - (y (pushnew 'a x))) - (and - (eqt x y) - x)) - (b c d a k f q)) - -(deftest pushnew.3 - (let* ((x (copy-tree '(1 2 3 4 5 6 7 8))) - (y (pushnew 7 x))) - (and - (eqt x y) - x)) - (1 2 3 4 5 6 7 8)) - -(deftest pushnew.4 - (let* ((x (copy-tree '((a b) 1 "and" c d e))) - (y (pushnew (copy-tree '(c d)) x - :test 'equal))) - (and (eqt x y) - x)) - ((c d) (a b) 1 "and" c d e)) - -(deftest pushnew.5 - (let* ((x (copy-tree '((a b) 1 "and" c d e))) - (y (pushnew (copy-tree '(a b)) x - :test 'equal))) - (and - (eqt x y) - x)) - ((a b) 1 "and" c d e)) - -(deftest pushnew.6 - (let* ((x (copy-tree '((a b) (c e) (d f) (g h)))) - (y (pushnew (copy-tree '(d i)) x :key #'car)) - (z (pushnew (copy-tree '(z 10)) x :key #'car))) - (and (eqt y (cdr z)) - (eqt z x) - x)) - ((z 10) (a b) (c e) (d f) (g h))) - -(deftest pushnew.7 - (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) - (y (pushnew (copy-tree '("def" 4)) x - :key #'car :test #'string=)) - (z (pushnew (copy-tree '("xyz" 10)) - x - :key #'car :test #'string=))) - (and - (eqt y (cdr x)) - (eqt x z) - x)) - (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) - -(deftest pushnew.8 - (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) - (y (pushnew (copy-tree '("def" 4)) x - :key #'car :test-not (complement #'string=))) - (z (pushnew (copy-tree '("xyz" 10)) x - :key #'car :test-not (complement #'string=)))) - (and - (eqt y (cdr x)) - (eqt x z) - x)) - (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) - -(deftest pushnew.9 - (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) - (y (pushnew (copy-tree '("def" 4)) x - :key 'car :test-not (complement #'string=))) - (z (pushnew (copy-tree '("xyz" 10)) x - :key 'car :test-not (complement #'string=)))) - (and - (eqt y (cdr x)) - (eqt x z) - x)) - (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) - -;; Check that a NIL :key argument is the same as no key argument at all -(deftest pushnew.10 - (let* ((x (list 'a 'b 'c 'd)) - (result (pushnew 'z x :key nil))) - result) - (z a b c d)) - -;; Check that a NIL :key argument is the same as no key argument at all -(deftest pushnew.11 - (let* ((x (copy-tree '((a b) 1 "and" c d e))) - (y (pushnew (copy-tree '(a b)) x - :test 'equal :key nil))) - (and - (eqt x y) - x)) - ((a b) 1 "and" c d e)) - -(deftest pushnew.12 - (let ((i 0) x y z (d '(b c))) - (values - (pushnew (progn (setf x (incf i)) 'a) - d - :key (progn (setf y (incf i)) #'identity) - :test (progn (setf z (incf i)) #'eql)) - d i x y z)) - (a b c) (a b c) - 3 1 2 3) - -(deftest pushnew.13 - (let ((i 0) x y z (d '(b c))) - (values - (pushnew (progn (setf x (incf i)) 'a) - d - :key (progn (setf y (incf i)) #'identity) - :test-not (progn (setf z (incf i)) (complement #'eql))) - d i x y z)) - (a b c) (a b c) - 3 1 2 3) - -(deftest pushnew.14 - (let ((i 0) x y z (d '(b c))) - (values - (pushnew (progn (setf x (incf i)) 'a) - d - :test (progn (setf z (incf i)) #'eql) - :key (progn (setf y (incf i)) #'identity)) - d i x y z)) - (a b c) (a b c) - 3 1 3 2) - -(deftest pushnew.15 - (let ((i 0) x y z (d '(b c))) - (values - (pushnew (progn (setf x (incf i)) 'a) - d - :test-not (progn (setf z (incf i)) (complement #'eql)) - :key (progn (setf y (incf i)) #'identity)) - d i x y z)) - (a b c) (a b c) - 3 1 3 2) - -(deftest pushnew.error.1 - (classify-error - (let ((x '(a b))) - (pushnew 'c x :test #'identity))) - program-error) - -(deftest pushnew.error.2 - (classify-error - (let ((x '(a b))) - (pushnew 'c x :test-not #'identity))) - program-error) - -(deftest pushnew.error.3 - (classify-error - (let ((x '(a b))) - (pushnew 'c x :key #'cons))) - program-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; adjoin - -(deftest adjoin.1 - (adjoin 'a nil) - (a)) - -(deftest adjoin.2 - (adjoin nil nil) - (nil)) - -(deftest adjoin.3 - (adjoin 'a '(a)) - (a)) - -;; Check that a NIL :key argument is the same as no key argument at all -(deftest adjoin.4 - (adjoin 'a '(a) :key nil) - (a)) - -(deftest adjoin.5 - (adjoin 'a '(a) :key #'identity) - (a)) - -(deftest adjoin.6 - (adjoin 'a '(a) :key 'identity) - (a)) - -(deftest adjoin.7 - (adjoin (1+ 11) '(4 3 12 2 1)) - (4 3 12 2 1)) - -;; Check that the test is EQL, not EQ (by adjoining a bignum) -(deftest adjoin.8 - (adjoin (1+ 999999999999) '(4 1 1000000000000 3816734 a "aa")) - (4 1 1000000000000 3816734 a "aa")) - -(deftest adjoin.9 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a)) - ("aaa" aaa "AAA" "aaa" #\a)) - -(deftest adjoin.10 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test #'equal) - (aaa "AAA" "aaa" #\a)) - -(deftest adjoin.11 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test 'equal) - (aaa "AAA" "aaa" #\a)) - -(deftest adjoin.12 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test-not (complement #'equal)) - (aaa "AAA" "aaa" #\a)) - -(deftest adjoin.14 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test #'equal :key #'identity) - (aaa "AAA" "aaa" #\a)) - -(deftest adjoin.15 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test 'equal :key #'identity) - (aaa "AAA" "aaa" #\a)) - -;; Test that a :key of NIL is the same as no key at all -(deftest adjoin.16 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test #'equal :key nil) - (aaa "AAA" "aaa" #\a)) - -;; Test that a :key of NIL is the same as no key at all -(deftest adjoin.17 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test 'equal :key nil) - (aaa "AAA" "aaa" #\a)) - -;; Test that a :key of NIL is the same as no key at all -(deftest adjoin.18 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test-not (complement #'equal) :key nil) - (aaa "AAA" "aaa" #\a)) - -(deftest adjoin.order.1 - (let ((i 0) w x y z) - (values - (adjoin (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) '(b c d a e)) - :key (progn (setf y (incf i)) #'identity) - :test (progn (setf z (incf i)) #'eql)) - i w x y z)) - (b c d a e) - 4 1 2 3 4) - -(deftest adjoin.order.2 - (let ((i 0) w x y z p) - (values - (adjoin (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) '(b c d e)) - :test-not (progn (setf y (incf i)) (complement #'eql)) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf p (incf i)) nil)) - i w x y z p)) - (a b c d e) - 5 1 2 3 4 5) - -(deftest adjoin.allow-other-keys.1 - (adjoin 'a '(b c) :bad t :allow-other-keys t) - (a b c)) - -(deftest adjoin.allow-other-keys.2 - (adjoin 'a '(b c) :allow-other-keys t :foo t) - (a b c)) - -(deftest adjoin.allow-other-keys.3 - (adjoin 'a '(b c) :allow-other-keys t) - (a b c)) - -(deftest adjoin.allow-other-keys.4 - (adjoin 'a '(b c) :allow-other-keys nil) - (a b c)) - -(deftest adjoin.allow-other-keys.5 - (adjoin 'a '(b c) :allow-other-keys t :allow-other-keys nil 'bad t) - (a b c)) - -(deftest adjoin.repeat-key - (adjoin 'a '(b c) :test #'eq :test (complement #'eq)) - (a b c)) - -(deftest adjoin.error.1 - (classify-error (adjoin)) - program-error) - -(deftest adjoin.error.2 - (classify-error (adjoin 'a)) - program-error) - -(deftest adjoin.error.3 - (classify-error (adjoin 'a '(b c) :bad t)) - program-error) - -(deftest adjoin.error.4 - (classify-error (adjoin 'a '(b c) :allow-other-keys nil :bad t)) - program-error) - -(deftest adjoin.error.5 - (classify-error (adjoin 'a '(b c) 1 2)) - program-error) - -(deftest adjoin.error.6 - (classify-error (adjoin 'a '(b c) :test)) - program-error) - -(deftest adjoin.error.7 - (classify-error (adjoin 'a '(b c) :test #'identity)) - program-error) - -(deftest adjoin.error.8 - (classify-error (adjoin 'a '(b c) :test-not #'identity)) - program-error) - -(deftest adjoin.error.9 - (classify-error (adjoin 'a '(b c) :key #'cons)) - program-error) - -(deftest adjoin.error.10 - (classify-error (adjoin 'a (list* 'b 'c 'd))) - type-error) - diff --git a/ansi-tests/cons-test-05.lsp b/ansi-tests/cons-test-05.lsp index 100c1edde0dfa45298727560dd4e6fb2cc4b3f96..4f3b29e9d0e23665318159e684a8cda53e3df2e4 100644 --- a/ansi-tests/cons-test-05.lsp +++ b/ansi-tests/cons-test-05.lsp @@ -5,8 +5,6 @@ (in-package :cl-test) -(declaim (optimize (safety 3))) - (defparameter *cons-accessors* '(first second third fourth fifth sixth seventh eighth ninth tenth car cdr caar cadr cdar cddr @@ -138,55 +136,3 @@ :cl-test) (classify-error (,name nil nil)) program-error))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; nth - -(deftest nth.1 - (nth-1-body (loop for i from 1 to 2000 collect (* 4 i))) - 0) - -(deftest nth.2 - (let ((x (loop for i from 1 to 2000 collect i))) - (loop - for i from 0 to 1999 do - (setf (nth i x) (- 1999 i))) - (equalt x (loop for i from 1999 downto 0 collect i))) - t) - -;;; Test side effects, evaluation order in assignment to NTH -(deftest nth.order.1 - (let ((i 0) - (x (list 'a 'b 'c 'd)) - y z) - (and - (eqlt (setf (nth (setf y (incf i)) x) (progn (setf z (incf i)) 'z)) - 'z) - (eqlt y 1) - (eqlt z 2) - x)) - (a z c d)) - -(deftest nth.order.2 - (let ((i 0) x y (z '(a b c d e))) - (values - (nth (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) z)) - i x y)) - b 2 1 2) - -(deftest nth.error.1 - (classify-error (nth)) - program-error) - -(deftest nth.error.2 - (classify-error (nth 0)) - program-error) - -(deftest nth.error.3 - (classify-error (nth 1 '(a b c) nil)) - program-error) - -(deftest nth.error.4 - (classify-error (nth 0 '(a b c) nil)) - program-error) diff --git a/ansi-tests/cons-test-07.lsp b/ansi-tests/cons-test-07.lsp deleted file mode 100644 index 5034441a3660891152567d654b2239b2e71e3fb8..0000000000000000000000000000000000000000 --- a/ansi-tests/cons-test-07.lsp +++ /dev/null @@ -1,223 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:35:15 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 7 - -(in-package :cl-test) - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; nconc - -(deftest nconc.1 - (nconc) - nil) - -(deftest nconc.2 - (nconc (copy-tree '(a b c d e f))) - (a b c d e f)) - -;;; (deftest nconc.3 -;;; (nconc 1) -;;; 1) - -(deftest nconc.4 - (let ((x (list 'a 'b 'c)) - (y (list 'd 'e 'f))) - (let ((ycopy (make-scaffold-copy y))) - (let ((result (nconc x y))) - (and - (check-scaffold-copy y ycopy) - (eqt (cdddr x) y) - result)))) - (a b c d e f)) - -(deftest nconc.5 - (let ((x (list 'a 'b 'c))) - (nconc x x) - (and - (eqt (cdddr x) x) - (null (list-length x)))) - t) - -(deftest nconc.6 - (let ((x (list 'a 'b 'c)) - (y (list 'd 'e 'f 'g 'h)) - (z (list 'i 'j 'k))) - (let ((result (nconc x y z 'foo))) - (and - (eqt (nthcdr 3 x) y) - (eqt (nthcdr 5 y) z) - (eqt (nthcdr 3 z) 'foo) - result))) - (a b c d e f g h i j k . foo)) - -(deftest nconc.7 - (nconc (copy-tree '(a . b)) - (copy-tree '(c . d)) - (copy-tree '(e . f)) - 'foo) - (a c e . foo)) - -(deftest nconc.order.1 - (let ((i 0) x y z) - (values - (nconc (progn (setf x (incf i)) (copy-list '(a b c))) - (progn (setf y (incf i)) (copy-list '(d e f))) - (progn (setf z (incf i)) (copy-list '(g h i)))) - i x y z)) - (a b c d e f g h i) 3 1 2 3) - -(deftest nconc.order.2 - (let ((i 0)) - (values - (nconc (list 'a) (incf i)) - i)) - (a . 1) 1) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; append - -(deftest append.1 - (append) - nil) - -(deftest append.2 - (append 'x) - x) - -(deftest append.3 - (let ((x (list 'a 'b 'c 'd)) - (y (list 'e 'f 'g))) - (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (let ((result (append x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - result)))) - (a b c d e f g)) - -(deftest append.4 - (append (list 'a) (list 'b) (list 'c) - (list 'd) (list 'e) (list 'f) - (list 'g) 'h) - (a b c d e f g . h)) - -(deftest append.5 - (append nil nil nil nil nil nil nil nil 'a) - a) - -(deftest append.6 - (append-6-body) - 0) - -(deftest append.order.1 - (let ((i 0) x y z) - (values - (append (progn (setf x (incf i)) (copy-list '(a b c))) - (progn (setf y (incf i)) (copy-list '(d e f))) - (progn (setf z (incf i)) (copy-list '(g h i)))) - i x y z)) - (a b c d e f g h i) 3 1 2 3) - -(deftest append.order.2 - (let ((i 0)) (values (append (incf i)) i)) - 1 1) - -(deftest append.error.1 - (classify-error (append '(a . b) '(z))) - type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; revappend - -(deftest revappend.1 - (let* ((x (list 'a 'b 'c)) - (y (list 'd 'e 'f)) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - ) - (let ((result (revappend x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - (eqt (cdddr result) y) - result))) - (c b a d e f)) - -(deftest revappend.2 - (revappend (copy-tree '(a b c d e)) 10) - (e d c b a . 10)) - -(deftest revappend.3 - (revappend nil 'a) - a) - -(deftest revappend.4 - (revappend (copy-tree '(a (b c) d)) nil) - (d (b c) a)) - -(deftest revappend.order.1 - (let ((i 0) x y) - (values - (revappend (progn (setf x (incf i)) (copy-list '(a b c))) - (progn (setf y (incf i)) (copy-list '(d e f)))) - i x y)) - (c b a d e f) 2 1 2) - -(deftest revappend.error.1 - (classify-error (revappend)) - program-error) - -(deftest revappend.error.2 - (classify-error (revappend nil)) - program-error) - -(deftest revappend.error.3 - (classify-error (revappend nil nil nil)) - program-error) - -(deftest revappend.error.4 - (classify-error (revappend '(a . b) '(z))) - type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; nreconc - -(deftest nreconc.1 - (let* ((x (list 'a 'b 'c)) - (y (copy-tree '(d e f))) - (result (nreconc x y))) - (and (equal y '(d e f)) - result)) - (c b a d e f)) - -(deftest nreconc.2 - (nreconc nil 'a) - a) - -(deftest nreconc.order.1 - (let ((i 0) x y) - (values - (nreconc (progn (setf x (incf i)) (copy-list '(a b c))) - (progn (setf y (incf i)) (copy-list '(d e f)))) - i x y)) - (c b a d e f) 2 1 2) - -(deftest nreconc.error.1 - (classify-error (nreconc)) - program-error) - -(deftest nreconc.error.2 - (classify-error (nreconc nil)) - program-error) - -(deftest nreconc.error.3 - (classify-error (nreconc nil nil nil)) - program-error) - -(deftest nreconc.error.4 - (classify-error (nreconc (cons 'a 'b) (list 'z))) - type-error) diff --git a/ansi-tests/cons-test-14.lsp b/ansi-tests/cons-test-14.lsp deleted file mode 100644 index 3b90821f619dd4db4fe74d5e0e2be1320a74b8b1..0000000000000000000000000000000000000000 --- a/ansi-tests/cons-test-14.lsp +++ /dev/null @@ -1,275 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:39:29 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 14 - -(in-package :cl-test) - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; member-if - -(deftest member-if.1 - (member-if #'listp nil) - nil) - -(deftest member-if.2 - (member-if #'(lambda (x) (eqt x 'a)) '(1 2 a 3 4)) - (a 3 4)) - -(deftest member-if.3 - (member-if #'(lambda (x) (eql x 12)) '(4 12 11 73 11) :key #'1+) - (11 73 11)) - -(deftest member-if.4 - (let ((test-inputs - `(1 a 11.3121 11.31s3 1.123f5 -1 0 - 13.13122d34 581.131e-10 - (a b c . d) - ,(make-array '(10)) - "ancadas" #\w))) - (notnot-mv - (every - #'(lambda (x) - (let ((result (catch-type-error (member-if #'listp x)))) - (or (eqt result 'type-error) - (progn - (format t "~%On ~S: returned ~%~S" x result) - nil)))) - test-inputs))) - t) - -(deftest member-if.5 - (member-if #'identity '(1 2 3 4 5) :key #'evenp) - (2 3 4 5)) - -;;; Order of argument tests - -(deftest member-if.order.1 - (let ((i 0) x y) - (values - (member-if (progn (setf x (incf i)) - #'identity) - (progn (setf y (incf i)) - '(nil nil a b nil c d))) - i x y)) - (a b nil c d) 2 1 2) - -(deftest member-if.order.2 - (let ((i 0) x y z w) - (values - (member-if (progn (setf x (incf i)) - #'identity) - (progn (setf y (incf i)) - '(nil nil a b nil c d)) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf w (incf i)) #'not)) - - i x y z w)) - (a b nil c d) 4 1 2 3 4) - - -;;; Keyword tests - -(deftest member-if.keywords.1 - (member-if #'identity '(1 2 3 4 5) :key #'evenp :key #'oddp) - (2 3 4 5)) - -(deftest member-if.allow-other-keys.2 - (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t :bad t) - (2 3 4 5)) - -(deftest member-if.allow-other-keys.3 - (member-if #'identity '(nil 2 3 4 5) :bad t :allow-other-keys t) - (2 3 4 5)) - -(deftest member-if.allow-other-keys.4 - (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t) - (2 3 4 5)) - -(deftest member-if.allow-other-keys.5 - (member-if #'identity '(nil 2 3 4 5) :allow-other-keys nil) - (2 3 4 5)) - -(deftest member-if.allow-other-keys.6 - (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t - :allow-other-keys nil) - (2 3 4 5)) - -(deftest member-if.allow-other-keys.7 - (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t - :allow-other-keys nil :key #'identity :key #'null) - (2 3 4 5)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; member-if-not - -(deftest member-if-not.1 - (member-if-not #'listp nil) - nil) - -(deftest member-if-not.2 - (member-if-not #'(lambda (x) (eqt x 'a)) '(a 1 2 a 3 4)) - (1 2 a 3 4)) - -(deftest member-if-not.3 - (member-if-not #'(lambda (x) (not (eql x 12))) '(4 12 11 73 11) :key #'1+) - (11 73 11)) - -(deftest member-if-not.4 - (let ((test-inputs - `(1 a 11.3121 11.31s3 1.123f5 -1 0 - 13.13122d34 581.131e-10 - ((a) (b) (c) . d) - ,(make-array '(10)) - "ancadas" #\w))) - (not (every - #'(lambda (x) - (let ((result (catch-type-error (member-if-not #'listp x)))) - (or (eqt result 'type-error) - (progn - (format t "~%On x = ~S, returns: ~%~S" x result) - nil)))) - test-inputs))) - nil) - -(deftest member-if-not.5 - (member-if-not #'not '(1 2 3 4 5) :key #'evenp) - (2 3 4 5)) - -;;; Order of evaluation tests - -(deftest member-if-not.order.1 - (let ((i 0) x y) - (values - (member-if-not (progn (setf x (incf i)) - #'not) - (progn (setf y (incf i)) - '(nil nil a b nil c d))) - i x y)) - (a b nil c d) 2 1 2) - -(deftest member-if-not.order.2 - (let ((i 0) x y z w) - (values - (member-if-not (progn (setf x (incf i)) - #'not) - (progn (setf y (incf i)) - '(nil nil a b nil c d)) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf w (incf i)) #'not)) - - i x y z w)) - (a b nil c d) 4 1 2 3 4) - -;;; Keyword tests - -(deftest member-if-not.keywords.1 - (member-if-not #'not '(1 2 3 4 5) :key #'evenp :key #'oddp) - (2 3 4 5)) - -(deftest member-if-not.allow-other-keys.2 - (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t :bad t) - (2 3 4 5)) - -(deftest member-if-not.allow-other-keys.3 - (member-if-not #'not '(nil 2 3 4 5) :bad t :allow-other-keys t) - (2 3 4 5)) - -(deftest member-if-not.allow-other-keys.4 - (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t) - (2 3 4 5)) - -(deftest member-if-not.allow-other-keys.5 - (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys nil) - (2 3 4 5)) - -(deftest member-if-not.allow-other-keys.6 - (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t - :allow-other-keys nil :key #'identity :key #'null) - (2 3 4 5)) - - -;;; Error cases - -(deftest member-if.error.1 - (classify-error (member-if #'identity 'a)) - type-error) - -(deftest member-if.error.2 - (classify-error (member-if)) - program-error) - -(deftest member-if.error.3 - (classify-error (member-if #'null)) - program-error) - -(deftest member-if.error.4 - (classify-error (member-if #'null '(a b c) :bad t)) - program-error) - -(deftest member-if.error.5 - (classify-error (member-if #'null '(a b c) :bad t :allow-other-keys nil)) - program-error) - -(deftest member-if.error.6 - (classify-error (member-if #'null '(a b c) :key)) - program-error) - -(deftest member-if.error.7 - (classify-error (member-if #'null '(a b c) 1 2)) - program-error) - -(deftest member-if.error.8 - (classify-error (locally (member-if #'identity 'a) t)) - type-error) - -(deftest member-if.error.9 - (classify-error (member-if #'cons '(a b c))) - program-error) - -(deftest member-if.error.10 - (classify-error (member-if #'identity '(a b c) :key #'cons)) - program-error) - - -(deftest member-if-not.error.1 - (classify-error (member-if-not #'identity 'a)) - type-error) - -(deftest member-if-not.error.2 - (classify-error (member-if-not)) - program-error) - -(deftest member-if-not.error.3 - (classify-error (member-if-not #'null)) - program-error) - -(deftest member-if-not.error.4 - (classify-error (member-if-not #'null '(a b c) :bad t)) - program-error) - -(deftest member-if-not.error.5 - (classify-error (member-if-not #'null '(a b c) :bad t :allow-other-keys nil)) - program-error) - -(deftest member-if-not.error.6 - (classify-error (member-if-not #'null '(a b c) :key)) - program-error) - -(deftest member-if-not.error.7 - (classify-error (member-if-not #'null '(a b c) 1 2)) - program-error) - -(deftest member-if-not.error.8 - (classify-error (locally (member-if-not #'identity 'a) t)) - type-error) - -(deftest member-if-not.error.9 - (classify-error (member-if-not #'cons '(a b c))) - program-error) - -(deftest member-if-not.error.10 - (classify-error (member-if-not #'identity '(a b c) :key #'cons)) - program-error) diff --git a/ansi-tests/cons-test-15.lsp b/ansi-tests/cons-test-15.lsp deleted file mode 100644 index b8868eb5d99b27b4301f97aa3b8895340bd58ad3..0000000000000000000000000000000000000000 --- a/ansi-tests/cons-test-15.lsp +++ /dev/null @@ -1,675 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:40:12 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 15 - -(in-package :cl-test) - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; mapc - -(deftest mapc.1 - (mapc #'list nil) - nil) - -(deftest mapc.2 - (let ((x 0)) - (let ((result - (mapc #'(lambda (y) (incf x y)) - '(1 2 3 4)))) - (list result x))) - ((1 2 3 4) 10)) - -(deftest mapc.3 - (let ((x 0)) - (list - (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) - (make-list 5 :initial-element 'a) - (make-list 5 )) - x)) - ((a a a a a) 5)) - -(deftest mapc.4 - (let ((x 0)) - (list - (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) - (make-list 5 :initial-element 'a) - (make-list 10)) - x)) - ((a a a a a) 5)) - -(deftest mapc.5 - (let ((x 0)) - (list - (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) - (make-list 5 :initial-element 'a) - (make-list 3)) - x)) - ((a a a a a) 3)) - -(defvar *mapc.6-var* nil) -(defun mapc.6-fun (x) - (push x *mapc.6-var*) - x) - -(deftest mapc.6 - (let* ((x (copy-list '(a b c d e f g h))) - (xcopy (make-scaffold-copy x))) - (setf *mapc.6-var* nil) - (let ((result (mapc 'mapc.6-fun x))) - (and (check-scaffold-copy x xcopy) - (eqt result x) - *mapc.6-var*))) - (h g f e d c b a)) - -(deftest mapc.order.1 - (let ((i 0) x y z) - (values - (mapc (progn (setf x (incf i)) - #'list) - (progn (setf y (incf i)) - '(a b c)) - (progn (setf z (incf i)) - '(1 2 3))) - i x y z)) - (a b c) 3 1 2 3) - -(deftest mapc.error.1 - (classify-error (mapc #'identity 1)) - type-error) - -(deftest mapc.error.2 - (classify-error (mapc)) - program-error) - -(deftest mapc.error.3 - (classify-error (mapc #'append)) - program-error) - -(deftest mapc.error.4 - (classify-error (locally (mapc #'identity 1) t)) - type-error) - -(deftest mapc.error.5 - (classify-error (mapc #'cons '(a b c))) - program-error) - -(deftest mapc.error.6 - (classify-error (mapc #'cons '(a b c) '(1 2 3) '(4 5 6))) - program-error) - -(deftest mapc.error.7 - (classify-error (mapc #'car '(a b c))) - type-error) - -(deftest mapc.error.8 - (classify-error (mapc #'identity (list* 1 2 3 4))) - type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; mapcar - -(deftest mapcar.1 - (mapcar #'1+ nil) - nil) - -(deftest mapcar.2 - (let* ((x (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x))) - (let ((result (mapcar #'1+ x))) - (and (check-scaffold-copy x xcopy) - result))) - (2 3 4 5)) - -(deftest mapcar.3 - (let* ((n 0) - (x (copy-list '(a b c d))) - (xcopy (make-scaffold-copy x))) - (let ((result - (mapcar #'(lambda (y) (declare (ignore y)) (incf n)) - x))) - (and (check-scaffold-copy x xcopy) - result))) - (1 2 3 4)) - -(deftest mapcar.4 - (let* ((n 0) - (x (copy-list '(a b c d))) - (xcopy (make-scaffold-copy x)) - (x2 (copy-list '(a b c d e f))) - (x2copy (make-scaffold-copy x2)) - (result - (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) - x x2))) - (and (check-scaffold-copy x xcopy) - (check-scaffold-copy x2 x2copy) - (list result n))) - ((1 2 3 4) 4)) - -(deftest mapcar.5 - (let* ((n 0) - (x (copy-list '(a b c d))) - (xcopy (make-scaffold-copy x)) - (x2 (copy-list '(a b c d e f))) - (x2copy (make-scaffold-copy x2)) - (result - (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) - x2 x))) - (and (check-scaffold-copy x xcopy) - (check-scaffold-copy x2 x2copy) - (list result n))) - ((1 2 3 4) 4)) - -(deftest mapcar.6 - (let* ((x (copy-list '(a b c d e f g h))) - (xcopy (make-scaffold-copy x))) - (setf *mapc.6-var* nil) - (let ((result (mapcar 'mapc.6-fun x))) - (and (check-scaffold-copy x xcopy) - (list *mapc.6-var* result)))) - ((h g f e d c b a) (a b c d e f g h))) - -(deftest mapcar.order.1 - (let ((i 0) x y z) - (values - (mapcar (progn (setf x (incf i)) - #'list) - (progn (setf y (incf i)) - '(a b c)) - (progn (setf z (incf i)) - '(1 2 3))) - i x y z)) - ((a 1) (b 2) (c 3)) - 3 1 2 3) - -(deftest mapcar.error.1 - (classify-error (mapcar #'identity 1)) - type-error) - -(deftest mapcar.error.2 - (classify-error (mapcar)) - program-error) - -(deftest mapcar.error.3 - (classify-error (mapcar #'append)) - program-error) - -(deftest mapcar.error.4 - (classify-error (locally (mapcar #'identity 1) t)) - type-error) - -(deftest mapcar.error.5 - (classify-error (mapcar #'car '(a b c))) - type-error) - -(deftest mapcar.error.6 - (classify-error (mapcar #'cons '(a b c))) - program-error) - -(deftest mapcar.error.7 - (classify-error (mapcar #'cons '(a b c) '(1 2 3) '(4 5 6))) - program-error) - -(deftest mapcar.error.8 - (classify-error (mapcar #'identity (list* 1 2 3 4))) - type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; mapcan - -(deftest mapcan.1 - (mapcan #'list nil) - nil) - -(deftest mapcan.2 - (mapcan #'list (copy-list '(a b c d e f))) - (a b c d e f)) - -(deftest mapcan.3 - (let* ((x (list 'a 'b 'c 'd)) - (xcopy (make-scaffold-copy x)) - (result (mapcan #'list x))) - (and - (= (length x) (length result)) - (check-scaffold-copy x xcopy) - (loop - for e1 on x - and e2 on result - count (or (eqt e1 e2) (not (eql (car e1) (car e2))))))) - 0) - -(deftest mapcan.4 - (mapcan #'list - (copy-list '(1 2 3 4)) - (copy-list '(a b c d))) - (1 a 2 b 3 c 4 d)) - -(deftest mapcan.5 - (mapcan #'(lambda (x y) (make-list y :initial-element x)) - (copy-list '(a b c d)) - (copy-list '(1 2 3 4))) - (a b b c c c d d d d)) - -(defvar *mapcan.6-var* nil) -(defun mapcan.6-fun (x) - (push x *mapcan.6-var*) - (copy-list *mapcan.6-var*)) - -(deftest mapcan.6 - (progn - (setf *mapcan.6-var* nil) - (mapcan 'mapcan.6-fun (copy-list '(a b c d)))) - (a b a c b a d c b a)) - -(deftest mapcan.order.1 - (let ((i 0) x y z) - (values - (mapcan (progn (setf x (incf i)) - #'list) - (progn (setf y (incf i)) - '(a b c)) - (progn (setf z (incf i)) - '(1 2 3))) - i x y z)) - (a 1 b 2 c 3) - 3 1 2 3) - -(deftest mapcan.8 - (mapcan #'(lambda (x y) (make-list y :initial-element x)) - (copy-list '(a b c d)) - (copy-list '(1 2 3 4 5 6))) - (a b b c c c d d d d)) - -(deftest mapcan.9 - (mapcan #'(lambda (x y) (make-list y :initial-element x)) - (copy-list '(a b c d e f)) - (copy-list '(1 2 3 4))) - (a b b c c c d d d d)) - -(deftest mapcan.10 - (mapcan #'list - (copy-list '(a b c d)) - (copy-list '(1 2 3 4)) - nil) - nil) - -(deftest mapcan.11 - (mapcan (constantly 1) (list 'a)) - 1) - -(deftest mapcan.error.1 - (classify-error (mapcan #'identity 1)) - type-error) - -(deftest mapcan.error.2 - (classify-error (mapcan)) - program-error) - -(deftest mapcan.error.3 - (classify-error (mapcan #'append)) - program-error) - -(deftest mapcan.error.4 - (classify-error (locally (mapcan #'identity 1) t)) - type-error) - -(deftest mapcan.error.5 - (classify-error (mapcan #'car '(a b c))) - type-error) - -(deftest mapcan.error.6 - (classify-error (mapcan #'cons '(a b c))) - program-error) - -(deftest mapcan.error.7 - (classify-error (mapcan #'cons '(a b c) '(1 2 3) '(4 5 6))) - program-error) - -(deftest mapcan.error.8 - (classify-error (mapcan #'identity (list* (list 1) (list 2) 3))) - type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; mapl - -(deftest mapl.1 - (mapl #'list nil) - nil) - -(deftest mapl.2 - (let* ((a nil) - (x (copy-list '(a b c))) - (xcopy (make-scaffold-copy x)) - (result - (mapl #'(lambda (y) (push y a)) - x))) - (and - (check-scaffold-copy x xcopy) - (eqt result x) - a)) - ((c) (b c) (a b c))) - -(deftest mapl.3 - (let* ((a nil) - (x (copy-list '(a b c d))) - (y (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (mapl #'(lambda (xtail ytail) - (setf a - (append (mapcar #'list xtail ytail) - a))) - x y))) - (and - (eqt result x) - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - a)) - ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) - (a 1) (b 2) (c 3) (d 4))) - -(deftest mapl.4 - (let* ((a nil) - (x (copy-list '(a b c d))) - (y (copy-list '(1 2 3 4 5 6 7 8))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (mapl #'(lambda (xtail ytail) - (setf a - (append (mapcar #'list xtail ytail) - a))) - x y))) - (and - (eqt result x) - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - a)) - ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) - (a 1) (b 2) (c 3) (d 4))) - -(deftest mapl.5 - (let* ((a nil) - (x (copy-list '(a b c d e f g))) - (y (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (mapl #'(lambda (xtail ytail) - (setf a - (append (mapcar #'list xtail ytail) - a))) - x y))) - (and - (eqt result x) - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - a)) - ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) - (a 1) (b 2) (c 3) (d 4))) - -(deftest mapl.order.1 - (let ((i 0) x y z) - (values - (mapl (progn - (setf x (incf i)) - (constantly nil)) - (progn - (setf y (incf i)) - '(a b c)) - (progn - (setf z (incf i)) - '(1 2 3))) - i x y z)) - (a b c) 3 1 2 3) - -(deftest mapl.error.1 - (classify-error (mapl #'identity 1)) - type-error) - -(deftest mapl.error.2 - (classify-error (mapl)) - program-error) - -(deftest mapl.error.3 - (classify-error (mapl #'append)) - program-error) - -(deftest mapl.error.4 - (classify-error (locally (mapl #'identity 1) t)) - type-error) - -(deftest mapl.error.5 - (classify-error (mapl #'cons '(a b c))) - program-error) - -(deftest mapl.error.6 - (classify-error (mapl #'cons '(a b c) '(1 2 3) '(4 5 6))) - program-error) - -(deftest mapl.error.7 - (classify-error (mapl #'caar '(a b c))) - type-error) - -(deftest mapl.error.8 - (classify-error (mapl #'identity (list* (list 1) (list 2) 3))) - type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; maplist - -(deftest maplist.1 - (maplist #'list nil) - nil) - -(deftest maplist.2 - (let* ((x (copy-list '(a b c))) - (xcopy (make-scaffold-copy x)) - (result (maplist #'identity x))) - (and (check-scaffold-copy x xcopy) - result)) - ((a b c) (b c) (c))) - -(deftest maplist.3 - (let* ((x (copy-list '(a b c d))) - (y (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (maplist #'append x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - result)) - ((a b c d 1 2 3 4) - (b c d 2 3 4) - (c d 3 4) - (d 4))) - -(deftest maplist.4 - (let* ((x (copy-list '(a b c d))) - (y (copy-list '(1 2 3 4 5))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (maplist #'append x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - result)) - ((a b c d 1 2 3 4 5) - (b c d 2 3 4 5) - (c d 3 4 5) - (d 4 5))) - -(deftest maplist.5 - (let* ((x (copy-list '(a b c d e))) - (y (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (maplist #'append x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - result)) - ((a b c d e 1 2 3 4) - (b c d e 2 3 4) - (c d e 3 4) - (d e 4))) - -(deftest maplist.6 - (maplist 'append '(a b c) '(1 2 3)) - ((a b c 1 2 3) (b c 2 3) (c 3))) - -(deftest maplist.7 - (maplist #'(lambda (x y) (nth (car x) y)) - '(0 1 0 1 0 1 0) - '(a b c d e f g) - ) - (a c c e e g g)) - -(deftest maplist.order.1 - (let ((i 0) x y z) - (values - (maplist - (progn - (setf x (incf i)) - #'(lambda (x y) (declare (ignore x)) (car y))) - (progn - (setf y (incf i)) - '(a b c)) - (progn - (setf z (incf i)) - '(1 2 3))) - i x y z)) - (1 2 3) 3 1 2 3) - -(deftest maplist.error.1 - (classify-error (maplist #'identity 'a)) - type-error) - -(deftest maplist.error.2 - (classify-error (maplist #'identity 1)) - type-error) - -(deftest maplist.error.3 - (classify-error (maplist #'identity 1.1323)) - type-error) - -(deftest maplist.error.4 - (classify-error (maplist #'identity "abcde")) - type-error) - -(deftest maplist.error.5 - (classify-error (maplist)) - program-error) - -(deftest maplist.error.6 - (classify-error (maplist #'append)) - program-error) - -(deftest maplist.error.7 - (classify-error (locally (maplist #'identity 'a) t)) - type-error) - -(deftest maplist.error.8 - (classify-error (maplist #'caar '(a b c))) - type-error) - -(deftest maplist.error.9 - (classify-error (maplist #'cons '(a b c))) - program-error) - -(deftest maplist.error.10 - (classify-error (maplist #'cons '(a b c) '(1 2 3) '(4 5 6))) - program-error) - -(deftest maplist.error.11 - (classify-error (maplist #'identity (list* (list 1) (list 2) 3))) - type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; mapcon - -(deftest mapcon.1 - (mapcon #'(lambda (x) (append '(a) x nil)) nil) - nil) - -(deftest mapcon.2 - (let* ((x (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (result - (mapcon #'(lambda (y) (append '(a) y nil)) x))) - (and - (check-scaffold-copy x xcopy) - result)) - (a 1 2 3 4 a 2 3 4 a 3 4 a 4)) - -(deftest mapcon.3 - (let* ((x (copy-list '(4 2 3 2 2))) - (y (copy-list '(a b c d e f g h i j k l))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (mapcon #'(lambda (xt yt) - (subseq yt 0 (car xt))) - x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - result)) - (a b c d b c c d e d e e f)) - -(deftest mapcon.4 - (mapcon (constantly 1) (list 'a)) - 1) - -(deftest mapcon.order.1 - (let ((i 0) x y z) - (values - (mapcon (progn (setf x (incf i)) - #'(lambda (x y) (list (car x) (car y)))) - (progn (setf y (incf i)) - '(a b c)) - (progn (setf z (incf i)) - '(1 2 3))) - i x y z)) - (a 1 b 2 c 3) - 3 1 2 3) - -(deftest mapcon.error.1 - (classify-error (mapcon #'identity 1)) - type-error) - -(deftest mapcon.error.2 - (classify-error (mapcon)) - program-error) - -(deftest mapcon.error.3 - (classify-error (mapcon #'append)) - program-error) - -(deftest mapcon.error.4 - (classify-error (locally (mapcon #'identity 1) t)) - type-error) - -(deftest mapcon.error.5 - (classify-error (mapcon #'caar '(a b c))) - type-error) - -(deftest mapcon.error.6 - (classify-error (mapcon #'cons '(a b c))) - program-error) - -(deftest mapcon.error.7 - (classify-error (mapcon #'cons '(a b c) '(1 2 3) '(4 5 6))) - program-error) - -(deftest mapcon.error.8 - (classify-error (mapcon #'copy-tree (cons 1 2))) - type-error) - diff --git a/ansi-tests/cons-test-16.lsp b/ansi-tests/cons-test-16.lsp deleted file mode 100644 index 581e965d23db628911de4d831a1ff5606482cd03..0000000000000000000000000000000000000000 --- a/ansi-tests/cons-test-16.lsp +++ /dev/null @@ -1,705 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:41:13 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 16 - -(in-package :cl-test) - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; acons - -(deftest acons.1 - (let* ((x (copy-tree '((c . d) (e . f)))) - (xcopy (make-scaffold-copy x)) - (result (acons 'a 'b x))) - (and - (check-scaffold-copy x xcopy) - (eqt (cdr result) x) - result)) - ((a . b) (c . d) (e . f))) - -(deftest acons.2 - (acons 'a 'b nil) - ((a . b))) - -(deftest acons.3 - (acons 'a 'b 'c) - ((a . b) . c)) - -(deftest acons.4 - (acons '((a b)) '(((c d) e) f) '((1 . 2))) - (( ((a b)) . (((c d) e) f)) (1 . 2))) - -(deftest acons.5 - (acons "ancd" 1.143 nil) - (("ancd" . 1.143))) - -(deftest acons.6 - (acons #\R :foo :bar) - ((#\R . :foo) . :bar)) - -(deftest acons.order.1 - (let ((i 0) x y z) - (values - (acons (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) 'b) - (progn (setf z (incf i)) '((c . d)))) - i x y z)) - ((a . b)(c . d)) - 3 1 2 3) - -(deftest acons.error.1 - (classify-error (acons)) - program-error) - -(deftest acons.error.2 - (classify-error (acons 'a)) - program-error) - -(deftest acons.error.3 - (classify-error (acons 'a 'b)) - program-error) - -(deftest acons.error.4 - (classify-error (acons 'a 'b 'c 'd)) - program-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; assoc - -(deftest assoc.1 - (assoc nil nil) - nil) - -(deftest assoc.2 - (assoc nil '(nil)) - nil) - -(deftest assoc.3 - (assoc nil '(nil (nil . 2) (a . b))) - (nil . 2)) - -(deftest assoc.4 - (assoc nil '((a . b) (c . d))) - nil) - -(deftest assoc.5 - (assoc 'a '((a . b))) - (a . b)) - -(deftest assoc.6 - (assoc 'a '((:a . b) (#:a . c) (a . d) (a . e) (z . f))) - (a . d)) - -(deftest assoc.7 - (let* ((x (copy-tree '((a . b) (b . c) (c . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc 'b x))) - (and - (eqt result (second x)) - (check-scaffold-copy x xcopy))) - t) - -(deftest assoc.8 - (assoc 1 '((0 . a) (1 . b) (2 . c))) - (1 . b)) - -(deftest assoc.9 - (assoc (copy-seq "abc") - '((abc . 1) ("abc" . 2) ("abc" . 3))) - nil) - -(deftest assoc.10 - (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c))))) - nil) - -(deftest assoc.11 - (let ((x (list 'a 'b))) - (assoc x `(((a b) c) (,x . d) (,x . e) ((a b) 1)))) - ((a b) . d)) - - -(deftest assoc.12 - (assoc #\e '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)) - :key #'(lambda (x) (char x 1))) - ("aevgd" . 2)) - -(deftest assoc.13 - (assoc nil '(((a) . b) ( nil . c ) ((nil) . d)) - :key #'car) - (nil . c)) - -(deftest assoc.14 - (assoc (copy-seq "abc") - '((abc . 1) ("abc" . 2) ("abc" . 3)) - :test #'equal) - ("abc" . 2)) - -(deftest assoc.15 - (assoc (copy-seq "abc") - '((abc . 1) ("abc" . 2) ("abc" . 3)) - :test #'equalp) - ("abc" . 2)) - -(deftest assoc.16 - (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c)))) - :test #'equal) - ((a) b)) - -(deftest assoc.17 - (assoc (copy-seq "abc") - '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)) - :test-not (complement #'equalp)) - ("abc" . 2)) - -(deftest assoc.18 - (assoc 'a '((a . d)(b . c)) :test-not #'eq) - (b . c)) - -(deftest assoc.19 - (assoc 'a '((a . d)(b . c)) :test (complement #'eq)) - (b . c)) - -(deftest assoc.20 - (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) - :key #'(lambda (x) (and (stringp x) (string-downcase x))) - :test #'equal) - ("A" . 6)) - -(deftest assoc.21 - (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) - :key #'(lambda (x) (and (stringp x) x)) - :test #'equal) - ("a" . 3)) - -(deftest assoc.22 - (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) - :key #'(lambda (x) (and (stringp x) (string-downcase x))) - :test-not (complement #'equal)) - ("A" . 6)) - -(deftest assoc.23 - (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) - :key #'(lambda (x) (and (stringp x) x)) - :test-not (complement #'equal)) - ("a" . 3)) - -;; Check that it works when test returns a true value -;; other than T - -(deftest assoc.24 - (assoc 'a '((b . 1) (a . 2) (c . 3)) - :test #'(lambda (x y) (and (eqt x y) 'matched))) - (a . 2)) - -;; Check that the order of the arguments to test is correct - -(deftest assoc.25 - (block fail - (assoc 'a '((b . 1) (c . 2) (a . 3)) - :test #'(lambda (x y) - (unless (eqt x 'a) (return-from fail 'fail)) - (eqt x y)))) - (a . 3)) - -;;; Order of argument evaluation - -(deftest assoc.order.1 - (let ((i 0) x y) - (values - (assoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4)))) - i x y)) - (c . 3) 2 1 2) - -(deftest assoc.order.2 - (let ((i 0) x y z) - (values - (assoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) - :test (progn (setf z (incf i)) #'eq)) - i x y z)) - (c . 3) 3 1 2 3) - -(deftest assoc.order.3 - (let ((i 0) x y) - (values - (assoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) - :test #'eq) - i x y)) - (c . 3) 2 1 2) - -(deftest assoc.order.4 - (let ((i 0) x y z w) - (values - (assoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf w (incf i)) #'not)) - i x y z w)) - (c . 3) 4 1 2 3 4) - -;;; Keyword tests - -(deftest assoc.allow-other-keys.1 - (assoc 'b '((a . 1) (b . 2) (c . 3)) :bad t :allow-other-keys t) - (b . 2)) - -(deftest assoc.allow-other-keys.2 - (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t) - (b . 2)) - -(deftest assoc.allow-other-keys.3 - (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t - :test-not #'eql) - (a . 1)) - -(deftest assoc.allow-other-keys.4 - (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t) - (b . 2)) - -(deftest assoc.allow-other-keys.5 - (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys nil) - (b . 2)) - -(deftest assoc.keywords.6 - (assoc 'b '((a . 1) (b . 2) (c . 3)) :key #'identity :key #'null) - (b . 2)) - -(deftest assoc.keywords.7 - (assoc 'b '((a . 1) (b . 2) (c . 3)) :key nil :key #'null) - (b . 2)) - - -(deftest assoc.error.1 - (classify-error (assoc)) - program-error) - -(deftest assoc.error.2 - (classify-error (assoc nil)) - program-error) - -(deftest assoc.error.3 - (classify-error (assoc nil nil :bad t)) - program-error) - -(deftest assoc.error.4 - (classify-error (assoc nil nil :key)) - program-error) - -(deftest assoc.error.5 - (classify-error (assoc nil nil 1 1)) - program-error) - -(deftest assoc.error.6 - (classify-error (assoc nil nil :bad t :allow-other-keys nil)) - program-error) - -(deftest assoc.error.7 - (classify-error (assoc 'a '((a . b)) :test #'identity)) - program-error) - -(deftest assoc.error.8 - (classify-error (assoc 'a '((a . b)) :test-not #'identity)) - program-error) - -(deftest assoc.error.9 - (classify-error (assoc 'a '((a . b)) :key #'cons)) - program-error) - -(deftest assoc.error.10 - (classify-error (assoc 'z '((a . b) . c))) - type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; assoc-if - -(deftest assoc-if.1 - (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if #'evenp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (6 . c)) - -(deftest assoc-if.2 - (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if #'oddp x :key #'1+))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (6 . c)) - -(deftest assoc-if.3 - (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if #'evenp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (fourth x)) - result)) - (6 . c)) - -(deftest assoc-if.4 - (assoc-if #'null '((a . b) nil (c . d) (nil . e) (f . g))) - (nil . e)) - -;;; Order of argument evaluation - -(deftest assoc-if.order.1 - (let ((i 0) x y) - (values - (assoc-if (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) - '((a . 1) (b . 2) (nil . 17) (d . 4)))) - i x y)) - (nil . 17) 2 1 2) - -(deftest assoc-if.order.2 - (let ((i 0) x y z) - (values - (assoc-if (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) - '((a . 1) (b . 2) (nil . 17) (d . 4))) - :key (progn (setf z (incf i)) #'null)) - i x y z)) - (a . 1) 3 1 2 3) - -;;; Keyword tests - -(deftest assoc-if.allow-other-keys.1 - (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) - (nil . 2)) - -(deftest assoc-if.allow-other-keys.2 - (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) - :allow-other-keys t :also-bad t) - (nil . 2)) - -(deftest assoc-if.allow-other-keys.3 - (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) - :allow-other-keys t :also-bad t :key #'not) - (a . 1)) - -(deftest assoc-if.allow-other-keys.4 - (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t) - (nil . 2)) - -(deftest assoc-if.allow-other-keys.5 - (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys nil) - (nil . 2)) - -(deftest assoc-if.keywords.6 - (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :key #'identity :key #'null) - (nil . 2)) - -(deftest assoc-if.keywords.7 - (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null) - (nil . 2)) - -;;; Error cases - -(deftest assoc-if.error.1 - (classify-error (assoc-if)) - program-error) - -(deftest assoc-if.error.2 - (classify-error (assoc-if #'null)) - program-error) - -(deftest assoc-if.error.3 - (classify-error (assoc-if #'null nil :bad t)) - program-error) - -(deftest assoc-if.error.4 - (classify-error (assoc-if #'null nil :key)) - program-error) - -(deftest assoc-if.error.5 - (classify-error (assoc-if #'null nil 1 1)) - program-error) - -(deftest assoc-if.error.6 - (classify-error (assoc-if #'null nil :bad t :allow-other-keys nil)) - program-error) - -(deftest assoc-if.error.7 - (classify-error (assoc-if #'cons '((a b)(c d)))) - program-error) - -(deftest assoc-if.error.8 - (classify-error (assoc-if #'identity '((a b)(c d)) :key #'cons)) - program-error) - -(deftest assoc-if.error.9 - (classify-error (assoc-if #'car '((a b)(c d)))) - type-error) - -(deftest assoc-if.error.10 - (classify-error (assoc-if #'identity '((a b)(c d)) :key #'car)) - type-error) - -(deftest assoc-if.error.11 - (classify-error (assoc-if #'null '((a . b) . c))) - type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; assoc-if-not - -(deftest assoc-if-not.1 - (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if-not #'oddp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (6 . c)) - -(deftest assoc-if-not.2 - (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if-not #'evenp x :key #'1+))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (6 . c)) - -(deftest assoc-if-not.3 - (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if-not #'oddp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (fourth x)) - result)) - (6 . c)) - -(deftest assoc-if-not.4 - (assoc-if-not #'identity '((a . b) nil (c . d) (nil . e) (f . g))) - (nil . e)) - -;;; Order of argument evaluation tests - -(deftest assoc-if-not.order.1 - (let ((i 0) x y) - (values - (assoc-if-not (progn (setf x (incf i)) #'identity) - (progn (setf y (incf i)) - '((a . 1) (b . 2) (nil . 17) (d . 4)))) - i x y)) - (nil . 17) 2 1 2) - -(deftest assoc-if-not.order.2 - (let ((i 0) x y z) - (values - (assoc-if-not (progn (setf x (incf i)) #'identity) - (progn (setf y (incf i)) - '((a . 1) (b . 2) (nil . 17) (d . 4))) - :key (progn (setf z (incf i)) #'null)) - i x y z)) - (a . 1) 3 1 2 3) - -;;; Keyword tests - -(deftest assoc-if-not.allow-other-keys.1 - (assoc-if-not #'identity - '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) - (nil . 2)) - -(deftest assoc-if-not.allow-other-keys.2 - (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) - :allow-other-keys t :also-bad t) - (nil . 2)) - -(deftest assoc-if-not.allow-other-keys.3 - (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) - :allow-other-keys t :also-bad t :key #'not) - (a . 1)) - -(deftest assoc-if-not.allow-other-keys.4 - (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t) - (nil . 2)) - -(deftest assoc-if-not.allow-other-keys.5 - (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys nil) - (nil . 2)) - -(deftest assoc-if-not.keywords.6 - (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) - :key #'identity :key #'null) - (nil . 2)) - -(deftest assoc-if-not.keywords.7 - (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null) - (nil . 2)) - -;;; Error tests - -(deftest assoc-if-not.error.1 - (classify-error (assoc-if-not)) - program-error) - -(deftest assoc-if-not.error.2 - (classify-error (assoc-if-not #'null)) - program-error) - -(deftest assoc-if-not.error.3 - (classify-error (assoc-if-not #'null nil :bad t)) - program-error) - -(deftest assoc-if-not.error.4 - (classify-error (assoc-if-not #'null nil :key)) - program-error) - -(deftest assoc-if-not.error.5 - (classify-error (assoc-if-not #'null nil 1 1)) - program-error) - -(deftest assoc-if-not.error.6 - (classify-error (assoc-if-not #'null nil :bad t :allow-other-keys nil)) - program-error) - -(deftest assoc-if-not.error.7 - (classify-error (assoc-if-not #'cons '((a b)(c d)))) - program-error) - -(deftest assoc-if-not.error.8 - (classify-error (assoc-if-not #'identity '((a b)(c d)) :key #'cons)) - program-error) - -(deftest assoc-if-not.error.9 - (classify-error (assoc-if-not #'car '((a b)(c d)))) - type-error) - -(deftest assoc-if-not.error.10 - (classify-error (assoc-if-not #'identity '((a b)(c d)) :key #'car)) - type-error) - -(deftest assoc-if-not.error.11 - (classify-error (assoc-if-not #'identity '((a . b) . c))) - type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; copy-alist - -(deftest copy-alist-1 - (let* ((x (copy-tree '((a . b) (c . d) nil (e f) ((x) ((y z)) w) - ("foo" . "bar") (#\w . 1.234) - (1/3 . 4123.4d5)))) - (xcopy (make-scaffold-copy x)) - (result (copy-alist x))) - (and - (check-scaffold-copy x xcopy) - (= (length x) (length result)) - (every #'(lambda (p1 p2) - (or (and (null p1) (null p2)) - (and (not (eqt p1 p2)) - (eqt (car p1) (car p2)) - (eqt (cdr p1) (cdr p2))))) - x result) - t)) - t) - -(deftest copy-alist.error.1 - (classify-error (copy-alist)) - program-error) - -(deftest copy-alist.error.2 - (classify-error (copy-alist nil nil)) - program-error) - -(deftest copy-alist.error.3 - (classify-error (copy-alist '((a . b) . c))) - type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; pairlis - -;; Pairlis has two legal behaviors: the pairs -;; can be prepended in the same order, or in the -;; reverse order, that they appear in the first -;; two arguments - -(defun my-pairlis (x y &optional alist) - (if (null x) - alist - (acons (car x) (car y) - (my-pairlis (cdr x) (cdr y) alist)))) - -(deftest pairlis-1 - (pairlis nil nil nil) - nil) - -(deftest pairlis-2 - (pairlis '(a) '(b) nil) - ((a . b))) - -(deftest pairlis-3 - (let* ((x (copy-list '(a b c d e))) - (xcopy (make-scaffold-copy x)) - (y (copy-list '(1 2 3 4 5))) - (ycopy (make-scaffold-copy y)) - (result (pairlis x y)) - (expected (my-pairlis x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - (or - (equal result expected) - (equal result (reverse expected))) - t)) - t) - -(deftest pairlis-4 - (let* ((x (copy-list '(a b c d e))) - (xcopy (make-scaffold-copy x)) - (y (copy-list '(1 2 3 4 5))) - (ycopy (make-scaffold-copy y)) - (z '((x . 10) (y . 20))) - (zcopy (make-scaffold-copy z)) - (result (pairlis x y z)) - (expected (my-pairlis x y z))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - (check-scaffold-copy z zcopy) - (eqt (cdr (cddr (cddr result))) z) - (or - (equal result expected) - (equal result (append (reverse (subseq expected 0 5)) - (subseq expected 5)))) - t)) - t) - -(deftest pairlis.error.1 - (classify-error (pairlis)) - program-error) - -(deftest pairlis.error.2 - (classify-error (pairlis nil)) - program-error) - -(deftest pairlis.error.3 - (classify-error (pairlis nil nil nil nil)) - program-error) - -(deftest pairlist.error.4 - (classify-error (pairlis 'a '(1))) - type-error) - -(deftest pairlist.error.5 - (classify-error (pairlis '(a) 'b)) - type-error) - -(deftest pairlist.error.6 - (classify-error (pairlis '(a . b) '(c . d))) - type-error) diff --git a/ansi-tests/cons-test-17.lsp b/ansi-tests/cons-test-17.lsp deleted file mode 100644 index 661520dd7fef2f08a93f96d39e3a379504e3e7f4..0000000000000000000000000000000000000000 --- a/ansi-tests/cons-test-17.lsp +++ /dev/null @@ -1,571 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 09:45:22 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 17 - -(in-package :cl-test) - -(declaim (optimize (safety 3))) - -(defun rev-assoc-list (x) - (cond - ((null x) nil) - ((null (car x)) - (cons nil (rev-assoc-list (cdr x)))) - (t - (acons (cdar x) (caar x) (rev-assoc-list (cdr x)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; rassoc - -(deftest rassoc.1 - (rassoc nil nil) - nil) - -(deftest rassoc.2 - (rassoc nil '(nil)) - nil) - -(deftest rassoc.3 - (rassoc nil (rev-assoc-list '(nil (nil . 2) (a . b)))) - (2 . nil)) - -(deftest rassoc.4 - (rassoc nil '((a . b) (c . d))) - nil) - -(deftest rassoc.5 - (rassoc 'a '((b . a))) - (b . a)) - -(deftest rassoc.6 - (rassoc 'a (rev-assoc-list '((:a . b) (#:a . c) (a . d) (a . e) (z . f)))) - (d . a)) - -(deftest rassoc.7 - (let* ((x (copy-tree (rev-assoc-list '((a . b) (b . c) (c . d))))) - (xcopy (make-scaffold-copy x)) - (result (rassoc 'b x))) - (and - (eqt result (second x)) - (check-scaffold-copy x xcopy))) - t) - -(deftest rassoc.8 - (rassoc 1 (rev-assoc-list '((0 . a) (1 . b) (2 . c)))) - (b . 1)) - -(deftest rassoc.9 - (rassoc (copy-seq "abc") - (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3)))) - nil) - -(deftest rassoc.10 - (rassoc (copy-list '(a)) - (copy-tree (rev-assoc-list '(((a) b) ((a) (c)))))) - nil) - -(deftest rassoc.11 - (let ((x (list 'a 'b))) - (rassoc x - (rev-assoc-list `(((a b) c) (,x . d) (,x . e) ((a b) 1))))) - (d a b)) - - -(deftest rassoc.12 - (rassoc #\e - (copy-tree - (rev-assoc-list '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)))) - :key #'(lambda (x) (char x 1))) - (2 . "aevgd")) - -(deftest rassoc.13 - (rassoc nil - (copy-tree - (rev-assoc-list - '(((a) . b) ( nil . c ) ((nil) . d)))) - :key #'car) - (c)) - -(deftest rassoc.14 - (rassoc (copy-seq "abc") - (copy-tree - (rev-assoc-list - '((abc . 1) ("abc" . 2) ("abc" . 3)))) - :test #'equal) - (2 . "abc")) - -(deftest rassoc.15 - (rassoc (copy-seq "abc") - (copy-tree - (rev-assoc-list - '((abc . 1) ("abc" . 2) ("abc" . 3)))) - :test #'equalp) - (2 . "abc")) - -(deftest rassoc.16 - (rassoc (copy-list '(a)) - (copy-tree - (rev-assoc-list '(((a) b) ((a) (c))))) - :test #'equal) - ((b) a)) - -(deftest rassoc.17 - (rassoc (copy-seq "abc") - (copy-tree - (rev-assoc-list - '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)))) - :test-not (complement #'equalp)) - (2 . "abc")) - -(deftest rassoc.18 - (rassoc 'a - (copy-tree - (rev-assoc-list - '((a . d)(b . c)))) - :test-not #'eq) - (c . b)) - -(deftest rassoc.19 - (rassoc 'a - (copy-tree - (rev-assoc-list - '((a . d)(b . c)))) - :test (complement #'eq)) - (c . b)) - -(deftest rassoc.20 - (rassoc "a" - (copy-tree - (rev-assoc-list - '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) - :key #'(lambda (x) (and (stringp x) (string-downcase x))) - :test #'equal) - (6 . "A")) - -(deftest rassoc.21 - (rassoc "a" - (copy-tree - (rev-assoc-list - '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) - :key #'(lambda (x) (and (stringp x) x)) - :test #'equal) - (3 . "a")) - -(deftest rassoc.22 - (rassoc "a" - (copy-tree - (rev-assoc-list - '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) - :key #'(lambda (x) (and (stringp x) (string-downcase x))) - :test-not (complement #'equal)) - (6 . "A")) - -(deftest rassoc.23 - (rassoc "a" - (copy-tree - (rev-assoc-list - '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) - :key #'(lambda (x) (and (stringp x) x)) - :test-not (complement #'equal)) - (3 . "a")) - -;; Check that it works when test returns a true value -;; other than T - -(deftest rassoc.24 - (rassoc 'a - (copy-tree - (rev-assoc-list - '((b . 1) (a . 2) (c . 3)))) - :test #'(lambda (x y) (and (eqt x y) 'matched))) - (2 . a)) - -;; Check that the order of the arguments to :test is correct - -(deftest rassoc.25 - (block fail - (rassoc 'a '((1 . b) (2 . c) (3 . a)) - :test #'(lambda (x y) - (unless (eqt x 'a) (return-from fail 'fail)) - (eqt x y)))) - (3 . a)) - -;;; Order of argument evaluation - -(deftest rassoc.order.1 - (let ((i 0) x y) - (values - (rassoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c)))) - i x y)) - (3 . c) 2 1 2) - -(deftest rassoc.order.2 - (let ((i 0) x y z) - (values - (rassoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) - :test (progn (setf z (incf i)) #'eql)) - i x y z)) - (3 . c) 3 1 2 3) - -(deftest rassoc.order.3 - (let ((i 0) x y) - (values - (rassoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) - :test #'eql) - i x y)) - (3 . c) 2 1 2) - -(deftest rassoc.order.4 - (let ((i 0) x y z w) - (values - (rassoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf w (incf i)) #'not)) - i x y z w)) - (3 . c) 4 1 2 3 4) - -;;; Keyword tests - -(deftest rassoc.allow-other-keys.1 - (rassoc 'b '((1 . a) (2 . b) (3 . c)) :bad t :allow-other-keys t) - (2 . b)) - -(deftest rassoc.allow-other-keys.2 - (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys t :bad t) - (2 . b)) - -(deftest rassoc.allow-other-keys.3 - (rassoc 'a '((1 . a) (2 . b) (3 . c)) :allow-other-keys t :bad t - :test-not #'eql) - (2 . b)) - -(deftest rassoc.allow-other-keys.4 - (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys t) - (2 . b)) - -(deftest rassoc.allow-other-keys.5 - (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys nil) - (2 . b)) - -(deftest rassoc.keywords.6 - (rassoc 'b '((1 . a) (2 . b) (3 . c)) - :test #'eql :test (complement #'eql)) - (2 . b)) - -;;; Error tests - -(deftest rassoc.error.1 - (classify-error (rassoc)) - program-error) - -(deftest rassoc.error.2 - (classify-error (rassoc nil)) - program-error) - -(deftest rassoc.error.3 - (classify-error (rassoc nil nil :bad t)) - program-error) - -(deftest rassoc.error.4 - (classify-error (rassoc nil nil :key)) - program-error) - -(deftest rassoc.error.5 - (classify-error (rassoc nil nil 1 1)) - program-error) - -(deftest rassoc.error.6 - (classify-error (rassoc nil nil :bad t :allow-other-keys nil)) - program-error) - -(deftest rassoc.error.7 - (classify-error (rassoc 'a '((b . a)(c . d)) :test #'identity)) - program-error) - -(deftest rassoc.error.8 - (classify-error (rassoc 'a '((b . a)(c . d)) :test-not #'identity)) - program-error) - -(deftest rassoc.error.9 - (classify-error (rassoc 'a '((b . a)(c . d)) :key #'cons)) - program-error) - -(deftest rassoc.error.10 - (classify-error (rassoc 'z '((a . b) . c))) - type-error) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; rassoc-if - -(deftest rassoc-if.1 - (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if #'evenp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (c . 6)) - -(deftest rassoc-if.2 - (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if #'oddp x :key #'1+))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (c . 6)) - -(deftest rassoc-if.3 - (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if #'evenp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (fourth x)) - result)) - (c . 6)) - -(deftest rassoc-if.4 - (rassoc-if #'null - (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) - (e)) - -;;; Order of argument evaluation - -(deftest rassoc-if.order.1 - (let ((i 0) x y) - (values - (rassoc-if (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) - '((1 . a) (2 . b) (17) (4 . d)))) - i x y)) - (17) 2 1 2) - -(deftest rassoc-if.order.2 - (let ((i 0) x y z) - (values - (rassoc-if (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) - '((1 . a) (2 . b) (17) (4 . d))) - :key (progn (setf z (incf i)) #'null)) - i x y z)) - (1 . a) 3 1 2 3) - - -;;; Keyword tests - -(deftest rassoc-if.allow-other-keys.1 - (rassoc-if #'null '((1 . a) (2) (3 . c)) :bad t :allow-other-keys t) - (2)) - -(deftest rassoc-if.allow-other-keys.2 - (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t) - (2)) - -(deftest rassoc-if.allow-other-keys.3 - (rassoc-if #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t - :key 'not) - (2)) - -(deftest rassoc-if.allow-other-keys.4 - (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys t) - (2)) - -(deftest rassoc-if.allow-other-keys.5 - (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys nil) - (2)) - -(deftest rassoc-if.keywords.6 - (rassoc-if #'identity '((1 . a) (2) (3 . c)) :key #'not :key #'identity) - (2)) - -;;; Error tests - -(deftest rassoc-if.error.1 - (classify-error (rassoc-if)) - program-error) - -(deftest rassoc-if.error.2 - (classify-error (rassoc-if #'null)) - program-error) - -(deftest rassoc-if.error.3 - (classify-error (rassoc-if #'null nil :bad t)) - program-error) - -(deftest rassoc-if.error.4 - (classify-error (rassoc-if #'null nil :key)) - program-error) - -(deftest rassoc-if.error.5 - (classify-error (rassoc-if #'null nil 1 1)) - program-error) - -(deftest rassoc-if.error.6 - (classify-error (rassoc-if #'null nil :bad t :allow-other-keys nil)) - program-error) - -(deftest rassoc-if.error.7 - (classify-error (rassoc-if #'cons '((a . b)(c . d)))) - program-error) - -(deftest rassoc-if.error.8 - (classify-error (rassoc-if #'car '((a . b)(c . d)))) - type-error) - -(deftest rassoc-if.error.9 - (classify-error (rassoc-if #'identity '((a . b)(c . d)) :key #'cons)) - program-error) - -(deftest rassoc-if.error.10 - (classify-error (rassoc-if #'identity '((a . b)(c . d)) :key #'car)) - type-error) - -(deftest rassoc-if.error.11 - (classify-error (rassoc-if #'not '((a . b) . c))) - type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; rassoc-if-not - -(deftest rassoc-if-not.1 - (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if-not #'oddp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (c . 6)) - -(deftest rassoc-if-not.2 - (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if-not #'evenp x :key #'1+))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (c . 6)) - -(deftest rassoc-if-not.3 - (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if-not #'oddp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (fourth x)) - result)) - (c . 6)) - -(deftest rassoc-if-not.4 - (rassoc-if-not #'identity - (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) - (e)) - -;;; Order of argument evaluation - -(deftest rassoc-if-not.order.1 - (let ((i 0) x y) - (values - (rassoc-if-not (progn (setf x (incf i)) #'identity) - (progn (setf y (incf i)) - '((1 . a) (2 . b) (17) (4 . d)))) - i x y)) - (17) 2 1 2) - -(deftest rassoc-if-not.order.2 - (let ((i 0) x y z) - (values - (rassoc-if-not (progn (setf x (incf i)) #'identity) - (progn (setf y (incf i)) - '((1 . a) (2 . b) (17) (4 . d))) - :key (progn (setf z (incf i)) #'null)) - i x y z)) - (1 . a) 3 1 2 3) - -;;; Keyword tests - -(deftest rassoc-if-not.allow-other-keys.1 - (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :bad t :allow-other-keys t) - (2)) - -(deftest rassoc-if-not.allow-other-keys.2 - (rassoc-if-not #'values '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t) - (2)) - -(deftest rassoc-if-not.allow-other-keys.3 - (rassoc-if-not #'not '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t - :key 'not) - (2)) - -(deftest rassoc-if-not.allow-other-keys.4 - (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t) - (2)) - -(deftest rassoc-if-not.allow-other-keys.5 - (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys nil) - (2)) - -(deftest rassoc-if-not.allow-other-keys.6 - (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t - :allow-other-keys nil :bad t) - (2)) - -(deftest rassoc-if-not.keywords.7 - (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :key #'not :key nil) - (1 . a)) - -;;; Error tests - -(deftest rassoc-if-not.error.1 - (classify-error (rassoc-if-not)) - program-error) - -(deftest rassoc-if-not.error.2 - (classify-error (rassoc-if-not #'null)) - program-error) - -(deftest rassoc-if-not.error.3 - (classify-error (rassoc-if-not #'null nil :bad t)) - program-error) - -(deftest rassoc-if-not.error.4 - (classify-error (rassoc-if-not #'null nil :key)) - program-error) - -(deftest rassoc-if-not.error.5 - (classify-error (rassoc-if-not #'null nil 1 1)) - program-error) - -(deftest rassoc-if-not.error.6 - (classify-error (rassoc-if-not #'null nil :bad t :allow-other-keys nil)) - program-error) - -(deftest rassoc-if-not.error.7 - (classify-error (rassoc-if-not #'cons '((a . b)(c . d)))) - program-error) - -(deftest rassoc-if-not.error.8 - (classify-error (rassoc-if-not #'car '((a . b)(c . d)))) - type-error) - -(deftest rassoc-if-not.error.9 - (classify-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'cons)) - program-error) - -(deftest rassoc-if-not.error.10 - (classify-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'car)) - type-error) - -(deftest rassoc-if-not.error.11 - (classify-error (rassoc-if-not #'identity '((a . b) . c))) - type-error) diff --git a/ansi-tests/cons-test-22.lsp b/ansi-tests/cons-test-22.lsp deleted file mode 100644 index 3b0d679bb4f0b8ae6bfcd63721114a933bb78d08..0000000000000000000000000000000000000000 --- a/ansi-tests/cons-test-22.lsp +++ /dev/null @@ -1,629 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Mar 30 22:10:34 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 22 - -(in-package :cl-test) - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; set-difference - -(deftest set-difference.1 - (set-difference nil nil) - nil) - -(deftest set-difference.2 - (let ((result - (set-difference-with-check '(a b c) nil))) - (check-set-difference '(a b c) nil result)) - t) - -(deftest set-difference.3 - (let ((result - (set-difference-with-check '(a b c d e f) '(f b d)))) - (check-set-difference '(a b c d e f) '(f b d) result)) - t) - -(deftest set-difference.4 - (sort - (copy-list - (set-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) - '(10 101 4 74 2 1391 7 17831))) - #'<) - (1 3 5 6 8)) - -(deftest set-difference.5 - (set-difference-with-check nil '(a b c d e f g h)) - nil) - -(deftest set-difference.6 - (set-difference-with-check '(a b c d e) '(d a b e) - :key nil) - (c)) - -(deftest set-difference.7 - (set-difference-with-check '(a b c d e) '(d a b e) :test #'eq) - (c)) - -(deftest set-difference.8 - (set-difference-with-check '(a b c d e) '(d a b e) :test #'eql) - (c)) - -(deftest set-difference.9 - (set-difference-with-check '(a b c d e) '(d a b e) :test #'equal) - (c)) - -(deftest set-difference.10 - (set-difference-with-check '(a b c d e) '(d a b e) - :test 'eq) - (c)) - -(deftest set-difference.11 - (set-difference-with-check '(a b c d e) '(d a b e) - :test 'eql) - (c)) - -(deftest set-difference.12 - (set-difference-with-check '(a b c d e) '(d a b e) - :test 'equal) - (c)) - -(deftest set-difference.13 - (do-random-set-differences 100 100) - nil) - -(deftest set-difference.14 - (set-difference-with-check '((a . 1) (b . 2) (c . 3)) - '((a . 1) (c . 3)) - :key 'car) - ((b . 2))) - -(deftest set-difference.15 - (set-difference-with-check '((a . 1) (b . 2) (c . 3)) - '((a . 1) (c . 3)) - :key #'car) - ((b . 2))) - -;; -;; Verify that the :test argument is called with the arguments -;; in the correct order -;; -(deftest set-difference.16 - (block fail - (sort - (copy-list - (set-difference-with-check - '(1 2 3 4) '(e f g h) - :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 set-difference.17 - (block fail - (sort - (copy-list - (set-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 set-difference.18 - (block fail - (sort - (copy-list - (set-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 set-difference.19 - (block fail - (sort - (copy-list - (set-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)) - -;;; Order of argument evaluation tests - -(deftest set-difference.order.1 - (let ((i 0) x y) - (values - (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4))) - i x y)) - (1) 2 1 2) - -(deftest set-difference.order.2 - (let ((i 0) x y z) - (values - (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4)) - :test (progn (setf z (incf i)) - #'(lambda (x y) (= x (1- y))))) - i x y z)) - (4) 3 1 2 3) - -(deftest set-difference.order.3 - (let ((i 0) x y z w) - (values - (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4)) - :test (progn (setf z (incf i)) - #'(lambda (x y) (= x (1- y)))) - :key (progn (setf w (incf i)) nil)) - i x y z w)) - (4) 4 1 2 3 4) - - -;;; Keyword tests - -(deftest set-difference.allow-other-keys.1 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :bad t :allow-other-keys t)) - #'<) - (1 5)) - -(deftest set-difference.allow-other-keys.2 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t :bad t)) - #'<) - (1 5)) - -(deftest set-difference.allow-other-keys.3 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y))))) - #'<) - (4 5)) - -(deftest set-difference.allow-other-keys.4 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t)) - #'<) - (1 5)) - -(deftest set-difference.allow-other-keys.5 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys nil)) - #'<) - (1 5)) - -(deftest set-difference.allow-other-keys.6 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t - :allow-other-keys nil)) - #'<) - (1 5)) - -(deftest set-difference.allow-other-keys.7 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t - :allow-other-keys nil - '#:x 1)) - #'<) - (1 5)) - -(deftest set-difference.keywords.8 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :test #'eql :test (complement #'eql))) - #'<) - (1 5)) - -(deftest set-difference.keywords.9 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :test (complement #'eql) :test #'eql)) - #'<) - nil) - -;;; Error tests - - -(deftest set-difference.error.1 - (classify-error (set-difference)) - program-error) - -(deftest set-difference.error.2 - (classify-error (set-difference nil)) - program-error) - -(deftest set-difference.error.3 - (classify-error (set-difference nil nil :bad t)) - program-error) - -(deftest set-difference.error.4 - (classify-error (set-difference nil nil :key)) - program-error) - -(deftest set-difference.error.5 - (classify-error (set-difference nil nil 1 2)) - program-error) - -(deftest set-difference.error.6 - (classify-error (set-difference nil nil :bad t :allow-other-keys nil)) - program-error) - -(deftest set-difference.error.7 - (classify-error (set-difference (list 1 2) (list 3 4) :test #'identity)) - program-error) - -(deftest set-difference.error.8 - (classify-error (set-difference (list 1 2) (list 3 4) :test-not #'identity)) - program-error) - -(deftest set-difference.error.9 - (classify-error (set-difference (list 1 2) (list 3 4) :key #'cons)) - program-error) - -(deftest set-difference.error.10 - (classify-error (set-difference (list 1 2) (list 3 4) :key #'car)) - type-error) - -(deftest set-difference.error.11 - (classify-error (set-difference (list 1 2 3) (list* 4 5 6))) - type-error) - -(deftest set-difference.error.12 - (classify-error (set-difference (list* 1 2 3) (list 4 5 6))) - type-error) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; nset-difference - -(deftest nset-difference.1 - (nset-difference nil nil) - nil) - -(deftest nset-difference.2 - (let ((result - (nset-difference-with-check '(a b c) nil))) - (check-nset-difference '(a b c) nil result)) - t) - -(deftest nset-difference.3 - (let ((result - (nset-difference-with-check '(a b c d e f) '(f b d)))) - (check-nset-difference '(a b c d e f) '(f b d) result)) - t) - -(deftest nset-difference.4 - (sort - (copy-list - (nset-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) - '(10 101 4 74 2 1391 7 17831))) - #'<) - (1 3 5 6 8)) - -(deftest nset-difference.5 - (nset-difference-with-check nil '(a b c d e f g h)) - nil) - -(deftest nset-difference.6 - (nset-difference-with-check '(a b c d e) '(d a b e) - :key nil) - (c)) - -(deftest nset-difference.7 - (nset-difference-with-check '(a b c d e) '(d a b e) :test #'eq) - (c)) - -(deftest nset-difference.8 - (nset-difference-with-check '(a b c d e) '(d a b e) :test #'eql) - (c)) - -(deftest nset-difference.9 - (nset-difference-with-check '(a b c d e) '(d a b e) :test #'equal) - (c)) - -(deftest nset-difference.10 - (nset-difference-with-check '(a b c d e) '(d a b e) - :test 'eq) - (c)) - -(deftest nset-difference.11 - (nset-difference-with-check '(a b c d e) '(d a b e) - :test 'eql) - (c)) - -(deftest nset-difference.12 - (nset-difference-with-check '(a b c d e) '(d a b e) - :test 'equal) - (c)) - -(deftest nset-difference.13 - (do-random-nset-differences 100 100) - nil) - -(deftest nset-difference.14 - (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) - '((a . 1) (c . 3)) - :key 'car) - ((b . 2))) - -(deftest nset-difference.15 - (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) - '((a . 1) (c . 3)) - :key #'car) - ((b . 2))) - -;; -;; Verify that the :test argument is called with the arguments -;; in the correct order -;; -(deftest nset-difference.16 - (block fail - (sort - (copy-list - (nset-difference-with-check - '(1 2 3 4) '(e f g h) - :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.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)))) - #'<)) - (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))))) - #'<)) - (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))))) - #'<)) - (1 2 3 4)) - -;;; Order of argument evaluation tests - -(deftest nset-difference.order.1 - (let ((i 0) x y) - (values - (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4))) - i x y)) - (1) 2 1 2) - -(deftest nset-difference.order.2 - (let ((i 0) x y z) - (values - (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4)) - :test (progn (setf z (incf i)) - #'(lambda (x y) (= x (1- y))))) - i x y z)) - (4) 3 1 2 3) - -(deftest nset-difference.order.3 - (let ((i 0) x y z w) - (values - (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4)) - :test (progn (setf z (incf i)) - #'(lambda (x y) (= x (1- y)))) - :key (progn (setf w (incf i)) nil)) - i x y z w)) - (4) 4 1 2 3 4) - - -;;; Keyword tests - -(deftest nset-difference.allow-other-keys.1 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :bad t :allow-other-keys t)) - #'<) - (1 5)) - -(deftest nset-difference.allow-other-keys.2 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t :bad t)) - #'<) - (1 5)) - -(deftest nset-difference.allow-other-keys.3 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y))))) - #'<) - (4 5)) - -(deftest nset-difference.allow-other-keys.4 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t)) - #'<) - (1 5)) - -(deftest nset-difference.allow-other-keys.5 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys nil)) - #'<) - (1 5)) - -(deftest nset-difference.allow-other-keys.6 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t - :allow-other-keys nil)) - #'<) - (1 5)) - -(deftest nset-difference.allow-other-keys.7 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t - :allow-other-keys nil - '#:x 1)) - #'<) - (1 5)) - -(deftest nset-difference.keywords.8 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :test #'eql :test (complement #'eql))) - #'<) - (1 5)) - -(deftest nset-difference.keywords.9 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :test (complement #'eql) :test #'eql)) - #'<) - nil) - -;;; Error tests - -(deftest nset-difference.error.1 - (classify-error (nset-difference)) - program-error) - -(deftest nset-difference.error.2 - (classify-error (nset-difference nil)) - program-error) - -(deftest nset-difference.error.3 - (classify-error (nset-difference nil nil :bad t)) - program-error) - -(deftest nset-difference.error.4 - (classify-error (nset-difference nil nil :key)) - program-error) - -(deftest nset-difference.error.5 - (classify-error (nset-difference nil nil 1 2)) - program-error) - -(deftest nset-difference.error.6 - (classify-error (nset-difference nil nil :bad t :allow-other-keys nil)) - program-error) - -(deftest nset-difference.error.7 - (classify-error (nset-difference (list 1 2) (list 3 4) :test #'identity)) - program-error) - -(deftest nset-difference.error.8 - (classify-error (nset-difference (list 1 2) (list 3 4) :test-not #'identity)) - program-error) - -(deftest nset-difference.error.9 - (classify-error (nset-difference (list 1 2) (list 3 4) :key #'cons)) - program-error) - -(deftest nset-difference.error.10 - (classify-error (nset-difference (list 1 2) (list 3 4) :key #'car)) - type-error) - -(deftest nset-difference.error.11 - (classify-error (nset-difference (list 1 2 3) (list* 4 5 6))) - type-error) - -(deftest nset-difference.error.12 - (classify-error (nset-difference (list* 1 2 3) (list 4 5 6))) - type-error) diff --git a/ansi-tests/cons-test-23.lsp b/ansi-tests/cons-test-23.lsp deleted file mode 100644 index bf2ad7a360881d8ac9232252e4b11d05654c4176..0000000000000000000000000000000000000000 --- a/ansi-tests/cons-test-23.lsp +++ /dev/null @@ -1,719 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Apr 1 21:49:43 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 23 - -(in-package :cl-test) - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; set-exclusive-or - -(deftest set-exclusive-or.1 - (set-exclusive-or nil nil) - nil) - -(deftest set-exclusive-or.2 - (let ((result - (set-exclusive-or-with-check '(a b c) nil))) - (check-set-exclusive-or '(a b c) nil result)) - t) - -(deftest set-exclusive-or.3 - (let ((result - (set-exclusive-or-with-check '(a b c d e f) '(f b d)))) - (check-set-exclusive-or '(a b c d e f) '(f b d) result)) - t) - -(deftest set-exclusive-or.4 - (sort - (copy-list - (set-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) - '(10 101 4 74 2 1391 7 17831))) - #'<) - (1 3 5 6 8 10 74 101 1391 17831)) - -(deftest set-exclusive-or.5 - (check-set-exclusive-or - nil - '(a b c d e f g h) - (set-exclusive-or-with-check nil '(a b c d e f g h))) - t) - -(deftest set-exclusive-or.6 - (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :key nil) - (c)) - -(deftest set-exclusive-or.7 - (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eq) - (c)) - -(deftest set-exclusive-or.7-a - (set-exclusive-or-with-check '(d a b e) '(a b c d e) :test #'eq) - (c)) - -(deftest set-exclusive-or.8 - (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eql) - (c)) - -(deftest set-exclusive-or.8-a - (set-exclusive-or-with-check '(e d b a) '(a b c d e) :test #'eql) - (c)) - -(deftest set-exclusive-or.8-b - (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :test-not (complement #'eql)) - (c)) - -(deftest set-exclusive-or.9 - (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'equal) - (c)) - -(deftest set-exclusive-or.10 - (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'eq) - (c)) - -(deftest set-exclusive-or.11 - (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'eql) - (c)) - -(deftest set-exclusive-or.12 - (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'equal) - (c)) - -;;; (deftest set-exclusive-or.13 -;;; (do-random-set-exclusive-ors 100 100) -;;; nil) - -(deftest set-exclusive-or.14 - (set-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) - '((a . 10) (c . 3)) - :key 'car) - ((b . 2))) - -(deftest set-exclusive-or.15 - (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) - '((a . 1) (c . 3313)) - :key #'car) - ((b . 2))) - -(deftest set-exclusive-or.16 - (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) - '((a . 1) (c . 3313)) - :key #'car - :test-not (complement #'eql)) - ((b . 2))) - -;; -;; Check that set-exclusive-or does not invert -;; the order of the arguments to the test function -;; -(deftest set-exclusive-or.17 - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (set-exclusive-or-with-check - list1 list2 - :test #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed))))))) - t) - -(deftest set-exclusive-or.17-a - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (set-exclusive-or-with-check - list1 list2 - :key #'identity - :test #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed))))))) - t) - -(deftest set-exclusive-or.18 - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (set-exclusive-or-with-check - list1 list2 - :test-not - #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed)) - t))))) - t) - -(deftest set-exclusive-or.18-a - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (set-exclusive-or-with-check - list1 list2 - :key #'identity - :test-not - #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed)) - t))))) - t) - -;;; Order of argument evaluation tests - -(deftest set-exclusive-or.order.1 - (let ((i 0) x y) - (values - (sort - (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10))) - #'<) - i x y)) - (2 4 6 10) 2 1 2) - -(deftest set-exclusive-or.order.2 - (let ((i 0) x y z) - (values - (sort - (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :test (progn (setf z (incf i)) - #'eql)) - #'<) - i x y z)) - (2 4 6 10) 3 1 2 3) - -(deftest set-exclusive-or.order.3 - (let ((i 0) x y z w) - (values - (sort - (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :test (progn (setf z (incf i)) - #'eql) - :key (progn (setf w (incf i)) nil)) - #'<) - i x y z w)) - (2 4 6 10) 4 1 2 3 4) - -(deftest set-exclusive-or.order.4 - (let ((i 0) x y z w) - (values - (sort - (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :key (progn (setf z (incf i)) nil) - :test (progn (setf w (incf i)) - #'eql)) - #'<) - i x y z w)) - (2 4 6 10) 4 1 2 3 4) - -(deftest set-exclusive-or.order.5 - (let ((i 0) x y z w) - (values - (sort - (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :key (progn (setf z (incf i)) nil) - :key (progn (setf w (incf i)) - (complement #'eql))) - #'<) - i x y z w)) - (2 4 6 10) 4 1 2 3 4) - - -;;; Keyword tests - -(deftest set-exclusive.allow-other-keys.1 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :bad t :allow-other-keys t) - #'<) - (1 2 5 6)) - -(deftest set-exclusive.allow-other-keys.2 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t :bad t) - #'<) - (1 2 5 6)) - -(deftest set-exclusive.allow-other-keys.3 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t :bad t - :test #'(lambda (x y) (= x (1- y)))) - #'<) - (1 6)) - -(deftest set-exclusive.allow-other-keys.4 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t) - #'<) - (1 2 5 6)) - -(deftest set-exclusive.allow-other-keys.5 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys nil) - #'<) - (1 2 5 6)) - -(deftest set-exclusive.allow-other-keys.6 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t - :allow-other-keys nil) - #'<) - (1 2 5 6)) - -(deftest set-exclusive.allow-other-keys.7 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t - :allow-other-keys nil - '#:x 1) - #'<) - (1 2 5 6)) - -(deftest set-exclusive.keywords.8 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :test #'eql - :test #'/=) - #'<) - (1 2 5 6)) - -(deftest set-exclusive.keywords.9 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :test #'/= - :test #'eql) - #'<) - nil) - -(deftest set-exclusive-or.error.1 - (classify-error (set-exclusive-or)) - program-error) - -(deftest set-exclusive-or.error.2 - (classify-error (set-exclusive-or nil)) - program-error) - -(deftest set-exclusive-or.error.3 - (classify-error (set-exclusive-or nil nil :bad t)) - program-error) - -(deftest set-exclusive-or.error.4 - (classify-error (set-exclusive-or nil nil :key)) - program-error) - -(deftest set-exclusive-or.error.5 - (classify-error (set-exclusive-or nil nil 1 2)) - program-error) - -(deftest set-exclusive-or.error.6 - (classify-error (set-exclusive-or nil nil :bad t :allow-other-keys nil)) - program-error) - -(deftest set-exclusive-or.error.7 - (classify-error (set-exclusive-or (list 1 2) (list 3 4) :test #'identity)) - program-error) - -(deftest set-exclusive-or.error.8 - (classify-error (set-exclusive-or (list 1 2) (list 3 4) :test-not #'identity)) - program-error) - -(deftest set-exclusive-or.error.9 - (classify-error (set-exclusive-or (list 1 2) (list 3 4) :key #'cons)) - program-error) - -(deftest set-exclusive-or.error.10 - (classify-error (set-exclusive-or (list 1 2) (list 3 4) :key #'car)) - type-error) - -(deftest set-exclusive-or.error.11 - (classify-error (set-exclusive-or (list 1 2 3) (list* 4 5 6))) - type-error) - -(deftest set-exclusive-or.error.12 - (classify-error (set-exclusive-or (list* 1 2 3) (list 4 5 6))) - type-error) - - -;;; Randomized test - -(deftest random-set-exclusive-or - (random-set-exclusive-or-test 10 100) - nil) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; nset-exclusive-or - -(deftest nset-exclusive-or.1 - (nset-exclusive-or nil nil) - nil) - -(deftest nset-exclusive-or.2 - (let ((result - (nset-exclusive-or-with-check '(a b c) nil))) - (check-set-exclusive-or '(a b c) nil result)) - t) - -(deftest nset-exclusive-or.3 - (let ((result - (nset-exclusive-or-with-check '(a b c d e f) '(f b d)))) - (check-set-exclusive-or '(a b c d e f) '(f b d) result)) - t) - -(deftest nset-exclusive-or.4 - (sort - (copy-list - (nset-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) - '(10 101 4 74 2 1391 7 17831))) - #'<) - (1 3 5 6 8 10 74 101 1391 17831)) - -(deftest nset-exclusive-or.5 - (check-set-exclusive-or - nil - '(a b c d e f g h) - (nset-exclusive-or-with-check nil '(a b c d e f g h))) - t) - -(deftest nset-exclusive-or.6 - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :key nil) - (c)) - -(deftest nset-exclusive-or.7 - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eq) - (c)) - -(deftest nset-exclusive-or.7-a - (nset-exclusive-or-with-check '(d a b e) '(a b c d e) :test #'eq) - (c)) - -(deftest nset-exclusive-or.8 - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eql) - (c)) - -(deftest nset-exclusive-or.8-a - (nset-exclusive-or-with-check '(e d b a) '(a b c d e) :test #'eql) - (c)) - -(deftest nset-exclusive-or.8-b - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :test-not (complement #'eql)) - (c)) - -(deftest nset-exclusive-or.9 - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'equal) - (c)) - -(deftest nset-exclusive-or.10 - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'eq) - (c)) - -(deftest nset-exclusive-or.11 - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'eql) - (c)) - -(deftest nset-exclusive-or.12 - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'equal) - (c)) - -;;; (deftest nset-exclusive-or.13 -;;; (do-random-nset-exclusive-ors 100 100) -;;; nil) - -(deftest nset-exclusive-or.14 - (nset-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) - '((a . 10) (c . 3)) - :key 'car) - ((b . 2))) - -(deftest nset-exclusive-or.15 - (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) - '((a . 1) (c . 3313)) - :key #'car) - ((b . 2))) - -(deftest nset-exclusive-or.16 - (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) - '((a . 1) (c . 3313)) - :key #'car - :test-not (complement #'eql)) - ((b . 2))) - -;; -;; Check that nset-exclusive-or does not invert -;; the order of the arguments to the test function -;; -(deftest nset-exclusive-or.17 - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (nset-exclusive-or-with-check - list1 list2 - :test #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed))))))) - t) - -(deftest nset-exclusive-or.17-a - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (nset-exclusive-or-with-check - list1 list2 - :key #'identity - :test #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed))))))) - t) - -(deftest nset-exclusive-or.18 - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (nset-exclusive-or-with-check - list1 list2 - :test-not - #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed)) - t))))) - t) - -(deftest nset-exclusive-or.18-a - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (nset-exclusive-or-with-check - list1 list2 - :key #'identity - :test-not - #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed)) - t))))) - t) - -;;; Order of argument evaluation tests - -(deftest nset-exclusive-or.order.1 - (let ((i 0) x y) - (values - (sort - (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10))) - #'<) - i x y)) - (2 4 6 10) 2 1 2) - -(deftest nset-exclusive-or.order.2 - (let ((i 0) x y z) - (values - (sort - (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :test (progn (setf z (incf i)) - #'eql)) - #'<) - i x y z)) - (2 4 6 10) 3 1 2 3) - -(deftest nset-exclusive-or.order.3 - (let ((i 0) x y z w) - (values - (sort - (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :test (progn (setf z (incf i)) - #'eql) - :key (progn (setf w (incf i)) nil)) - #'<) - i x y z w)) - (2 4 6 10) 4 1 2 3 4) - -(deftest nset-exclusive-or.order.4 - (let ((i 0) x y z w) - (values - (sort - (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :key (progn (setf z (incf i)) nil) - :test (progn (setf w (incf i)) - #'eql)) - #'<) - i x y z w)) - (2 4 6 10) 4 1 2 3 4) - -(deftest nset-exclusive-or.order.5 - (let ((i 0) x y z w) - (values - (sort - (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :key (progn (setf z (incf i)) nil) - :key (progn (setf w (incf i)) - (complement #'eql))) - #'<) - i x y z w)) - (2 4 6 10) 4 1 2 3 4) - - -;;; Keyword tests - -(deftest nset-exclusive.allow-other-keys.1 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :bad t :allow-other-keys t) - #'<) - (1 2 5 6)) - -(deftest nset-exclusive.allow-other-keys.2 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t :bad t) - #'<) - (1 2 5 6)) - -(deftest nset-exclusive.allow-other-keys.3 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t :bad t - :test #'(lambda (x y) (= x (1- y)))) - #'<) - (1 6)) - -(deftest nset-exclusive.allow-other-keys.4 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t) - #'<) - (1 2 5 6)) - -(deftest nset-exclusive.allow-other-keys.5 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys nil) - #'<) - (1 2 5 6)) - -(deftest nset-exclusive.allow-other-keys.6 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t - :allow-other-keys nil) - #'<) - (1 2 5 6)) - -(deftest nset-exclusive.allow-other-keys.7 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t - :allow-other-keys nil - '#:x 1) - #'<) - (1 2 5 6)) - -(deftest nset-exclusive.keywords.8 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :test #'eql - :test #'/=) - #'<) - (1 2 5 6)) - -(deftest nset-exclusive.keywords.9 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :test #'/= - :test #'eql) - #'<) - nil) - -;;; Randomized test - -(deftest random-nset-exclusive-or - (random-set-exclusive-or-test 10 1000 'nset-exclusive-or) - nil) - -;;; Error tests - -(deftest nset-exclusive-or.error.1 - (classify-error (nset-exclusive-or)) - program-error) - -(deftest nset-exclusive-or.error.2 - (classify-error (nset-exclusive-or nil)) - program-error) - -(deftest nset-exclusive-or.error.3 - (classify-error (nset-exclusive-or nil nil :bad t)) - program-error) - -(deftest nset-exclusive-or.error.4 - (classify-error (nset-exclusive-or nil nil :key)) - program-error) - -(deftest nset-exclusive-or.error.5 - (classify-error (nset-exclusive-or nil nil 1 2)) - program-error) - -(deftest nset-exclusive-or.error.6 - (classify-error (nset-exclusive-or nil nil :bad t :allow-other-keys nil)) - program-error) - -(deftest nset-exclusive-or.error.7 - (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :test #'identity)) - program-error) - -(deftest nset-exclusive-or.error.8 - (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :test-not #'identity)) - program-error) - -(deftest nset-exclusive-or.error.9 - (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'cons)) - program-error) - -(deftest nset-exclusive-or.error.10 - (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'car)) - type-error) - -(deftest nset-exclusive-or.error.11 - (classify-error (nset-exclusive-or (list 1 2 3) (list* 4 5 6))) - type-error) - -(deftest nset-exclusive-or.error.12 - (classify-error (nset-exclusive-or (list* 1 2 3) (list 4 5 6))) - type-error) diff --git a/ansi-tests/cons-test-25.lsp b/ansi-tests/cons-test-25.lsp deleted file mode 100644 index baa1544da1835bfaee29a65eecfde0ee3f99b350..0000000000000000000000000000000000000000 --- a/ansi-tests/cons-test-25.lsp +++ /dev/null @@ -1,56 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 5 22:26:59 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 25 - -(in-package :cl-test) - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; setting of C*R accessors - -(loop - for fn in '(car cdr caar cadr cdar cddr - caaar caadr cadar caddr cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) - do - (let ((level (- (length (symbol-name fn)) 2))) - (eval `(deftest ,(intern - (concatenate 'string - (symbol-name fn) - "-SET-ALT") - :cl-test) - (let ((x (create-c*r-test ,level))) - (and - (setf (,fn x) 'a) - (eql (,fn x) 'a) - (setf (,fn x) 'none) - (equal x (create-c*r-test ,level)) - )) - t)))) - -(loop - for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) - (fifth 5) (sixth 6) (seventh 7) (eighth 8) - (ninth 9) (tenth 10)) - do - (eval - `(deftest ,(intern - (concatenate 'string - (symbol-name fn) - "-SET-ALT") - :cl-test) - (let ((x (make-list 20 :initial-element nil))) - (and - (setf (,fn x) 'a) - (loop - for i from 1 to 20 - do (when (and (not (eql i ,len)) - (nth (1- i) x)) - (return nil)) - finally (return t)) - (eql (,fn x) 'a) - (nth ,(1- len) x))) - a))) diff --git a/ansi-tests/cons.lsp b/ansi-tests/cons.lsp new file mode 100644 index 0000000000000000000000000000000000000000..50ef5bfeaa579a0dccf78cc781f7a291cafb055c --- /dev/null +++ b/ansi-tests/cons.lsp @@ -0,0 +1,46 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:24:25 2003 +;;;; Contains: Tests for CONS + +(in-package :cl-test) + +;; Various easy tests of cons +(deftest cons-of-symbols + (cons 'a 'b) + (a . b)) + +(deftest cons-with-nil + (cons 'a nil) + (a)) + +;; successive calls to cons produces results that are equal, but not eq +(deftest cons-eq-equal + (let ((x (cons 'a 'b)) + (y (cons 'a 'b))) + (and (not (eqt x y)) + (equalt x y))) + t) + +;; list can be expressed as a bunch of conses (with nil) +(deftest cons-equal-list + (equalt (cons 'a (cons 'b (cons 'c nil))) + (list 'a 'b 'c)) + t) + +;;; Order of evaluation of cons arguments +(deftest cons.order.1 + (let ((i 0)) (values (cons (incf i) (incf i)) i)) + (1 . 2) 2) + +(deftest cons.error.1 + (classify-error (cons)) + program-error) + +(deftest cons.error.2 + (classify-error (cons 'a)) + program-error) + +(deftest cons.error.3 + (classify-error (cons 'a 'b 'c)) + program-error) diff --git a/ansi-tests/consp.lsp b/ansi-tests/consp.lsp new file mode 100644 index 0000000000000000000000000000000000000000..72a5b97e2b684b0d804c527417e67c495b4e73b4 --- /dev/null +++ b/ansi-tests/consp.lsp @@ -0,0 +1,59 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:27:16 2003 +;;;; Contains: Tests of CONSP + +(in-package :cl-test) + +;; Lists satisfy consp +(deftest consp-list + (notnot-mv (consp '(a))) + t) + +;; cons satisfies consp +(deftest consp-cons + (notnot-mv (consp (cons nil nil))) + t) + +;; nil is not a consp +(deftest consp-nil + (consp nil) + nil) + +;; The empty list is not a cons +(deftest consp-empty-list + (consp (list)) + nil) + +;; A single element list is a cons +(deftest consp-single-element-list + (notnot-mv (consp (list 'a))) + t) + +;; For everything in *universe*, it is either an atom, or satisfies +;; consp, but not both +(deftest consp-xor-atom-universe + (notnot-mv + (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 +(deftest consp-cons-universe + (check-type-predicate 'consp 'cons) + 0) + +(deftest consp.order.1 + (let ((i 0)) + (values (consp (incf i)) i)) + nil 1) + +(deftest consp.error.1 + (classify-error (consp)) + program-error) + +(deftest consp.error.2 + (classify-error (consp 'a 'b)) + program-error) + diff --git a/ansi-tests/copy-alist.lsp b/ansi-tests/copy-alist.lsp new file mode 100644 index 0000000000000000000000000000000000000000..b0c425128e7d12368ec783bd36e79fa8591815a4 --- /dev/null +++ b/ansi-tests/copy-alist.lsp @@ -0,0 +1,36 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:29:07 2003 +;;;; Contains: Tests of COPY-ALIST + +(in-package :cl-test) + +(deftest copy-alist.1 + (let* ((x (copy-tree '((a . b) (c . d) nil (e f) ((x) ((y z)) w) + ("foo" . "bar") (#\w . 1.234) + (1/3 . 4123.4d5)))) + (xcopy (make-scaffold-copy x)) + (result (copy-alist x))) + (and + (check-scaffold-copy x xcopy) + (= (length x) (length result)) + (every #'(lambda (p1 p2) + (or (and (null p1) (null p2)) + (and (not (eqt p1 p2)) + (eqlt (car p1) (car p2)) + (eqlt (cdr p1) (cdr p2))))) + x result) + t)) + t) + +(deftest copy-alist.error.1 + (classify-error (copy-alist)) + program-error) + +(deftest copy-alist.error.2 + (classify-error (copy-alist nil nil)) + program-error) + +(deftest copy-alist.error.3 + (classify-error (copy-alist '((a . b) . c))) + type-error) diff --git a/ansi-tests/copy-list.lsp b/ansi-tests/copy-list.lsp new file mode 100644 index 0000000000000000000000000000000000000000..831b4858132fc74a1cc4e39c941b54f3b1ae469b --- /dev/null +++ b/ansi-tests/copy-list.lsp @@ -0,0 +1,34 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:55:19 2003 +;;;; Contains: Tests of COPY-LIST + +(in-package :cl-test) + +(deftest copy-list.1 + (check-copy-list '(a b c d)) + (a b c d)) + +;; Check that copy-list works on dotted lists + +(deftest copy-list.2 + (check-copy-list '(a . b)) + (a . b)) + +(deftest copy-list.3 + (check-copy-list '(a b c . d)) + (a b c . d)) + +(deftest copy-list.4 + (let ((i 0)) + (values (copy-list (progn (incf i) '(a b c))) + i)) + (a b c) 1) + +(deftest copy-list.error.1 + (classify-error (copy-list)) + program-error) + +(deftest copy-list.error.2 + (classify-error (copy-list nil nil)) + program-error) diff --git a/ansi-tests/copy-tree.lsp b/ansi-tests/copy-tree.lsp new file mode 100644 index 0000000000000000000000000000000000000000..5727bbd8df8cfba9c4d0872dd6a704c795a76a76 --- /dev/null +++ b/ansi-tests/copy-tree.lsp @@ -0,0 +1,41 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:31:33 2003 +;;;; Contains: Tests of COPY-TREE + +(in-package :cl-test) + +;; Try copy-tree on a tree containing elements of various kinds +(deftest copy-tree.1 + (let* ((x (cons 'a (list + (cons 'b 'c) + (cons 1 1.2) + (list (list "abcde" + (make-array '(10) :initial-element + (cons 'e 'f))) + 'g)))) + (y (copy-tree x))) + (check-cons-copy x y)) + t) + +;; Try copy-tree on *universe* +(deftest copy-tree.2 + (let* ((x (copy-list *universe*)) + (y (copy-tree x))) + (check-cons-copy x y)) + t) + +(deftest copy-tree.order.1 + (let ((i 0)) + (values + (copy-tree (progn (incf i) '(a b c))) + i)) + (a b c) 1) + +(deftest copy-tree.error.1 + (classify-error (copy-tree)) + program-error) + +(deftest copy-tree.error.2 + (classify-error (copy-tree 'a 'b)) + program-error) diff --git a/ansi-tests/cons-test-08.lsp b/ansi-tests/cxr.lsp similarity index 72% rename from ansi-tests/cons-test-08.lsp rename to ansi-tests/cxr.lsp index 6b1e3f001edb7de8e75a109f1a69b8df85480f08..b69daaa03940f47e79ced78fddcab88b72c5b7b2 100644 --- a/ansi-tests/cons-test-08.lsp +++ b/ansi-tests/cxr.lsp @@ -1,14 +1,142 @@ ;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:36:01 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 8 +;;;; Created: Sat Apr 19 21:28:38 2003 +;;;; Contains: Tests of C*R functions (in-package :cl-test) -(declaim (optimize (safety 3))) +;; Tests of car, cdr and compound forms +(deftest cons.23 + (car '(a)) + a) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Error checking car, cdr, list-length +(deftest cons.24 + (cdr '(a . b)) + b) + +(deftest cons.25 + (caar '((a))) + a) + +(deftest cons.26 + (cdar '((a . b))) + b) + +(deftest cons.27 + (cadr '(a b)) + b) + +(deftest cons.28 + (cddr '(a b . c)) + c) + +(deftest cons.29 + (caaar '(((a)))) + a) + +(deftest cons.30 + (cdaar '(((a . b)))) + b) + +(deftest cons.31 + (cadar (cons (cons 'a (cons 'b 'c)) 'd)) + b) + +(deftest cons.32 + (cddar (cons (cons 'a (cons 'b 'c)) 'd)) + c) + +(deftest cons.33 + (caadr (cons 'a (cons (cons 'b 'c) 'd))) + b) + +(deftest cons.34 + (caddr (cons 'a (cons 'b (cons 'c 'd)))) + c) + +(deftest cons.36 + (cdadr (cons 'a (cons (cons 'b 'c) 'd))) + c) + +(deftest cons.37 + (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))))) + +(deftest cons.38 + (caaaar *cons-test-4*) + a) + +(deftest cons.39 + (cdaaar *cons-test-4*) + b) + +(deftest cons.40 + (cadaar *cons-test-4*) + c) + +(deftest cons.41 + (cddaar *cons-test-4*) + d) + +(deftest cons.42 + (caadar *cons-test-4*) + e) + +(deftest cons.43 + (cdadar *cons-test-4*) + f) + +(deftest cons.44 + (caddar *cons-test-4*) + g) + +(deftest cons.45 + (cdddar *cons-test-4*) + h) + +;;; + +(deftest cons.46 + (caaadr *cons-test-4*) + i) + +(deftest cons.47 + (cdaadr *cons-test-4*) + j) + +(deftest cons.48 + (cadadr *cons-test-4*) + k) + +(deftest cons.49 + (cddadr *cons-test-4*) + l) + +(deftest cons.50 + (caaddr *cons-test-4*) + m) + +(deftest cons.51 + (cdaddr *cons-test-4*) + n) + +(deftest cons.52 + (cadddr *cons-test-4*) + o) + +(deftest cons.53 + (cddddr *cons-test-4*) + p) (deftest car.1 (car '(a)) @@ -52,18 +180,6 @@ (classify-error (locally (cdr 'a) t)) type-error) -(deftest list-length.4 - (list-length (copy-tree '(a b c))) - 3) - -(deftest list-length-symbol - (classify-error (list-length 'a)) - type-error) - -(deftest list-length-dotted-list - (classify-error (list-length (copy-tree '(a b c d . e)))) - type-error) - ;;; Error checking of c*r functions (deftest caar.error.1 @@ -453,3 +569,51 @@ type-error) ;;; Need to add 'locally' wrapped forms of these + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; setting of C*R accessors + +(loop + for fn in '(car cdr caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) + do + (let ((level (- (length (symbol-name fn)) 2))) + (eval `(deftest ,(intern + (concatenate 'string + (symbol-name fn) + "-SET-ALT") + :cl-test) + (let ((x (create-c*r-test ,level))) + (and + (setf (,fn x) 'a) + (eql (,fn x) 'a) + (setf (,fn x) 'none) + (equal x (create-c*r-test ,level)) + )) + t)))) + +(loop + for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) + (fifth 5) (sixth 6) (seventh 7) (eighth 8) + (ninth 9) (tenth 10)) + do + (eval + `(deftest ,(intern + (concatenate 'string + (symbol-name fn) + "-SET-ALT") + :cl-test) + (let ((x (make-list 20 :initial-element nil))) + (and + (setf (,fn x) 'a) + (loop + for i from 1 to 20 + do (when (and (not (eql i ,len)) + (nth (1- i) x)) + (return nil)) + finally (return t)) + (eql (,fn x) 'a) + (nth ,(1- len) x))) + a))) diff --git a/ansi-tests/cons-test-06.lsp b/ansi-tests/endp.lsp similarity index 89% rename from ansi-tests/cons-test-06.lsp rename to ansi-tests/endp.lsp index 211003fb66dfd105cf0cd977310f855ba1c317a5..12b66c17d023e9e9cb61cdc45694f3021a4f0a2e 100644 --- a/ansi-tests/cons-test-06.lsp +++ b/ansi-tests/endp.lsp @@ -1,12 +1,10 @@ ;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:34:40 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 6 +;;;; Contains: Tests of ENDP (in-package :cl-test) -(declaim (optimize (safety 3))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; endp diff --git a/ansi-tests/get-properties.lsp b/ansi-tests/get-properties.lsp new file mode 100644 index 0000000000000000000000000000000000000000..147d71b0b8094951fdd7351c8b7cc0f854343757 --- /dev/null +++ b/ansi-tests/get-properties.lsp @@ -0,0 +1,86 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:37:00 2003 +;;;; Contains: Tests of GET-PROPERTIES + +(in-package :cl-test) + +(deftest get-properties.1 + (get-properties nil nil) + nil nil nil) + +(deftest get-properties.2 + (get-properties '(a b) nil) + nil nil nil) + +(deftest get-properties.3 + (get-properties '(a b c d) '(a)) + a b (a b c d)) + +(deftest get-properties.4 + (get-properties '(a b c d) '(c)) + c d (c d)) + +(deftest get-properties.5 + (get-properties '(a b c d) '(c a)) + a b (a b c d)) + +(deftest get-properties.6 + (get-properties '(a b c d) '(b)) + nil nil nil) + +(deftest get-properties.7 + (get-properties '("aa" b c d) (list (copy-seq "aa"))) + nil nil nil) + +(deftest get-properties.8 + (get-properties '(1000000000000 b c d) (list (1+ 999999999999))) + nil nil nil) + +(deftest get-properties.9 + (let* ((x (copy-list '(a b c d e f g h a c))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(x y f g))) + (ycopy (make-scaffold-copy y))) + (multiple-value-bind + (indicator value tail) + (get-properties x y) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (eqt tail (nthcdr 6 x)) + (values indicator value tail)))) + g h (g h a c)) + +(deftest get-properties.order.1 + (let ((i 0) x y) + (values + (multiple-value-list + (get-properties (progn (setf x (incf i)) '(a b c d)) + (progn (setf y (incf i)) '(c)))) + i x y)) + (c d (c d)) 2 1 2) + +(deftest get-properties.error.1 + (classify-error (get-properties)) + program-error) + +(deftest get-properties.error.2 + (classify-error (get-properties nil)) + program-error) + +(deftest get-properties.error.3 + (classify-error (get-properties nil nil nil)) + program-error) + +(deftest get-properties.error.4 + (classify-error (get-properties '(a 1 b 2 c 3) '(x . y))) + type-error) + +(deftest get-properties.error.5 + (classify-error (get-properties '(a 1 b 2 c 3 . d) '(x y))) + type-error) + +(deftest get-properties.error.6 + (classify-error (get-properties '(a 1 b 2 c . d) '(x y))) + type-error) diff --git a/ansi-tests/cons-test-18.lsp b/ansi-tests/getf.lsp similarity index 61% rename from ansi-tests/cons-test-18.lsp rename to ansi-tests/getf.lsp index 771dd9d508ed22239ab77bcb150e01ea69b098c9..7627fe03fcd94623535819a24df1fdec0396dec3 100644 --- a/ansi-tests/cons-test-18.lsp +++ b/ansi-tests/getf.lsp @@ -1,99 +1,10 @@ ;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 10:23:31 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 18 +;;;; Created: Sun Apr 20 07:37:41 2003 +;;;; Contains: Tests of GETF (in-package :cl-test) -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; get-properties - -(deftest get-properties.1 - (get-properties nil nil) - nil nil nil) - -(deftest get-properties.2 - (get-properties '(a b) nil) - nil nil nil) - -(deftest get-properties.3 - (get-properties '(a b c d) '(a)) - a b (a b c d)) - -(deftest get-properties.4 - (get-properties '(a b c d) '(c)) - c d (c d)) - -(deftest get-properties.5 - (get-properties '(a b c d) '(c a)) - a b (a b c d)) - -(deftest get-properties.6 - (get-properties '(a b c d) '(b)) - nil nil nil) - -(deftest get-properties.7 - (get-properties '("aa" b c d) (list (copy-seq "aa"))) - nil nil nil) - -(deftest get-properties.8 - (get-properties '(1000000000000 b c d) (list (1+ 999999999999))) - nil nil nil) - -(deftest get-properties.9 - (let* ((x (copy-list '(a b c d e f g h a c))) - (xcopy (make-scaffold-copy x)) - (y (copy-list '(x y f g))) - (ycopy (make-scaffold-copy y))) - (multiple-value-bind - (indicator value tail) - (get-properties x y) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - (eqt tail (nthcdr 6 x)) - (values indicator value tail)))) - g h (g h a c)) - -(deftest get-properties.order.1 - (let ((i 0) x y) - (values - (multiple-value-list - (get-properties (progn (setf x (incf i)) '(a b c d)) - (progn (setf y (incf i)) '(c)))) - i x y)) - (c d (c d)) 2 1 2) - -(deftest get-properties.error.1 - (classify-error (get-properties)) - program-error) - -(deftest get-properties.error.2 - (classify-error (get-properties nil)) - program-error) - -(deftest get-properties.error.3 - (classify-error (get-properties nil nil nil)) - program-error) - -(deftest get-properties.error.4 - (classify-error (get-properties '(a 1 b 2 c 3) '(x . y))) - type-error) - -(deftest get-properties.error.5 - (classify-error (get-properties '(a 1 b 2 c 3 . d) '(x y))) - type-error) - -(deftest get-properties.error.6 - (classify-error (get-properties '(a 1 b 2 c . d) '(x y))) - type-error) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; getf - (deftest getf.1 (getf nil 'a) nil) @@ -315,44 +226,3 @@ (deftest getf.error.5 (classify-error (getf '(a 10 . b) 'c)) type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; remf - -(deftest remf.1 - (let ((x nil)) - (values (remf x 'a) x)) - nil ()) - -(deftest remf.2 - (let ((x (list 'a 'b))) - (values (not (null (remf x 'a))) x)) - t ()) - -(deftest remf.3 - (let ((x (list 'a 'b 'a 'c))) - (values (not (null (remf x 'a))) x)) - t (a c)) - -(deftest remf.4 - (let ((x (list 'a 'b 'c 'd))) - (values - (and (remf x 'c) t) - (loop - for ptr on x by #'cddr count - (not (eqt (car ptr) 'a))))) - t 0) - -(deftest remf.order.1 - (let ((i 0) x y - (p (make-array 1 :initial-element (copy-list '(a b c d e f))))) - (values - (notnot - (remf (aref p (progn (setf x (incf i)) 0)) - (progn (setf y (incf i)) - 'c))) - (aref p 0) - i x y)) - t (a b e f) 2 1 2) - - \ No newline at end of file diff --git a/ansi-tests/cons-test-19.lsp b/ansi-tests/intersection.lsp similarity index 50% rename from ansi-tests/cons-test-19.lsp rename to ansi-tests/intersection.lsp index f36ccb086c9053a4716b22b55ceafc0bca635850..f4354f5a6052e8ea9672e8d19c4b4a3d46bb3d64 100644 --- a/ansi-tests/cons-test-19.lsp +++ b/ansi-tests/intersection.lsp @@ -1,15 +1,10 @@ ;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 11:53:33 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 19 +;;;; Created: Sun Apr 20 07:39:19 2003 +;;;; Contains: Tests of INTERSECTION (in-package :cl-test) -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; intersection - (deftest intersection.1 (intersection nil nil) nil) @@ -395,360 +390,3 @@ (deftest intersection.error.12 (classify-error (intersection '(a b . c) '(d e f))) type-error) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; nintersection - -(deftest nintersection.1 - (nintersection nil nil) - nil) - -(deftest nintersection.2 - (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)) - 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))))))) - 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)))) - t) - -(deftest nintersection.6 - (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)) - (10)) - -(deftest nintersection.8 - (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) - ("aaa")) - -(deftest nintersection.9-a - (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)))) - ("aaa")) - -(deftest nintersection.10 - (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 - (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) - 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)))) - (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 - (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)) - 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))))) - (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))))) - (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)))))) - (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)))))) - (4)) - -;;; Order of argument evaluation tests - -(deftest nintersection.order.1 - (let ((i 0) x y) - (values - (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd))) - i x y)) - nil 2 1 2) - -(deftest nintersection.order.2 - (let ((i 0) x y) - (values - (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test #'eq) - i x y)) - nil 2 1 2) - -(deftest nintersection.order.3 - (let ((i 0) x y z w) - (values - (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test (progn (setf z (incf i)) #'eq) - :test (progn (setf w (incf i)) - (complement #'eq))) - i x y z w)) - nil 4 1 2 3 4) - -(deftest nintersection.order.4 - (let ((i 0) x y z w) - (values - (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test (progn (setf z (incf i)) #'eq) - :key (progn (setf w (incf i)) #'identity)) - i x y z w)) - nil 4 1 2 3 4) - -(deftest nintersection.order.5 - (let ((i 0) x y z w) - (values - (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :key (progn (setf z (incf i)) #'identity) - :test (progn (setf w (incf i)) #'eq)) - i x y z w)) - nil 4 1 2 3 4) - -;;; Keyword tests - -(deftest nintersection.allow-other-keys.1 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :bad t :allow-other-keys 1)) - (4)) - -(deftest nintersection.allow-other-keys.2 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :allow-other-keys :foo :also-bad t)) - (4)) - -(deftest nintersection.allow-other-keys.3 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :allow-other-keys :foo :also-bad t - :test #'(lambda (x y) (= x (1+ y))))) - nil) - -(deftest nintersection.allow-other-keys.4 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :allow-other-keys t)) - (4)) - -(deftest nintersection.allow-other-keys.5 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :allow-other-keys nil)) - (4)) - -(deftest nintersection.allow-other-keys.6 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :allow-other-keys t - :allow-other-keys nil :bad t)) - (4)) - -(deftest nintersection.allow-other-keys.7 - (sort - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :allow-other-keys t - :allow-other-keys nil - :test #'(lambda (x y) (eql x (1- y))))) - #'<) - (3 4)) - -(deftest nintersection.keywords.8 - (sort - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 - :test #'(lambda (x y) (eql x (1- y))) - :test #'eql)) - #'<) - (3 4)) - -(deftest nintersection.allow-other-keys.9 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :allow-other-keys :foo :also-bad t - :test #'(lambda (x y) (= x (1+ y))))) - nil) - -(deftest nintersection.error.1 - (classify-error (nintersection)) - program-error) - -(deftest nintersection.error.2 - (classify-error (nintersection nil)) - program-error) - -(deftest nintersection.error.3 - (classify-error (nintersection nil nil :bad t)) - program-error) - -(deftest nintersection.error.4 - (classify-error (nintersection nil nil :key)) - program-error) - -(deftest nintersection.error.5 - (classify-error (nintersection nil nil 1 2)) - program-error) - -(deftest nintersection.error.6 - (classify-error (nintersection nil nil :bad t :allow-other-keys nil)) - program-error) - -(deftest nintersection.error.7 - (classify-error (nintersection (list 1 2 3) (list 4 5 6) :test #'identity)) - program-error) - -(deftest nintersection.error.8 - (classify-error (nintersection (list 1 2 3) (list 4 5 6) :test-not #'identity)) - program-error) - -(deftest nintersection.error.9 - (classify-error (nintersection (list 1 2 3) (list 4 5 6) :key #'cons)) - program-error) - -(deftest nintersection.error.10 - (classify-error (nintersection (list 1 2 3) (list 4 5 6) :key #'car)) - type-error) - -(deftest nintersection.error.11 - (classify-error (nintersection (list 1 2 3) (list* 4 5 6 7))) - type-error) - -(deftest nintersection.error.12 - (classify-error (nintersection (list* 1 2 3) (list 4 5 6))) - type-error) diff --git a/ansi-tests/cons-test-10.lsp b/ansi-tests/last.lsp similarity index 95% rename from ansi-tests/cons-test-10.lsp rename to ansi-tests/last.lsp index fc625783cee0fd0347e5d5520037cd138e10abee..52a25cee6077b5d63e39f7eb956cf5565ac7ee20 100644 --- a/ansi-tests/cons-test-10.lsp +++ b/ansi-tests/last.lsp @@ -5,11 +5,6 @@ (in-package :cl-test) -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; last - (deftest last.1 (last nil) nil) diff --git a/ansi-tests/cons-test-11.lsp b/ansi-tests/ldiff.lsp similarity index 63% rename from ansi-tests/cons-test-11.lsp rename to ansi-tests/ldiff.lsp index c807859b653c8902406a1b6321578b3157309340..3c3de969433b0b35da24204129c83860286807e9 100644 --- a/ansi-tests/cons-test-11.lsp +++ b/ansi-tests/ldiff.lsp @@ -1,15 +1,10 @@ ;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:37:56 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 11 +;;;; Created: Sat Apr 19 22:46:56 2003 +;;;; Contains: Tests of LDIFF (in-package :cl-test) -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ldiff, tailp - (deftest ldiff.1 (let* ((x (copy-tree '(a b c d e f))) (xcopy (make-scaffold-copy x))) @@ -167,95 +162,3 @@ (ldiff-12-body) 0) |# - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; tailp - -(deftest tailp.1 - (let ((x (copy-tree '(a b c d e . f)))) - (and - (tailp x x) - (tailp (cdr x) x) - (tailp (cddr x) x) - (tailp (cdddr x) x) - (tailp (cddddr x) x) - t)) - t) - -;; The next four tests test that tailp handles dotted lists. See -;; TAILP-NIL:T in the X3J13 documentation. - -(deftest tailp.2 - (notnot-mv (tailp 'e (copy-tree '(a b c d . e)))) - t) - -(deftest tailp.3 - (tailp 'z (copy-tree '(a b c d . e))) - nil) - -(deftest tailp.4 - (notnot-mv (tailp 10203040506070 - (list* 'a 'b (1- 10203040506071)))) - t) - -(deftest tailp.5 - (let ((x "abcde")) (tailp x (list* 'a 'b (copy-seq x)))) - nil) - -(deftest tailp.error.5 - (classify-error (tailp)) - program-error) - -(deftest tailp.error.6 - (classify-error (tailp nil)) - program-error) - -(deftest tailp.error.7 - (classify-error (tailp nil nil nil)) - program-error) - -;; Test that tailp does not modify its arguments - -(deftest tailp.6 - (let* ((x (copy-list '(a b c d e))) - (y (cddr x))) - (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (and - (tailp y x) - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)))) - t) - -;; Note! The spec is ambiguous on whether this next test -;; is correct. The spec says that tailp should be prepared -;; to signal an error if the list argument is not a proper -;; list or dotted list. If listp is false, the list argument -;; is neither (atoms are not dotted lists). -;; -;; However, the sample implementation *does* work even if -;; the list argument is an atom. -;; - -#| -(defun tailp.7-body () - (loop - for x in *universe* - count (and (not (listp x)) - (eqt 'type-error - (catch-type-error (tailp x x)))))) - -(deftest tailp.7 - (tailp.7-body) - 0) -|# - -(deftest tailp.order.1 - (let ((i 0) x y) - (values - (notnot - (tailp (progn (setf x (incf i)) 'd) - (progn (setf y (incf i)) '(a b c . d)))) - i x y)) - t 2 1 2) - diff --git a/ansi-tests/list-length.lsp b/ansi-tests/list-length.lsp new file mode 100644 index 0000000000000000000000000000000000000000..4002dfd5631b7fe418431ac0494f6e62762aa4dc --- /dev/null +++ b/ansi-tests/list-length.lsp @@ -0,0 +1,70 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:03:01 2003 +;;;; Contains: Tests of LIST-LENGTH + +(in-package :cl-test) + +(deftest list-length-nil + (list-length nil) + 0) + +(deftest list-length-list + (list-length '(a b c d e f)) + 6) + +;; check that list-length returns nil +;; on a circular list + +(deftest list-length-circular-list + (let ((x (cons nil nil))) + (let ((y (list* 1 2 3 4 5 6 7 8 9 x))) + (setf (cdr x) y) + (let ((z (list* 'a 'b 'c 'd 'e y))) + (list-length z)))) + nil) + +(deftest list-length.order.1 + (let ((i 0)) + (values (list-length (progn (incf i) '(a b c))) i)) + 3 1) + + +(deftest list-length.4 + (list-length (copy-tree '(a b c))) + 3) + +;; Check that list-length produces a type-error +;; on arguments that are not proper lists or circular lists + +(deftest list-length.error.1 + (loop + for x in (list 'a 1 1.0 #\w (make-array '(10)) + '(a b . c) (symbol-package 'cons)) + count (not (eqt (catch-type-error (list-length x)) + 'type-error))) + 0) + +(deftest list-length.error.2 + (classify-error (list-length)) + program-error) + +(deftest list-length.error.3 + (classify-error (list-length nil nil)) + program-error) + +(deftest list-length.error.4 + (classify-error (list-length 'a)) + type-error) + +(deftest list-length.error.5 + (classify-error (locally (list-length 'a) t)) + type-error) + +(deftest list-length-symbol + (classify-error (list-length 'a)) + type-error) + +(deftest list-length-dotted-list + (classify-error (list-length (copy-tree '(a b c d . e)))) + type-error) diff --git a/ansi-tests/list.lsp b/ansi-tests/list.lsp new file mode 100644 index 0000000000000000000000000000000000000000..64d8ac489aabac4203f6e5deebf0813316aabb11 --- /dev/null +++ b/ansi-tests/list.lsp @@ -0,0 +1,62 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:56:04 2003 +;;;; Contains: Tests of LIST, LIST* + +(in-package :cl-test) + +(deftest list.1 + (list 'a 'b 'c) + (a b c)) + +(deftest list.2 + (list) + nil) + +(deftest list.order.1 + (let ((i 0)) + (list (incf i) (incf i) (incf i) (incf i))) + (1 2 3 4)) + +(deftest list.order.2 + (let ((i 0)) + (list (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i))) + (1 2 3 4 5 6 7 8)) + +(deftest list.order.3 + (let ((i 0)) + (list (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i))) + (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)) + +(deftest list*.1 + (list* 1 2 3) + (1 2 . 3)) + +(deftest list*.2 + (list* 'a) + a) + +(deftest list-list*.1 + (list* 'a 'b 'c (list 'd 'e 'f)) + (a b c d e f)) + +(deftest list*.3 + (list* 1) + 1) + +(deftest list*.order.1 + (let ((i 0)) + (list* (incf i) (incf i) (incf i) (incf i))) + (1 2 3 . 4)) + +(deftest list*.order.2 + (let ((i 0)) + (list* (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i))) + (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 . 16)) diff --git a/ansi-tests/listp.lsp b/ansi-tests/listp.lsp new file mode 100644 index 0000000000000000000000000000000000000000..0a1427f906e86ef826353af989b34e142ec09b1c --- /dev/null +++ b/ansi-tests/listp.lsp @@ -0,0 +1,47 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:03:37 2003 +;;;; Contains: Tests of LISTP + +(in-package :cl-test) + +(deftest listp-nil + (notnot-mv (listp nil)) + t) + +(deftest listp-symbol + (listp 'a) + nil) + +(deftest listp-singleton-list + (notnot-mv (listp '(a))) + t) + +(deftest listp-circular-list + (let ((x (cons nil nil))) + (setf (cdr x) x) + (notnot-mv (listp x))) + t) + +(deftest listp-longer-list + (notnot-mv (listp '(a b c d e f g h))) + t) + +;;; Check that (listp x) == (typep x 'list) + +(deftest listp-universe + (check-type-predicate 'listp 'list) + 0) + +(deftest listp.order.1 + (let ((i 0)) + (values (listp (incf i)) i)) + nil 1) + +(deftest listp.error.1 + (classify-error (listp)) + program-error) + +(deftest listp.error.2 + (classify-error (listp nil nil)) + program-error) diff --git a/ansi-tests/load-cons.lsp b/ansi-tests/load-cons.lsp index cfed47388e394f77eba83922feb0837a35707041..8a1faf741f5f3ad04bbf9427b6e2d4f58cd5cff6 100644 --- a/ansi-tests/load-cons.lsp +++ b/ansi-tests/load-cons.lsp @@ -2,28 +2,80 @@ (compile-and-load "cons-aux.lsp") +(load "cons.lsp") +(load "consp.lsp") +(load "atom.lsp") +(load "cxr.lsp") +(load "rplaca.lsp") +(load "rplacd.lsp") +(load "copy-tree.lsp") +(load "sublis.lsp") +(load "nsublis.lsp") +(load "subst.lsp") +(load "subst-if.lsp") +(load "subst-if-not.lsp") +(load "nsubst.lsp") +(load "nsubst-if.lsp") +(load "nsubst-if-not.lsp") +(load "copy-list.lsp") +(load "list.lsp") +(load "list-length.lsp") +(load "listp.lsp") +(load "make-list.lsp") +(load "push.lsp") +(load "pop.lsp") +(load "pushnew.lsp") +(load "adjoin.lsp") +(load "nth.lsp") +(load "endp.lsp") +(load "nconc.lsp") +(load "append.lsp") +(load "revappend.lsp") +(load "nreconc.lsp") +(load "butlast.lsp") +(load "nbutlast.lsp") +(load "last.lsp") +(load "ldiff.lsp") +(load "tailp.lsp") +(load "nthcdr.lsp") +(load "rest.lsp") +(load "member.lsp") +(load "member-if.lsp") +(load "member-if-not.lsp") + +(load "mapc.lsp") +(load "mapcar.lsp") +(load "mapcan.lsp") +(load "mapl.lsp") +(load "maplist.lsp") +(load "mapcon.lsp") + +(load "acons.lsp") +(load "assoc.lsp") +(load "assoc-if.lsp") +(load "assoc-if-not.lsp") +(load "rassoc.lsp") +(load "rassoc-if.lsp") +(load "rassoc-if-not.lsp") +(load "copy-alist.lsp") +(load "pairlis.lsp") + +(load "get-properties.lsp") +(load "getf.lsp") +(load "remf.lsp") + +(load "intersection.lsp") +(load "nintersection.lsp") +(load "union.lsp") +(load "nunion.lsp") +(load "set-difference.lsp") +(load "nset-difference.lsp") +(load "set-exclusive-or.lsp") +(load "nset-exclusive-or.lsp") +(load "subsetp.lsp") + +;;; Misc. stuff that should be moved elsewhere (load "cons-test-01.lsp") -(load "cons-test-02.lsp") (load "cons-test-03.lsp") -(load "cons-test-04.lsp") (load "cons-test-05.lsp") -(load "cons-test-06.lsp") -(load "cons-test-07.lsp") -(load "cons-test-08.lsp") -(load "cons-test-09.lsp") -(load "cons-test-10.lsp") -(load "cons-test-11.lsp") -(load "cons-test-12.lsp") -(load "cons-test-13.lsp") -(load "cons-test-14.lsp") -(load "cons-test-15.lsp") -(load "cons-test-16.lsp") -(load "cons-test-17.lsp") -(load "cons-test-18.lsp") -(load "cons-test-19.lsp") -(load "cons-test-20.lsp") -(load "cons-test-21.lsp") -(load "cons-test-22.lsp") -(load "cons-test-23.lsp") -(load "cons-test-24.lsp") -(load "cons-test-25.lsp") + diff --git a/ansi-tests/make-list.lsp b/ansi-tests/make-list.lsp new file mode 100644 index 0000000000000000000000000000000000000000..42267040d773da713cbfb97208a2089c2e2a15be --- /dev/null +++ b/ansi-tests/make-list.lsp @@ -0,0 +1,101 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:04:27 2003 +;;;; Contains: Tests of MAKE-LIST + +(in-package :cl-test) + +(deftest make-list-empty.1 + (make-list 0) + nil) + +(deftest make-list-empty.2 + (make-list 0 :initial-element 'a) + nil) + +(deftest make-list-no-initial-element + (make-list 6) + (nil nil nil nil nil nil)) + +(deftest make-list-with-initial-element + (make-list 6 :initial-element 'a) + (a a a a a a)) + +(deftest make-list.allow-other-keys.1 + (make-list 5 :allow-other-keys t :foo 'a) + (nil nil nil nil nil)) + +(deftest make-list.allow-other-keys.2 + (make-list 5 :bar nil :allow-other-keys t) + (nil nil nil nil nil)) + +(deftest make-list.allow-other-keys.3 + (make-list 5 :allow-other-keys nil) + (nil nil nil nil nil)) + +(deftest make-list.allow-other-keys.4 + (make-list 5 :allow-other-keys t :allow-other-keys nil 'bad t) + (nil nil nil nil nil)) + +(deftest make-list.allow-other-keys.5 + (make-list 5 :allow-other-keys t) + (nil nil nil nil nil)) + +(deftest make-list-repeated-keyword + (make-list 5 :initial-element 'a :initial-element 'b) + (a a a a a)) + +(deftest make-list.order.1 + (let ((i 0) x y) + (values + (make-list (progn (setf x (incf i)) 5) + :initial-element + (progn (setf y (incf i)) 'a)) + i x y)) + (a a a a a) + 2 1 2) + +(deftest make-list.order.2 + (let ((i 0) x y z) + (values + (make-list (progn (setf x (incf i)) 5) + :initial-element + (progn (setf y (incf i)) 'a) + :initial-element + (progn (setf z (incf i)) 'b)) + i x y z)) + (a a a a a) + 3 1 2 3) + + +(deftest make-list.error.1 + (catch-type-error (make-list -1)) + type-error) + +(deftest make-list.error.2 + (classify-error (make-list 'a)) + type-error) + +(deftest make-list.error.3 + (classify-error (make-list)) + program-error) + +(deftest make-list.error.4 + (classify-error (make-list 5 :bad t)) + program-error) + +(deftest make-list.error.5 + (classify-error (make-list 5 :initial-element)) + program-error) + +(deftest make-list.error.6 + (classify-error (make-list 5 1 2)) + program-error) + +(deftest make-list.error.7 + (classify-error (make-list 5 :bad t :allow-other-keys nil)) + program-error) + +(deftest make-list.error.8 + (classify-error (locally (make-list 'a) t)) + type-error) diff --git a/ansi-tests/mapc.lsp b/ansi-tests/mapc.lsp new file mode 100644 index 0000000000000000000000000000000000000000..88a74130c255c41169454a155d85d6cb49598230 --- /dev/null +++ b/ansi-tests/mapc.lsp @@ -0,0 +1,104 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:21:24 2003 +;;;; Contains: Tests of MAPC + +(in-package :cl-test) + +(deftest mapc.1 + (mapc #'list nil) + nil) + +(deftest mapc.2 + (let ((x 0)) + (let ((result + (mapc #'(lambda (y) (incf x y)) + '(1 2 3 4)))) + (list result x))) + ((1 2 3 4) 10)) + +(deftest mapc.3 + (let ((x 0)) + (list + (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) + (make-list 5 :initial-element 'a) + (make-list 5 )) + x)) + ((a a a a a) 5)) + +(deftest mapc.4 + (let ((x 0)) + (list + (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) + (make-list 5 :initial-element 'a) + (make-list 10)) + x)) + ((a a a a a) 5)) + +(deftest mapc.5 + (let ((x 0)) + (list + (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) + (make-list 5 :initial-element 'a) + (make-list 3)) + x)) + ((a a a a a) 3)) + +(defvar *mapc.6-var* nil) +(defun mapc.6-fun (x) + (push x *mapc.6-var*) + x) + +(deftest mapc.6 + (let* ((x (copy-list '(a b c d e f g h))) + (xcopy (make-scaffold-copy x))) + (setf *mapc.6-var* nil) + (let ((result (mapc 'mapc.6-fun x))) + (and (check-scaffold-copy x xcopy) + (eqt result x) + *mapc.6-var*))) + (h g f e d c b a)) + +(deftest mapc.order.1 + (let ((i 0) x y z) + (values + (mapc (progn (setf x (incf i)) + #'list) + (progn (setf y (incf i)) + '(a b c)) + (progn (setf z (incf i)) + '(1 2 3))) + i x y z)) + (a b c) 3 1 2 3) + +(deftest mapc.error.1 + (classify-error (mapc #'identity 1)) + type-error) + +(deftest mapc.error.2 + (classify-error (mapc)) + program-error) + +(deftest mapc.error.3 + (classify-error (mapc #'append)) + program-error) + +(deftest mapc.error.4 + (classify-error (locally (mapc #'identity 1) t)) + type-error) + +(deftest mapc.error.5 + (classify-error (mapc #'cons '(a b c))) + program-error) + +(deftest mapc.error.6 + (classify-error (mapc #'cons '(a b c) '(1 2 3) '(4 5 6))) + program-error) + +(deftest mapc.error.7 + (classify-error (mapc #'car '(a b c))) + type-error) + +(deftest mapc.error.8 + (classify-error (mapc #'identity (list* 1 2 3 4))) + type-error) diff --git a/ansi-tests/mapcan.lsp b/ansi-tests/mapcan.lsp new file mode 100644 index 0000000000000000000000000000000000000000..8ab029d5a165fcd755032087006069bf6e876245 --- /dev/null +++ b/ansi-tests/mapcan.lsp @@ -0,0 +1,118 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:22:46 2003 +;;;; Contains: Tests of MAPCAN + +(in-package :cl-test) + +(deftest mapcan.1 + (mapcan #'list nil) + nil) + +(deftest mapcan.2 + (mapcan #'list (copy-list '(a b c d e f))) + (a b c d e f)) + +(deftest mapcan.3 + (let* ((x (list 'a 'b 'c 'd)) + (xcopy (make-scaffold-copy x)) + (result (mapcan #'list x))) + (and + (= (length x) (length result)) + (check-scaffold-copy x xcopy) + (loop + for e1 on x + and e2 on result + count (or (eqt e1 e2) (not (eql (car e1) (car e2))))))) + 0) + +(deftest mapcan.4 + (mapcan #'list + (copy-list '(1 2 3 4)) + (copy-list '(a b c d))) + (1 a 2 b 3 c 4 d)) + +(deftest mapcan.5 + (mapcan #'(lambda (x y) (make-list y :initial-element x)) + (copy-list '(a b c d)) + (copy-list '(1 2 3 4))) + (a b b c c c d d d d)) + +(defvar *mapcan.6-var* nil) +(defun mapcan.6-fun (x) + (push x *mapcan.6-var*) + (copy-list *mapcan.6-var*)) + +(deftest mapcan.6 + (progn + (setf *mapcan.6-var* nil) + (mapcan 'mapcan.6-fun (copy-list '(a b c d)))) + (a b a c b a d c b a)) + +(deftest mapcan.order.1 + (let ((i 0) x y z) + (values + (mapcan (progn (setf x (incf i)) + #'list) + (progn (setf y (incf i)) + '(a b c)) + (progn (setf z (incf i)) + '(1 2 3))) + i x y z)) + (a 1 b 2 c 3) + 3 1 2 3) + +(deftest mapcan.8 + (mapcan #'(lambda (x y) (make-list y :initial-element x)) + (copy-list '(a b c d)) + (copy-list '(1 2 3 4 5 6))) + (a b b c c c d d d d)) + +(deftest mapcan.9 + (mapcan #'(lambda (x y) (make-list y :initial-element x)) + (copy-list '(a b c d e f)) + (copy-list '(1 2 3 4))) + (a b b c c c d d d d)) + +(deftest mapcan.10 + (mapcan #'list + (copy-list '(a b c d)) + (copy-list '(1 2 3 4)) + nil) + nil) + +(deftest mapcan.11 + (mapcan (constantly 1) (list 'a)) + 1) + +(deftest mapcan.error.1 + (classify-error (mapcan #'identity 1)) + type-error) + +(deftest mapcan.error.2 + (classify-error (mapcan)) + program-error) + +(deftest mapcan.error.3 + (classify-error (mapcan #'append)) + program-error) + +(deftest mapcan.error.4 + (classify-error (locally (mapcan #'identity 1) t)) + type-error) + +(deftest mapcan.error.5 + (classify-error (mapcan #'car '(a b c))) + type-error) + +(deftest mapcan.error.6 + (classify-error (mapcan #'cons '(a b c))) + program-error) + +(deftest mapcan.error.7 + (classify-error (mapcan #'cons '(a b c) '(1 2 3) '(4 5 6))) + program-error) + +(deftest mapcan.error.8 + (classify-error (mapcan #'identity (list* (list 1) (list 2) 3))) + type-error) diff --git a/ansi-tests/mapcar.lsp b/ansi-tests/mapcar.lsp new file mode 100644 index 0000000000000000000000000000000000000000..96133698156201c985b8fac55c155149371458d1 --- /dev/null +++ b/ansi-tests/mapcar.lsp @@ -0,0 +1,111 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:22:16 2003 +;;;; Contains: Tests of MAPCAR + +(in-package :cl-test) + +(deftest mapcar.1 + (mapcar #'1+ nil) + nil) + +(deftest mapcar.2 + (let* ((x (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x))) + (let ((result (mapcar #'1+ x))) + (and (check-scaffold-copy x xcopy) + result))) + (2 3 4 5)) + +(deftest mapcar.3 + (let* ((n 0) + (x (copy-list '(a b c d))) + (xcopy (make-scaffold-copy x))) + (let ((result + (mapcar #'(lambda (y) (declare (ignore y)) (incf n)) + x))) + (and (check-scaffold-copy x xcopy) + result))) + (1 2 3 4)) + +(deftest mapcar.4 + (let* ((n 0) + (x (copy-list '(a b c d))) + (xcopy (make-scaffold-copy x)) + (x2 (copy-list '(a b c d e f))) + (x2copy (make-scaffold-copy x2)) + (result + (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) + x x2))) + (and (check-scaffold-copy x xcopy) + (check-scaffold-copy x2 x2copy) + (list result n))) + ((1 2 3 4) 4)) + +(deftest mapcar.5 + (let* ((n 0) + (x (copy-list '(a b c d))) + (xcopy (make-scaffold-copy x)) + (x2 (copy-list '(a b c d e f))) + (x2copy (make-scaffold-copy x2)) + (result + (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) + x2 x))) + (and (check-scaffold-copy x xcopy) + (check-scaffold-copy x2 x2copy) + (list result n))) + ((1 2 3 4) 4)) + +(deftest mapcar.6 + (let* ((x (copy-list '(a b c d e f g h))) + (xcopy (make-scaffold-copy x))) + (setf *mapc.6-var* nil) + (let ((result (mapcar 'mapc.6-fun x))) + (and (check-scaffold-copy x xcopy) + (list *mapc.6-var* result)))) + ((h g f e d c b a) (a b c d e f g h))) + +(deftest mapcar.order.1 + (let ((i 0) x y z) + (values + (mapcar (progn (setf x (incf i)) + #'list) + (progn (setf y (incf i)) + '(a b c)) + (progn (setf z (incf i)) + '(1 2 3))) + i x y z)) + ((a 1) (b 2) (c 3)) + 3 1 2 3) + +(deftest mapcar.error.1 + (classify-error (mapcar #'identity 1)) + type-error) + +(deftest mapcar.error.2 + (classify-error (mapcar)) + program-error) + +(deftest mapcar.error.3 + (classify-error (mapcar #'append)) + program-error) + +(deftest mapcar.error.4 + (classify-error (locally (mapcar #'identity 1) t)) + type-error) + +(deftest mapcar.error.5 + (classify-error (mapcar #'car '(a b c))) + type-error) + +(deftest mapcar.error.6 + (classify-error (mapcar #'cons '(a b c))) + program-error) + +(deftest mapcar.error.7 + (classify-error (mapcar #'cons '(a b c) '(1 2 3) '(4 5 6))) + program-error) + +(deftest mapcar.error.8 + (classify-error (mapcar #'identity (list* 1 2 3 4))) + type-error) diff --git a/ansi-tests/mapcon.lsp b/ansi-tests/mapcon.lsp new file mode 100644 index 0000000000000000000000000000000000000000..b66370420afbf4c59f1c9a457ae66896dd57075f --- /dev/null +++ b/ansi-tests/mapcon.lsp @@ -0,0 +1,85 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:24:28 2003 +;;;; Contains: Tests of MAPCON + +(in-package :cl-test) + +(deftest mapcon.1 + (mapcon #'(lambda (x) (append '(a) x nil)) nil) + nil) + +(deftest mapcon.2 + (let* ((x (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (result + (mapcon #'(lambda (y) (append '(a) y nil)) x))) + (and + (check-scaffold-copy x xcopy) + result)) + (a 1 2 3 4 a 2 3 4 a 3 4 a 4)) + +(deftest mapcon.3 + (let* ((x (copy-list '(4 2 3 2 2))) + (y (copy-list '(a b c d e f g h i j k l))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapcon #'(lambda (xt yt) + (subseq yt 0 (car xt))) + x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)) + (a b c d b c c d e d e e f)) + +(deftest mapcon.4 + (mapcon (constantly 1) (list 'a)) + 1) + +(deftest mapcon.order.1 + (let ((i 0) x y z) + (values + (mapcon (progn (setf x (incf i)) + #'(lambda (x y) (list (car x) (car y)))) + (progn (setf y (incf i)) + '(a b c)) + (progn (setf z (incf i)) + '(1 2 3))) + i x y z)) + (a 1 b 2 c 3) + 3 1 2 3) + +(deftest mapcon.error.1 + (classify-error (mapcon #'identity 1)) + type-error) + +(deftest mapcon.error.2 + (classify-error (mapcon)) + program-error) + +(deftest mapcon.error.3 + (classify-error (mapcon #'append)) + program-error) + +(deftest mapcon.error.4 + (classify-error (locally (mapcon #'identity 1) t)) + type-error) + +(deftest mapcon.error.5 + (classify-error (mapcon #'caar '(a b c))) + type-error) + +(deftest mapcon.error.6 + (classify-error (mapcon #'cons '(a b c))) + program-error) + +(deftest mapcon.error.7 + (classify-error (mapcon #'cons '(a b c) '(1 2 3) '(4 5 6))) + program-error) + +(deftest mapcon.error.8 + (classify-error (mapcon #'copy-tree (cons 1 2))) + type-error) + diff --git a/ansi-tests/mapl.lsp b/ansi-tests/mapl.lsp new file mode 100644 index 0000000000000000000000000000000000000000..25718148944af1b8ea8b8c4dc6ca1bb910676374 --- /dev/null +++ b/ansi-tests/mapl.lsp @@ -0,0 +1,130 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:23:23 2003 +;;;; Contains: Tests of MAPL + +(in-package :cl-test) + +(deftest mapl.1 + (mapl #'list nil) + nil) + +(deftest mapl.2 + (let* ((a nil) + (x (copy-list '(a b c))) + (xcopy (make-scaffold-copy x)) + (result + (mapl #'(lambda (y) (push y a)) + x))) + (and + (check-scaffold-copy x xcopy) + (eqt result x) + a)) + ((c) (b c) (a b c))) + +(deftest mapl.3 + (let* ((a nil) + (x (copy-list '(a b c d))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapl #'(lambda (xtail ytail) + (setf a + (append (mapcar #'list xtail ytail) + a))) + x y))) + (and + (eqt result x) + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + a)) + ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) + (a 1) (b 2) (c 3) (d 4))) + +(deftest mapl.4 + (let* ((a nil) + (x (copy-list '(a b c d))) + (y (copy-list '(1 2 3 4 5 6 7 8))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapl #'(lambda (xtail ytail) + (setf a + (append (mapcar #'list xtail ytail) + a))) + x y))) + (and + (eqt result x) + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + a)) + ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) + (a 1) (b 2) (c 3) (d 4))) + +(deftest mapl.5 + (let* ((a nil) + (x (copy-list '(a b c d e f g))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapl #'(lambda (xtail ytail) + (setf a + (append (mapcar #'list xtail ytail) + a))) + x y))) + (and + (eqt result x) + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + a)) + ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) + (a 1) (b 2) (c 3) (d 4))) + +(deftest mapl.order.1 + (let ((i 0) x y z) + (values + (mapl (progn + (setf x (incf i)) + (constantly nil)) + (progn + (setf y (incf i)) + '(a b c)) + (progn + (setf z (incf i)) + '(1 2 3))) + i x y z)) + (a b c) 3 1 2 3) + +(deftest mapl.error.1 + (classify-error (mapl #'identity 1)) + type-error) + +(deftest mapl.error.2 + (classify-error (mapl)) + program-error) + +(deftest mapl.error.3 + (classify-error (mapl #'append)) + program-error) + +(deftest mapl.error.4 + (classify-error (locally (mapl #'identity 1) t)) + type-error) + +(deftest mapl.error.5 + (classify-error (mapl #'cons '(a b c))) + program-error) + +(deftest mapl.error.6 + (classify-error (mapl #'cons '(a b c) '(1 2 3) '(4 5 6))) + program-error) + +(deftest mapl.error.7 + (classify-error (mapl #'caar '(a b c))) + type-error) + +(deftest mapl.error.8 + (classify-error (mapl #'identity (list* (list 1) (list 2) 3))) + type-error) diff --git a/ansi-tests/maplist.lsp b/ansi-tests/maplist.lsp new file mode 100644 index 0000000000000000000000000000000000000000..4195f99bba5f2977e37377648fb0787b38cac3cf --- /dev/null +++ b/ansi-tests/maplist.lsp @@ -0,0 +1,138 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:24:00 2003 +;;;; Contains: Tests of MAPLIST + +(in-package :cl-test) + +(deftest maplist.1 + (maplist #'list nil) + nil) + +(deftest maplist.2 + (let* ((x (copy-list '(a b c))) + (xcopy (make-scaffold-copy x)) + (result (maplist #'identity x))) + (and (check-scaffold-copy x xcopy) + result)) + ((a b c) (b c) (c))) + +(deftest maplist.3 + (let* ((x (copy-list '(a b c d))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (maplist #'append x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)) + ((a b c d 1 2 3 4) + (b c d 2 3 4) + (c d 3 4) + (d 4))) + +(deftest maplist.4 + (let* ((x (copy-list '(a b c d))) + (y (copy-list '(1 2 3 4 5))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (maplist #'append x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)) + ((a b c d 1 2 3 4 5) + (b c d 2 3 4 5) + (c d 3 4 5) + (d 4 5))) + +(deftest maplist.5 + (let* ((x (copy-list '(a b c d e))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (maplist #'append x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)) + ((a b c d e 1 2 3 4) + (b c d e 2 3 4) + (c d e 3 4) + (d e 4))) + +(deftest maplist.6 + (maplist 'append '(a b c) '(1 2 3)) + ((a b c 1 2 3) (b c 2 3) (c 3))) + +(deftest maplist.7 + (maplist #'(lambda (x y) (nth (car x) y)) + '(0 1 0 1 0 1 0) + '(a b c d e f g) + ) + (a c c e e g g)) + +(deftest maplist.order.1 + (let ((i 0) x y z) + (values + (maplist + (progn + (setf x (incf i)) + #'(lambda (x y) (declare (ignore x)) (car y))) + (progn + (setf y (incf i)) + '(a b c)) + (progn + (setf z (incf i)) + '(1 2 3))) + i x y z)) + (1 2 3) 3 1 2 3) + +(deftest maplist.error.1 + (classify-error (maplist #'identity 'a)) + type-error) + +(deftest maplist.error.2 + (classify-error (maplist #'identity 1)) + type-error) + +(deftest maplist.error.3 + (classify-error (maplist #'identity 1.1323)) + type-error) + +(deftest maplist.error.4 + (classify-error (maplist #'identity "abcde")) + type-error) + +(deftest maplist.error.5 + (classify-error (maplist)) + program-error) + +(deftest maplist.error.6 + (classify-error (maplist #'append)) + program-error) + +(deftest maplist.error.7 + (classify-error (locally (maplist #'identity 'a) t)) + type-error) + +(deftest maplist.error.8 + (classify-error (maplist #'caar '(a b c))) + type-error) + +(deftest maplist.error.9 + (classify-error (maplist #'cons '(a b c))) + program-error) + +(deftest maplist.error.10 + (classify-error (maplist #'cons '(a b c) '(1 2 3) '(4 5 6))) + program-error) + +(deftest maplist.error.11 + (classify-error (maplist #'identity (list* (list 1) (list 2) 3))) + type-error) + diff --git a/ansi-tests/member-if-not.lsp b/ansi-tests/member-if-not.lsp new file mode 100644 index 0000000000000000000000000000000000000000..a727f76d02b3ad3bfde9c87015766d6d393011b3 --- /dev/null +++ b/ansi-tests/member-if-not.lsp @@ -0,0 +1,133 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Mar 28 07:39:29 1998 +;;;; Contains: Tests of MEMBER-IF-NOT + +(in-package :cl-test) + +(deftest member-if-not.1 + (member-if-not #'listp nil) + nil) + +(deftest member-if-not.2 + (member-if-not #'(lambda (x) (eqt x 'a)) '(a 1 2 a 3 4)) + (1 2 a 3 4)) + +(deftest member-if-not.3 + (member-if-not #'(lambda (x) (not (eql x 12))) '(4 12 11 73 11) :key #'1+) + (11 73 11)) + +(deftest member-if-not.4 + (let ((test-inputs + `(1 a 11.3121 11.31s3 1.123f5 -1 0 + 13.13122d34 581.131e-10 + ((a) (b) (c) . d) + ,(make-array '(10)) + "ancadas" #\w))) + (not (every + #'(lambda (x) + (let ((result (catch-type-error (member-if-not #'listp x)))) + (or (eqt result 'type-error) + (progn + (format t "~%On x = ~S, returns: ~%~S" x result) + nil)))) + test-inputs))) + nil) + +(deftest member-if-not.5 + (member-if-not #'not '(1 2 3 4 5) :key #'evenp) + (2 3 4 5)) + +;;; Order of evaluation tests + +(deftest member-if-not.order.1 + (let ((i 0) x y) + (values + (member-if-not (progn (setf x (incf i)) + #'not) + (progn (setf y (incf i)) + '(nil nil a b nil c d))) + i x y)) + (a b nil c d) 2 1 2) + +(deftest member-if-not.order.2 + (let ((i 0) x y z w) + (values + (member-if-not (progn (setf x (incf i)) + #'not) + (progn (setf y (incf i)) + '(nil nil a b nil c d)) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf w (incf i)) #'not)) + + i x y z w)) + (a b nil c d) 4 1 2 3 4) + +;;; Keyword tests + +(deftest member-if-not.keywords.1 + (member-if-not #'not '(1 2 3 4 5) :key #'evenp :key #'oddp) + (2 3 4 5)) + +(deftest member-if-not.allow-other-keys.2 + (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t :bad t) + (2 3 4 5)) + +(deftest member-if-not.allow-other-keys.3 + (member-if-not #'not '(nil 2 3 4 5) :bad t :allow-other-keys t) + (2 3 4 5)) + +(deftest member-if-not.allow-other-keys.4 + (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t) + (2 3 4 5)) + +(deftest member-if-not.allow-other-keys.5 + (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys nil) + (2 3 4 5)) + +(deftest member-if-not.allow-other-keys.6 + (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t + :allow-other-keys nil :key #'identity :key #'null) + (2 3 4 5)) + +;;; Error tests + +(deftest member-if-not.error.1 + (classify-error (member-if-not #'identity 'a)) + type-error) + +(deftest member-if-not.error.2 + (classify-error (member-if-not)) + program-error) + +(deftest member-if-not.error.3 + (classify-error (member-if-not #'null)) + program-error) + +(deftest member-if-not.error.4 + (classify-error (member-if-not #'null '(a b c) :bad t)) + program-error) + +(deftest member-if-not.error.5 + (classify-error (member-if-not #'null '(a b c) :bad t :allow-other-keys nil)) + program-error) + +(deftest member-if-not.error.6 + (classify-error (member-if-not #'null '(a b c) :key)) + program-error) + +(deftest member-if-not.error.7 + (classify-error (member-if-not #'null '(a b c) 1 2)) + program-error) + +(deftest member-if-not.error.8 + (classify-error (locally (member-if-not #'identity 'a) t)) + type-error) + +(deftest member-if-not.error.9 + (classify-error (member-if-not #'cons '(a b c))) + program-error) + +(deftest member-if-not.error.10 + (classify-error (member-if-not #'identity '(a b c) :key #'cons)) + program-error) diff --git a/ansi-tests/member-if.lsp b/ansi-tests/member-if.lsp new file mode 100644 index 0000000000000000000000000000000000000000..122b8e03e6c6949d0ae130f15caa0692f62ea015 --- /dev/null +++ b/ansi-tests/member-if.lsp @@ -0,0 +1,139 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:51:56 2003 +;;;; Contains: Tests of MEMBER-IF + +(in-package :cl-test) + +(deftest member-if.1 + (member-if #'listp nil) + nil) + +(deftest member-if.2 + (member-if #'(lambda (x) (eqt x 'a)) '(1 2 a 3 4)) + (a 3 4)) + +(deftest member-if.3 + (member-if #'(lambda (x) (eql x 12)) '(4 12 11 73 11) :key #'1+) + (11 73 11)) + +(deftest member-if.4 + (let ((test-inputs + `(1 a 11.3121 11.31s3 1.123f5 -1 0 + 13.13122d34 581.131e-10 + (a b c . d) + ,(make-array '(10)) + "ancadas" #\w))) + (notnot-mv + (every + #'(lambda (x) + (let ((result (catch-type-error (member-if #'listp x)))) + (or (eqt result 'type-error) + (progn + (format t "~%On ~S: returned ~%~S" x result) + nil)))) + test-inputs))) + t) + +(deftest member-if.5 + (member-if #'identity '(1 2 3 4 5) :key #'evenp) + (2 3 4 5)) + +;;; Order of argument tests + +(deftest member-if.order.1 + (let ((i 0) x y) + (values + (member-if (progn (setf x (incf i)) + #'identity) + (progn (setf y (incf i)) + '(nil nil a b nil c d))) + i x y)) + (a b nil c d) 2 1 2) + +(deftest member-if.order.2 + (let ((i 0) x y z w) + (values + (member-if (progn (setf x (incf i)) + #'identity) + (progn (setf y (incf i)) + '(nil nil a b nil c d)) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf w (incf i)) #'not)) + + i x y z w)) + (a b nil c d) 4 1 2 3 4) + +;;; Keyword tests + +(deftest member-if.keywords.1 + (member-if #'identity '(1 2 3 4 5) :key #'evenp :key #'oddp) + (2 3 4 5)) + +(deftest member-if.allow-other-keys.2 + (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t :bad t) + (2 3 4 5)) + +(deftest member-if.allow-other-keys.3 + (member-if #'identity '(nil 2 3 4 5) :bad t :allow-other-keys t) + (2 3 4 5)) + +(deftest member-if.allow-other-keys.4 + (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t) + (2 3 4 5)) + +(deftest member-if.allow-other-keys.5 + (member-if #'identity '(nil 2 3 4 5) :allow-other-keys nil) + (2 3 4 5)) + +(deftest member-if.allow-other-keys.6 + (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t + :allow-other-keys nil) + (2 3 4 5)) + +(deftest member-if.allow-other-keys.7 + (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t + :allow-other-keys nil :key #'identity :key #'null) + (2 3 4 5)) + +;;; Error cases + +(deftest member-if.error.1 + (classify-error (member-if #'identity 'a)) + type-error) + +(deftest member-if.error.2 + (classify-error (member-if)) + program-error) + +(deftest member-if.error.3 + (classify-error (member-if #'null)) + program-error) + +(deftest member-if.error.4 + (classify-error (member-if #'null '(a b c) :bad t)) + program-error) + +(deftest member-if.error.5 + (classify-error (member-if #'null '(a b c) :bad t :allow-other-keys nil)) + program-error) + +(deftest member-if.error.6 + (classify-error (member-if #'null '(a b c) :key)) + program-error) + +(deftest member-if.error.7 + (classify-error (member-if #'null '(a b c) 1 2)) + program-error) + +(deftest member-if.error.8 + (classify-error (locally (member-if #'identity 'a) t)) + type-error) + +(deftest member-if.error.9 + (classify-error (member-if #'cons '(a b c))) + program-error) + +(deftest member-if.error.10 + (classify-error (member-if #'identity '(a b c) :key #'cons)) + program-error) diff --git a/ansi-tests/cons-test-13.lsp b/ansi-tests/member.lsp similarity index 97% rename from ansi-tests/cons-test-13.lsp rename to ansi-tests/member.lsp index bdef6cc70baf6eea533aba7fe9719ca0e1d353ff..c7b0fe5524108100a72d8895d1c9b7ad638d7b08 100644 --- a/ansi-tests/cons-test-13.lsp +++ b/ansi-tests/member.lsp @@ -1,15 +1,10 @@ ;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Mar 28 07:38:57 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 13 +;;;; Contains: Tests of MEMBER (in-package :cl-test) -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; member - (deftest member.1 (let* ((x (copy-tree '(a b c d e f))) (xcopy (make-scaffold-copy x)) diff --git a/ansi-tests/cons-test-09.lsp b/ansi-tests/nbutlast.lsp similarity index 52% rename from ansi-tests/cons-test-09.lsp rename to ansi-tests/nbutlast.lsp index baba3477a02c0a70663317ff79237d3009640f7b..a3cdf93027e8ad75d6d3b2f22628b8e787f39ca0 100644 --- a/ansi-tests/cons-test-09.lsp +++ b/ansi-tests/nbutlast.lsp @@ -1,95 +1,10 @@ ;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:36:30 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 9 +;;;; Created: Sat Apr 19 22:41:54 2003 +;;;; Contains: Tests of NBUTLAST (in-package :cl-test) -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; butlast, nbutlast - -(deftest butlast.1 - (let ((x (list 'a 'b 'c 'd 'e))) - (let ((xcopy (make-scaffold-copy x))) - (let ((result (butlast x 2))) - (and - (check-scaffold-copy x xcopy) - result)))) - (a b c)) - -(deftest butlast.2 - (let ((x (list 'a 'b 'c 'd 'e))) - (let ((xcopy (make-scaffold-copy x))) - (let ((result (butlast x 0))) - (and - (check-scaffold-copy x xcopy) - result)))) - (a b c d e)) - -(deftest butlast.3 - (let ((x (list 'a 'b 'c 'd 'e))) - (let ((xcopy (make-scaffold-copy x))) - (let ((result (butlast x 5))) - (and - (check-scaffold-copy x xcopy) - result)))) - nil) - -(deftest butlast.4 - (let ((x (list 'a 'b 'c 'd 'e))) - (let ((xcopy (make-scaffold-copy x))) - (let ((result (butlast x 6))) - (and - (check-scaffold-copy x xcopy) - result)))) - nil) - -(deftest butlast.5 - (butlast (copy-tree '(a b c . d)) 1) - (a b)) - -(deftest butlast.order.1 - (let ((i 0) x y) - (values - (butlast (progn (setf x (incf i)) - (list 'a 'b 'c 'd 'e)) - (progn (setf y (incf i)) - 2)) - i x y)) - (a b c) 2 1 2) - -(deftest butlast.order.2 - (let ((i 0)) - (values - (butlast (progn (incf i) '(a b c d))) - i)) - (a b c) 1) - -(deftest butlast.error.1 - (classify-error (butlast (copy-tree '(a b c d)) 'a)) - type-error) - -(deftest butlast.error.2 - (classify-error (butlast 'a 0)) - type-error) - -(deftest butlast.error.3 - (classify-error (butlast)) - program-error) - -(deftest butlast.error.4 - (classify-error (butlast '(a b c) 3 3)) - program-error) - -(deftest butlast.error.5 - (classify-error (locally (butlast 'a 0) t)) - type-error) - - -;;; Tests of NBUTLAST - (deftest nbutlast.1 (let ((x (list 'a 'b 'c 'd 'e))) (let ((y (cdr x)) diff --git a/ansi-tests/nconc.lsp b/ansi-tests/nconc.lsp new file mode 100644 index 0000000000000000000000000000000000000000..894280574550054da87082736ed4e16ca2b48e80 --- /dev/null +++ b/ansi-tests/nconc.lsp @@ -0,0 +1,72 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:35:53 2003 +;;;; Contains: Tests of NCONC + +(in-package :cl-test) + +(deftest nconc.1 + (nconc) + nil) + +(deftest nconc.2 + (nconc (copy-tree '(a b c d e f))) + (a b c d e f)) + +;;; (deftest nconc.3 +;;; (nconc 1) +;;; 1) + +(deftest nconc.4 + (let ((x (list 'a 'b 'c)) + (y (list 'd 'e 'f))) + (let ((ycopy (make-scaffold-copy y))) + (let ((result (nconc x y))) + (and + (check-scaffold-copy y ycopy) + (eqt (cdddr x) y) + result)))) + (a b c d e f)) + +(deftest nconc.5 + (let ((x (list 'a 'b 'c))) + (nconc x x) + (and + (eqt (cdddr x) x) + (null (list-length x)))) + t) + +(deftest nconc.6 + (let ((x (list 'a 'b 'c)) + (y (list 'd 'e 'f 'g 'h)) + (z (list 'i 'j 'k))) + (let ((result (nconc x y z 'foo))) + (and + (eqt (nthcdr 3 x) y) + (eqt (nthcdr 5 y) z) + (eqt (nthcdr 3 z) 'foo) + result))) + (a b c d e f g h i j k . foo)) + +(deftest nconc.7 + (nconc (copy-tree '(a . b)) + (copy-tree '(c . d)) + (copy-tree '(e . f)) + 'foo) + (a c e . foo)) + +(deftest nconc.order.1 + (let ((i 0) x y z) + (values + (nconc (progn (setf x (incf i)) (copy-list '(a b c))) + (progn (setf y (incf i)) (copy-list '(d e f))) + (progn (setf z (incf i)) (copy-list '(g h i)))) + i x y z)) + (a b c d e f g h i) 3 1 2 3) + +(deftest nconc.order.2 + (let ((i 0)) + (values + (nconc (list 'a) (incf i)) + i)) + (a . 1) 1) diff --git a/ansi-tests/nintersection.lsp b/ansi-tests/nintersection.lsp new file mode 100644 index 0000000000000000000000000000000000000000..d1f7425cfb582d5fad74aa0d16e0e2923055539b --- /dev/null +++ b/ansi-tests/nintersection.lsp @@ -0,0 +1,361 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:40:02 2003 +;;;; Contains: Tests of NINTERSECTION + +(in-package :cl-test) + +(deftest nintersection.1 + (nintersection nil nil) + nil) + +(deftest nintersection.2 + (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)) + 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))))))) + 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)))) + t) + +(deftest nintersection.6 + (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)) + (10)) + +(deftest nintersection.8 + (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) + ("aaa")) + +(deftest nintersection.9-a + (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)))) + ("aaa")) + +(deftest nintersection.10 + (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 + (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) + 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)))) + (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 + (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)) + 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))))) + (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))))) + (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)))))) + (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)))))) + (4)) + +;;; Order of argument evaluation tests + +(deftest nintersection.order.1 + (let ((i 0) x y) + (values + (nintersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd))) + i x y)) + nil 2 1 2) + +(deftest nintersection.order.2 + (let ((i 0) x y) + (values + (nintersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd)) + :test #'eq) + i x y)) + nil 2 1 2) + +(deftest nintersection.order.3 + (let ((i 0) x y z w) + (values + (nintersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd)) + :test (progn (setf z (incf i)) #'eq) + :test (progn (setf w (incf i)) + (complement #'eq))) + i x y z w)) + nil 4 1 2 3 4) + +(deftest nintersection.order.4 + (let ((i 0) x y z w) + (values + (nintersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd)) + :test (progn (setf z (incf i)) #'eq) + :key (progn (setf w (incf i)) #'identity)) + i x y z w)) + nil 4 1 2 3 4) + +(deftest nintersection.order.5 + (let ((i 0) x y z w) + (values + (nintersection (progn (setf x (incf i)) (list 'a 'b)) + (progn (setf y (incf i)) (list 'c 'd)) + :key (progn (setf z (incf i)) #'identity) + :test (progn (setf w (incf i)) #'eq)) + i x y z w)) + nil 4 1 2 3 4) + +;;; Keyword tests + +(deftest nintersection.allow-other-keys.1 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :bad t :allow-other-keys 1)) + (4)) + +(deftest nintersection.allow-other-keys.2 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :allow-other-keys :foo :also-bad t)) + (4)) + +(deftest nintersection.allow-other-keys.3 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :allow-other-keys :foo :also-bad t + :test #'(lambda (x y) (= x (1+ y))))) + nil) + +(deftest nintersection.allow-other-keys.4 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :allow-other-keys t)) + (4)) + +(deftest nintersection.allow-other-keys.5 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :allow-other-keys nil)) + (4)) + +(deftest nintersection.allow-other-keys.6 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :allow-other-keys t + :allow-other-keys nil :bad t)) + (4)) + +(deftest nintersection.allow-other-keys.7 + (sort + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :allow-other-keys t + :allow-other-keys nil + :test #'(lambda (x y) (eql x (1- y))))) + #'<) + (3 4)) + +(deftest nintersection.keywords.8 + (sort + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 + :test #'(lambda (x y) (eql x (1- y))) + :test #'eql)) + #'<) + (3 4)) + +(deftest nintersection.allow-other-keys.9 + (let ((list1 (list 1 2 3 4)) + (list2 (list 4 5 6 7))) + (nintersection list1 list2 :allow-other-keys :foo :also-bad t + :test #'(lambda (x y) (= x (1+ y))))) + nil) + +(deftest nintersection.error.1 + (classify-error (nintersection)) + program-error) + +(deftest nintersection.error.2 + (classify-error (nintersection nil)) + program-error) + +(deftest nintersection.error.3 + (classify-error (nintersection nil nil :bad t)) + program-error) + +(deftest nintersection.error.4 + (classify-error (nintersection nil nil :key)) + program-error) + +(deftest nintersection.error.5 + (classify-error (nintersection nil nil 1 2)) + program-error) + +(deftest nintersection.error.6 + (classify-error (nintersection nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest nintersection.error.7 + (classify-error (nintersection (list 1 2 3) (list 4 5 6) :test #'identity)) + program-error) + +(deftest nintersection.error.8 + (classify-error (nintersection (list 1 2 3) (list 4 5 6) :test-not #'identity)) + program-error) + +(deftest nintersection.error.9 + (classify-error (nintersection (list 1 2 3) (list 4 5 6) :key #'cons)) + program-error) + +(deftest nintersection.error.10 + (classify-error (nintersection (list 1 2 3) (list 4 5 6) :key #'car)) + type-error) + +(deftest nintersection.error.11 + (classify-error (nintersection (list 1 2 3) (list* 4 5 6 7))) + type-error) + +(deftest nintersection.error.12 + (classify-error (nintersection (list* 1 2 3) (list 4 5 6))) + type-error) + diff --git a/ansi-tests/nreconc.lsp b/ansi-tests/nreconc.lsp new file mode 100644 index 0000000000000000000000000000000000000000..9afa6dac799919a787d6e5e1c50dfc6f333fd388 --- /dev/null +++ b/ansi-tests/nreconc.lsp @@ -0,0 +1,42 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:38:12 2003 +;;;; Contains: Tests of NRECONC + +(in-package :cl-test) + +(deftest nreconc.1 + (let* ((x (list 'a 'b 'c)) + (y (copy-tree '(d e f))) + (result (nreconc x y))) + (and (equal y '(d e f)) + result)) + (c b a d e f)) + +(deftest nreconc.2 + (nreconc nil 'a) + a) + +(deftest nreconc.order.1 + (let ((i 0) x y) + (values + (nreconc (progn (setf x (incf i)) (copy-list '(a b c))) + (progn (setf y (incf i)) (copy-list '(d e f)))) + i x y)) + (c b a d e f) 2 1 2) + +(deftest nreconc.error.1 + (classify-error (nreconc)) + program-error) + +(deftest nreconc.error.2 + (classify-error (nreconc nil)) + program-error) + +(deftest nreconc.error.3 + (classify-error (nreconc nil nil nil)) + program-error) + +(deftest nreconc.error.4 + (classify-error (nreconc (cons 'a 'b) (list 'z))) + type-error) diff --git a/ansi-tests/nset-difference.lsp b/ansi-tests/nset-difference.lsp new file mode 100644 index 0000000000000000000000000000000000000000..2250bf5618ec553dec2341361782d062c233e267 --- /dev/null +++ b/ansi-tests/nset-difference.lsp @@ -0,0 +1,313 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:44:44 2003 +;;;; Contains: Tests of NSET-DIFFERENCE + +(in-package :cl-test) + +(deftest nset-difference.1 + (nset-difference nil nil) + nil) + +(deftest nset-difference.2 + (let ((result + (nset-difference-with-check '(a b c) nil))) + (check-nset-difference '(a b c) nil result)) + t) + +(deftest nset-difference.3 + (let ((result + (nset-difference-with-check '(a b c d e f) '(f b d)))) + (check-nset-difference '(a b c d e f) '(f b d) result)) + t) + +(deftest nset-difference.4 + (sort + (copy-list + (nset-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) + '(10 101 4 74 2 1391 7 17831))) + #'<) + (1 3 5 6 8)) + +(deftest nset-difference.5 + (nset-difference-with-check nil '(a b c d e f g h)) + nil) + +(deftest nset-difference.6 + (nset-difference-with-check '(a b c d e) '(d a b e) + :key nil) + (c)) + +(deftest nset-difference.7 + (nset-difference-with-check '(a b c d e) '(d a b e) :test #'eq) + (c)) + +(deftest nset-difference.8 + (nset-difference-with-check '(a b c d e) '(d a b e) :test #'eql) + (c)) + +(deftest nset-difference.9 + (nset-difference-with-check '(a b c d e) '(d a b e) :test #'equal) + (c)) + +(deftest nset-difference.10 + (nset-difference-with-check '(a b c d e) '(d a b e) + :test 'eq) + (c)) + +(deftest nset-difference.11 + (nset-difference-with-check '(a b c d e) '(d a b e) + :test 'eql) + (c)) + +(deftest nset-difference.12 + (nset-difference-with-check '(a b c d e) '(d a b e) + :test 'equal) + (c)) + +(deftest nset-difference.13 + (do-random-nset-differences 100 100) + nil) + +(deftest nset-difference.14 + (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) + '((a . 1) (c . 3)) + :key 'car) + ((b . 2))) + +(deftest nset-difference.15 + (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) + '((a . 1) (c . 3)) + :key #'car) + ((b . 2))) + +;; +;; Verify that the :test argument is called with the arguments +;; in the correct order +;; +(deftest nset-difference.16 + (block fail + (sort + (copy-list + (nset-difference-with-check + '(1 2 3 4) '(e f g h) + :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.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)))) + #'<)) + (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))))) + #'<)) + (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))))) + #'<)) + (1 2 3 4)) + +;;; Order of argument evaluation tests + +(deftest nset-difference.order.1 + (let ((i 0) x y) + (values + (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) + (progn (setf y (incf i)) (list 2 3 4))) + i x y)) + (1) 2 1 2) + +(deftest nset-difference.order.2 + (let ((i 0) x y z) + (values + (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) + (progn (setf y (incf i)) (list 2 3 4)) + :test (progn (setf z (incf i)) + #'(lambda (x y) (= x (1- y))))) + i x y z)) + (4) 3 1 2 3) + +(deftest nset-difference.order.3 + (let ((i 0) x y z w) + (values + (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) + (progn (setf y (incf i)) (list 2 3 4)) + :test (progn (setf z (incf i)) + #'(lambda (x y) (= x (1- y)))) + :key (progn (setf w (incf i)) nil)) + i x y z w)) + (4) 4 1 2 3 4) + + +;;; Keyword tests + +(deftest nset-difference.allow-other-keys.1 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :bad t :allow-other-keys t)) + #'<) + (1 5)) + +(deftest nset-difference.allow-other-keys.2 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t :bad t)) + #'<) + (1 5)) + +(deftest nset-difference.allow-other-keys.3 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y))))) + #'<) + (4 5)) + +(deftest nset-difference.allow-other-keys.4 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t)) + #'<) + (1 5)) + +(deftest nset-difference.allow-other-keys.5 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys nil)) + #'<) + (1 5)) + +(deftest nset-difference.allow-other-keys.6 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t + :allow-other-keys nil)) + #'<) + (1 5)) + +(deftest nset-difference.allow-other-keys.7 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t + :allow-other-keys nil + '#:x 1)) + #'<) + (1 5)) + +(deftest nset-difference.keywords.8 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :test #'eql :test (complement #'eql))) + #'<) + (1 5)) + +(deftest nset-difference.keywords.9 + (sort + (copy-list + (nset-difference + (list 1 2 3 4 5) (list 2 3 4) + :test (complement #'eql) :test #'eql)) + #'<) + nil) + +;;; Error tests + +(deftest nset-difference.error.1 + (classify-error (nset-difference)) + program-error) + +(deftest nset-difference.error.2 + (classify-error (nset-difference nil)) + program-error) + +(deftest nset-difference.error.3 + (classify-error (nset-difference nil nil :bad t)) + program-error) + +(deftest nset-difference.error.4 + (classify-error (nset-difference nil nil :key)) + program-error) + +(deftest nset-difference.error.5 + (classify-error (nset-difference nil nil 1 2)) + program-error) + +(deftest nset-difference.error.6 + (classify-error (nset-difference nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest nset-difference.error.7 + (classify-error (nset-difference (list 1 2) (list 3 4) :test #'identity)) + program-error) + +(deftest nset-difference.error.8 + (classify-error (nset-difference (list 1 2) (list 3 4) :test-not #'identity)) + program-error) + +(deftest nset-difference.error.9 + (classify-error (nset-difference (list 1 2) (list 3 4) :key #'cons)) + program-error) + +(deftest nset-difference.error.10 + (classify-error (nset-difference (list 1 2) (list 3 4) :key #'car)) + type-error) + +(deftest nset-difference.error.11 + (classify-error (nset-difference (list 1 2 3) (list* 4 5 6))) + type-error) + +(deftest nset-difference.error.12 + (classify-error (nset-difference (list* 1 2 3) (list 4 5 6))) + type-error) + diff --git a/ansi-tests/nset-exclusive-or.lsp b/ansi-tests/nset-exclusive-or.lsp new file mode 100644 index 0000000000000000000000000000000000000000..465a123458fb3d11864c859f6d5f328379de2a15 --- /dev/null +++ b/ansi-tests/nset-exclusive-or.lsp @@ -0,0 +1,359 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:47:05 2003 +;;;; Contains: Tests of NSET-EXCLUSIVE-OR + +(in-package :cl-test) + +(deftest nset-exclusive-or.1 + (nset-exclusive-or nil nil) + nil) + +(deftest nset-exclusive-or.2 + (let ((result + (nset-exclusive-or-with-check '(a b c) nil))) + (check-set-exclusive-or '(a b c) nil result)) + t) + +(deftest nset-exclusive-or.3 + (let ((result + (nset-exclusive-or-with-check '(a b c d e f) '(f b d)))) + (check-set-exclusive-or '(a b c d e f) '(f b d) result)) + t) + +(deftest nset-exclusive-or.4 + (sort + (copy-list + (nset-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) + '(10 101 4 74 2 1391 7 17831))) + #'<) + (1 3 5 6 8 10 74 101 1391 17831)) + +(deftest nset-exclusive-or.5 + (check-set-exclusive-or + nil + '(a b c d e f g h) + (nset-exclusive-or-with-check nil '(a b c d e f g h))) + t) + +(deftest nset-exclusive-or.6 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :key nil) + (c)) + +(deftest nset-exclusive-or.7 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eq) + (c)) + +(deftest nset-exclusive-or.7-a + (nset-exclusive-or-with-check '(d a b e) '(a b c d e) :test #'eq) + (c)) + +(deftest nset-exclusive-or.8 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eql) + (c)) + +(deftest nset-exclusive-or.8-a + (nset-exclusive-or-with-check '(e d b a) '(a b c d e) :test #'eql) + (c)) + +(deftest nset-exclusive-or.8-b + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :test-not (complement #'eql)) + (c)) + +(deftest nset-exclusive-or.9 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'equal) + (c)) + +(deftest nset-exclusive-or.10 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'eq) + (c)) + +(deftest nset-exclusive-or.11 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'eql) + (c)) + +(deftest nset-exclusive-or.12 + (nset-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'equal) + (c)) + +;;; (deftest nset-exclusive-or.13 +;;; (do-random-nset-exclusive-ors 100 100) +;;; nil) + +(deftest nset-exclusive-or.14 + (nset-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) + '((a . 10) (c . 3)) + :key 'car) + ((b . 2))) + +(deftest nset-exclusive-or.15 + (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) + '((a . 1) (c . 3313)) + :key #'car) + ((b . 2))) + +(deftest nset-exclusive-or.16 + (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) + '((a . 1) (c . 3313)) + :key #'car + :test-not (complement #'eql)) + ((b . 2))) + +;; +;; Check that nset-exclusive-or does not invert +;; the order of the arguments to the test function +;; +(deftest nset-exclusive-or.17 + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (nset-exclusive-or-with-check + list1 list2 + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed))))))) + t) + +(deftest nset-exclusive-or.17-a + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (nset-exclusive-or-with-check + list1 list2 + :key #'identity + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed))))))) + t) + +(deftest nset-exclusive-or.18 + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (nset-exclusive-or-with-check + list1 list2 + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t))))) + t) + +(deftest nset-exclusive-or.18-a + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (nset-exclusive-or-with-check + list1 list2 + :key #'identity + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t))))) + t) + +;;; Order of argument evaluation tests + +(deftest nset-exclusive-or.order.1 + (let ((i 0) x y) + (values + (sort + (nset-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10))) + #'<) + i x y)) + (2 4 6 10) 2 1 2) + +(deftest nset-exclusive-or.order.2 + (let ((i 0) x y z) + (values + (sort + (nset-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :test (progn (setf z (incf i)) + #'eql)) + #'<) + i x y z)) + (2 4 6 10) 3 1 2 3) + +(deftest nset-exclusive-or.order.3 + (let ((i 0) x y z w) + (values + (sort + (nset-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :test (progn (setf z (incf i)) + #'eql) + :key (progn (setf w (incf i)) nil)) + #'<) + i x y z w)) + (2 4 6 10) 4 1 2 3 4) + +(deftest nset-exclusive-or.order.4 + (let ((i 0) x y z w) + (values + (sort + (nset-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :key (progn (setf z (incf i)) nil) + :test (progn (setf w (incf i)) + #'eql)) + #'<) + i x y z w)) + (2 4 6 10) 4 1 2 3 4) + +(deftest nset-exclusive-or.order.5 + (let ((i 0) x y z w) + (values + (sort + (nset-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :key (progn (setf z (incf i)) nil) + :key (progn (setf w (incf i)) + (complement #'eql))) + #'<) + i x y z w)) + (2 4 6 10) 4 1 2 3 4) + + +;;; Keyword tests + +(deftest nset-exclusive.allow-other-keys.1 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :bad t :allow-other-keys t) + #'<) + (1 2 5 6)) + +(deftest nset-exclusive.allow-other-keys.2 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t :bad t) + #'<) + (1 2 5 6)) + +(deftest nset-exclusive.allow-other-keys.3 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t :bad t + :test #'(lambda (x y) (= x (1- y)))) + #'<) + (1 6)) + +(deftest nset-exclusive.allow-other-keys.4 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t) + #'<) + (1 2 5 6)) + +(deftest nset-exclusive.allow-other-keys.5 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys nil) + #'<) + (1 2 5 6)) + +(deftest nset-exclusive.allow-other-keys.6 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t + :allow-other-keys nil) + #'<) + (1 2 5 6)) + +(deftest nset-exclusive.allow-other-keys.7 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t + :allow-other-keys nil + '#:x 1) + #'<) + (1 2 5 6)) + +(deftest nset-exclusive.keywords.8 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :test #'eql + :test #'/=) + #'<) + (1 2 5 6)) + +(deftest nset-exclusive.keywords.9 + (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :test #'/= + :test #'eql) + #'<) + nil) + +;;; Randomized test + +(deftest random-nset-exclusive-or + (random-set-exclusive-or-test 10 1000 'nset-exclusive-or) + nil) + +;;; Error tests + +(deftest nset-exclusive-or.error.1 + (classify-error (nset-exclusive-or)) + program-error) + +(deftest nset-exclusive-or.error.2 + (classify-error (nset-exclusive-or nil)) + program-error) + +(deftest nset-exclusive-or.error.3 + (classify-error (nset-exclusive-or nil nil :bad t)) + program-error) + +(deftest nset-exclusive-or.error.4 + (classify-error (nset-exclusive-or nil nil :key)) + program-error) + +(deftest nset-exclusive-or.error.5 + (classify-error (nset-exclusive-or nil nil 1 2)) + program-error) + +(deftest nset-exclusive-or.error.6 + (classify-error (nset-exclusive-or nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest nset-exclusive-or.error.7 + (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :test #'identity)) + program-error) + +(deftest nset-exclusive-or.error.8 + (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :test-not #'identity)) + program-error) + +(deftest nset-exclusive-or.error.9 + (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'cons)) + program-error) + +(deftest nset-exclusive-or.error.10 + (classify-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'car)) + type-error) + +(deftest nset-exclusive-or.error.11 + (classify-error (nset-exclusive-or (list 1 2 3) (list* 4 5 6))) + type-error) + +(deftest nset-exclusive-or.error.12 + (classify-error (nset-exclusive-or (list* 1 2 3) (list 4 5 6))) + type-error) diff --git a/ansi-tests/nsublis.lsp b/ansi-tests/nsublis.lsp new file mode 100644 index 0000000000000000000000000000000000000000..22ccb51d7b1c7ae062d962ce8915c24692ab350c --- /dev/null +++ b/ansi-tests/nsublis.lsp @@ -0,0 +1,167 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:35:33 2003 +;;;; Contains: Tests of NSUBLIS + +(in-package :cl-test) + +(deftest nsublis.1 + (check-nsublis '((a b) g (d e 10 g h) 15 . g) + '((e . e2) (g . 17))) + ((a b) 17 (d e2 10 17 h) 15 . 17)) + +(deftest nsublis.2 + (check-nsublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) + '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) + :test #'equal) + (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b)))) + +(deftest nsublis.3 + (check-nsublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) + '((30 . "foo"))) + (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) + +(deftest nsublis.4 + (check-nsublis + (nsublis (copy-tree '((a . 2) (b . 4) (c . 1))) + (copy-tree '(a b c d e (a b c a d b) f))) + '((t . "yes")) + :key #'(lambda (x) (and (typep x 'integer) + (evenp x)))) + ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) + +(deftest nsublis.5 + (check-nsublis '("fee" (("fee" "Fie" "foo")) + fie ("fee" "fie")) + `((,(copy-seq "fie") . #\f))) + ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) + +(deftest nsublis.6 + (check-nsublis '("fee" fie (("fee" "Fie" "foo") 1) + ("fee" "fie")) + `((,(copy-seq "fie") . #\f)) + :test 'equal) + ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) + +(deftest nsublis.7 + (check-nsublis '(("aa" a b) + (z "bb" d) + ((x . "aa"))) + `((,(copy-seq "aa") . 1) + (,(copy-seq "bb") . 2)) + :test 'equal + :key #'(lambda (x) (if (consp x) (car x) + '*not-present*))) + (1 (z . 2) ((x . "aa")))) + +(deftest nsublis.8 + (nsublis nil 'a :bad-keyword t :allow-other-keys t) + a) + +;; Check that a null key arg is ignored. + +(deftest nsublis.9 + (check-nsublis + '(1 2 a b) + '((1 . 2) (a . b)) + :key nil) + (2 2 b b)) + +;;; Order of argument evaluation +(deftest nsublis.order.1 + (let ((i 0) w x y z) + (values + (nsublis + (progn (setf w (incf i)) + '((a . z))) + (progn (setf x (incf i)) + (copy-tree '(a b c d))) + :test (progn (setf y (incf i)) #'eql) + :key (progn (setf z (incf i)) #'identity)) + i w x y z)) + (z b c d) + 4 1 2 3 4) + +(deftest nsublis.order.2 + (let ((i 0) w x y z) + (values + (nsublis + (progn (setf w (incf i)) + '((a . z))) + (progn (setf x (incf i)) + (copy-tree '(a b c d))) + :key (progn (setf y (incf i)) #'identity) + :test-not (progn (setf z (incf i)) (complement #'eql)) + ) + i w x y z)) + (z b c d) + 4 1 2 3 4) + +;;; Keyword tests + +(deftest nsublis.allow-other-keys.1 + (nsublis nil 'a :bad t :allow-other-keys t) + a) + +(deftest nsublis.allow-other-keys.2 + (nsublis nil 'a :allow-other-keys t :bad t) + a) + +(deftest nsublis.allow-other-keys.3 + (nsublis nil 'a :allow-other-keys t) + a) + +(deftest nsublis.allow-other-keys.4 + (nsublis nil 'a :allow-other-keys nil) + a) + +(deftest nsublis.allow-other-keys.5 + (nsublis nil 'a :allow-other-keys t :allow-other-keys t :bad t) + a) + +(deftest nsublis.keywords.6 + (nsublis '((1 . a)) (list 0 1 2) + :key #'(lambda (x) (if (numberp x) (1+ x) x)) + :key #'identity) + (a 1 2)) + +;; Argument error cases + +(deftest nsublis.error.1 + (classify-error (nsublis)) + program-error) + +(deftest nsublis.error.2 + (classify-error (nsublis nil)) + program-error) + +(deftest nsublis.error.3 + (classify-error (nsublis nil 'a :test)) + program-error) + +(deftest nsublis.error.4 + (classify-error (nsublis nil 'a :bad-keyword t)) + program-error) + +(deftest nsublis.error.5 + (classify-error (nsublis '((a . 1) (b . 2)) + (list 'a 'b 'c 'd) + :test #'identity)) + program-error) + +(deftest nsublis.error.6 + (classify-error (nsublis '((a . 1) (b . 2)) + (list 'a 'b 'c 'd) + :key #'cons)) + program-error) + +(deftest nsublis.error.7 + (classify-error (nsublis '((a . 1) (b . 2)) + (list 'a 'b 'c 'd) + :test-not #'identity)) + program-error) + +(deftest nsublis.error.8 + (classify-error (nsublis '((a . 1) . bad) + (list 'a 'b 'c 'd))) + type-error) diff --git a/ansi-tests/nsubst-if-not.lsp b/ansi-tests/nsubst-if-not.lsp new file mode 100644 index 0000000000000000000000000000000000000000..dc704267932298f82768ea9ab8dbdac15a5ae654 --- /dev/null +++ b/ansi-tests/nsubst-if-not.lsp @@ -0,0 +1,119 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:54:12 2003 +;;;; Contains: Tests of NSUBST-IF-NOT + +(in-package :cl-test) + +(deftest nsubst-if-not.1 + (check-nsubst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) + ((x) + ((x) (x) x) + ((x) (x) (x) x) + ((x) (x) (x) (x) x) + x)) + +(deftest nsubst-if-not.2 + (check-nsubst-if-not 'a (complement #'listp) + '((100 1) (2 3) (4 3 2 1) (a b c))) + a) + +(deftest nsubst-if-not.3 + (check-nsubst-if-not 'c #'identity + '((100 1) (2 3) (4 3 2 1) (a b c)) + :key (complement #'listp)) + c) + +(deftest nsubst-if-not.4 + (check-nsubst-if-not + 40 + #'(lambda (x) (not (eql x 17))) + '((17) (17 22) (17 22 31) (17 21 34 54)) + :key #'(lambda (x) + (and (consp x) + (car x)))) + (40 40 40 40)) + +(deftest nsubst-if-not.5 + (check-nsubst-if-not 'a #'(lambda (x) (not (eql x 'b))) + '((a) (b) (c) (d)) + :key nil) + ((a) (a) (c) (d))) + +(deftest nsubst-if-not.6 + (nsubst-if-not 'a #'null nil :bad t :allow-other-keys t) + nil) + +(deftest nsubst-if-not.7 + (let ((i 0) w x y z) + (values + (nsubst-if-not + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) #'(lambda (x) (not (eql x 'b)))) + (progn (setf y (incf i)) (copy-list '(1 2 a b c))) + :key (progn (setf z (incf i)) #'identity)) + i w x y z)) + (1 2 a a c) + 4 1 2 3 4) + +;;; Keywords tests for nsubst-if-not + +(deftest nsubst-if-not.allow-other-keys.1 + (nsubst-if-not 'a #'identity nil :bad t :allow-other-keys t) + a) + +(deftest nsubst-if-not.allow-other-keys.2 + (nsubst-if-not 'a #'identity nil :allow-other-keys t) + a) + +(deftest nsubst-if-not.allow-other-keys.3 + (nsubst-if-not 'a #'identity nil :allow-other-keys nil) + a) + +(deftest nsubst-if-not.allow-other-keys.4 + (nsubst-if-not 'a #'identity nil :allow-other-keys t :bad t) + a) + +(deftest nsubst-if-not.allow-other-keys.5 + (nsubst-if-not 'a #'identity nil :allow-other-keys t :allow-other-keys nil :bad t) + a) + +(deftest nsubst-if-not.keywords.6 + (nsubst-if-not 'a #'identity nil :key nil :key (constantly 'b)) + a) + +;;; error cases + +(deftest nsubst-if-not.error.1 + (classify-error (nsubst-if-not)) + program-error) + +(deftest nsubst-if-not.error.2 + (classify-error (nsubst-if-not 'a)) + program-error) + +(deftest nsubst-if-not.error.3 + (classify-error (nsubst-if-not 'a #'null)) + program-error) + +(deftest nsubst-if-not.error.4 + (classify-error (nsubst-if-not 'a #'null nil :foo nil)) + program-error) + +(deftest nsubst-if-not.error.5 + (classify-error (nsubst-if-not 'a #'null nil :test)) + program-error) + +(deftest nsubst-if-not.error.6 + (classify-error (nsubst-if-not 'a #'null nil 1)) + program-error) + +(deftest nsubst-if-not.error.7 + (classify-error (nsubst-if-not 'a #'null nil + :bad t :allow-other-keys nil)) + program-error) + +(deftest nsubst-if-not.error.8 + (classify-error (nsubst-if-not 'a #'null (list 'a nil 'c) :key #'cons)) + program-error) + diff --git a/ansi-tests/nsubst-if.lsp b/ansi-tests/nsubst-if.lsp new file mode 100644 index 0000000000000000000000000000000000000000..3c5f335c83fd8251038cc8da1b5a2be78bc4d163 --- /dev/null +++ b/ansi-tests/nsubst-if.lsp @@ -0,0 +1,119 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:51:41 2003 +;;;; Contains: Tests of NSUBST-IF + +(in-package :cl-test) + +(deftest nsubst-if.1 + (check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) + a) + +(deftest nsubst-if.2 + (check-nsubst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) + (17 (17 17) (17 17 17) (17 nil 17 17 17))) + +(deftest nsubst-if.3 + (check-nsubst-if '(z) + (complement #'consp) + '(a (a b) (c d e) (f g h i))) + ((z) + ((z) (z) z) + ((z) (z) (z) z) + ((z) (z) (z) (z) z) + z)) + +(deftest nsubst-if.4 + (check-nsubst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) + :key #'listp) + b) + +(deftest nsubst-if.5 + (check-nsubst-if 4 #'(lambda (x) (eql x 1)) + '((1 3) (1) (1 10 20 30) (1 3 x y)) + :key #'(lambda (x) + (and (consp x) + (car x)))) + (4 4 4 4)) + +(deftest nsubst-if.6 + (check-nsubst-if 'a #'(lambda (x) (eql x 'b)) + '((a) (b) (c) (d)) + :key nil) + ((a) (a) (c) (d))) + +(deftest nsubst-if.7 + (nsubst-if 'a #'null nil :bad t :allow-other-keys t) + a) + +(deftest nsubst-if.8 + (let ((i 0) w x y z) + (values + (nsubst-if + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) #'(lambda (x) (eql x 'b))) + (progn (setf y (incf i)) (copy-list '(1 2 a b c))) + :key (progn (setf z (incf i)) #'identity)) + i w x y z)) + (1 2 a a c) + 4 1 2 3 4) + +;;; Keyword tests for nsubst-if + +(deftest nsubst-if.allow-other-keys.1 + (nsubst-if 'a #'null nil :bad t :allow-other-keys t) + a) + +(deftest nsubst-if.allow-other-keys.2 + (nsubst-if 'a #'null nil :allow-other-keys t) + a) + +(deftest nsubst-if.allow-other-keys.3 + (nsubst-if 'a #'null nil :allow-other-keys nil) + a) + +(deftest nsubst-if.allow-other-keys.4 + (nsubst-if 'a #'null nil :allow-other-keys t :bad t) + a) + +(deftest nsubst-if.allow-other-keys.5 + (nsubst-if 'a #'null nil :allow-other-keys t :allow-other-keys nil :bad t) + a) + +(deftest nsubst-if.keywords.6 + (nsubst-if 'a #'null nil :key nil :key (constantly 'b)) + a) + +;;; error cases + +(deftest nsubst-if.error.1 + (classify-error (nsubst-if)) + program-error) + +(deftest nsubst-if.error.2 + (classify-error (nsubst-if 'a)) + program-error) + +(deftest nsubst-if.error.3 + (classify-error (nsubst-if 'a #'null)) + program-error) + +(deftest nsubst-if.error.4 + (classify-error (nsubst-if 'a #'null nil :foo nil)) + program-error) + +(deftest nsubst-if.error.5 + (classify-error (nsubst-if 'a #'null nil :test)) + program-error) + +(deftest nsubst-if.error.6 + (classify-error (nsubst-if 'a #'null nil 1)) + program-error) + +(deftest nsubst-if.error.7 + (classify-error (nsubst-if 'a #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest nsubst-if.error.8 + (classify-error (nsubst-if 'a #'null (list 'a nil 'c) :key #'cons)) + program-error) diff --git a/ansi-tests/nsubst.lsp b/ansi-tests/nsubst.lsp new file mode 100644 index 0000000000000000000000000000000000000000..c089e8c8635976434d84d0fd69399bd0ad79d70d --- /dev/null +++ b/ansi-tests/nsubst.lsp @@ -0,0 +1,158 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:49:58 2003 +;;;; Contains: Tests of NSUBST + +(in-package :cl-test) + + +(defvar *nsubst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) + +(deftest nsubst.1 + (check-nsubst "Z" 30 (copy-tree *nsubst-tree-1*)) + (10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) + +(deftest nsubst.2 + (check-nsubst "A" 0 (copy-tree *nsubst-tree-1*)) + (10 (30 20 10) (20 10) (10 20 30 40))) + +(deftest nsubst.3 + (check-nsubst "Z" 100 (copy-tree *nsubst-tree-1*) :test-not #'eql) + "Z") + +(deftest nsubst.4 + (check-nsubst 'grape 'dick + '(melville wrote (moby dick))) + (melville wrote (moby grape))) + +(deftest nsubst.5 + (check-nsubst 'cha-cha-cha 'nil '(melville wrote (moby dick))) + (melville wrote (moby dick . cha-cha-cha) . cha-cha-cha)) + +(deftest nsubst.6 + (check-nsubst + '(1 2) '(foo . bar) + '((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) + :test #'equal) + ((foo . baz) (1 2) (bar . foo) (baz 1 2))) + +(deftest nsubst.7 + (check-nsubst + 'foo "aaa" + '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) + :key #'(lambda (x) (if (and (numberp x) (evenp x)) + "aaa" + nil)) + :test #'string=) + ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) + +(deftest nsubst.8 + (check-nsubst + 'foo nil + '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) + :key #'(lambda (x) (if (and (numberp x) (evenp x)) + (copy-seq "aaa") + nil)) + :test-not #'equal) + ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) + +(deftest nsubst.9 + (check-nsubst 'a 'b + (copy-tree '(a b c d a b)) + :key nil) + (a a c d a a)) + +;;; Order of argument evaluation +(deftest nsubst.order.1 + (let ((i 0) v w x y z) + (values + (nsubst (progn (setf v (incf i)) 'b) + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) + :key (progn (setf y (incf i)) #'identity) + :test (progn (setf z (incf i)) #'eql)) + i v w x y z)) + ((10 b . b) b b c ((b)) z) + 5 1 2 3 4 5) + +(deftest nsubst.order.2 + (let ((i 0) v w x y z) + (values + (nsubst (progn (setf v (incf i)) 'b) + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) + :test-not (progn (setf y (incf i)) (complement #'eql)) + :key (progn (setf z (incf i)) #'identity) + ) + i v w x y z)) + ((10 b . b) b b c ((b)) z) + 5 1 2 3 4 5) + +;;; Keyword tests for nsubst + +(deftest nsubst.allow-other-keys.1 + (nsubst 'a 'b (list 'a 'b 'c) :bad t :allow-other-keys t) + (a a c)) + +(deftest nsubst.allow-other-keys.2 + (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t) + (a a c)) + +(deftest nsubst.allow-other-keys.3 + (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys nil) + (a a c)) + +(deftest nsubst.allow-other-keys.4 + (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t :bad t) + (a a c)) + +(deftest nsubst.allow-other-keys.5 + (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t :allow-other-keys nil + :bad t) + (a a c)) + +(deftest nsubst.keywords.6 + (nsubst 'a 'b (list 'a 'b 'c) :test #'eq :test (complement #'eq)) + (a a c)) + +;;; Error cases + +(deftest nsubst.error.1 + (classify-error (nsubst)) + program-error) + +(deftest nsubst.error.2 + (classify-error (nsubst 'a)) + program-error) + +(deftest nsubst.error.3 + (classify-error (nsubst 'a 'b)) + program-error) + +(deftest nsubst.error.4 + (classify-error (nsubst 'a 'b nil :foo nil)) + program-error) + +(deftest nsubst.error.5 + (classify-error (nsubst 'a 'b nil :test)) + program-error) + +(deftest nsubst.error.6 + (classify-error (nsubst 'a 'b nil 1)) + program-error) + +(deftest nsubst.error.7 + (classify-error (nsubst 'a 'b nil :bad t :allow-other-keys nil)) + program-error) + +(deftest nsubst.error.8 + (classify-error (nsubst 'a 'b (list 'a 'b) :test #'identity)) + program-error) + +(deftest nsubst.error.9 + (classify-error (nsubst 'a 'b (list 'a 'b) :test-not #'identity)) + program-error) + +(deftest nsubst.error.10 + (classify-error (nsubst 'a 'b (list 'a 'b) :key #'equal)) + program-error) diff --git a/ansi-tests/nth.lsp b/ansi-tests/nth.lsp new file mode 100644 index 0000000000000000000000000000000000000000..08b72d9b31e963de8323f739e9d92aa16ddf904b --- /dev/null +++ b/ansi-tests/nth.lsp @@ -0,0 +1,55 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:33:23 2003 +;;;; Contains: Tests of NTH + +(in-package :cl-test) + +(deftest nth.1 + (nth-1-body (loop for i from 1 to 2000 collect (* 4 i))) + 0) + +(deftest nth.2 + (let ((x (loop for i from 1 to 2000 collect i))) + (loop + for i from 0 to 1999 do + (setf (nth i x) (- 1999 i))) + (equalt x (loop for i from 1999 downto 0 collect i))) + t) + +;;; Test side effects, evaluation order in assignment to NTH +(deftest nth.order.1 + (let ((i 0) + (x (list 'a 'b 'c 'd)) + y z) + (and + (eqlt (setf (nth (setf y (incf i)) x) (progn (setf z (incf i)) 'z)) + 'z) + (eqlt y 1) + (eqlt z 2) + x)) + (a z c d)) + +(deftest nth.order.2 + (let ((i 0) x y (z '(a b c d e))) + (values + (nth (progn (setf x (incf i)) 1) + (progn (setf y (incf i)) z)) + i x y)) + b 2 1 2) + +(deftest nth.error.1 + (classify-error (nth)) + program-error) + +(deftest nth.error.2 + (classify-error (nth 0)) + program-error) + +(deftest nth.error.3 + (classify-error (nth 1 '(a b c) nil)) + program-error) + +(deftest nth.error.4 + (classify-error (nth 0 '(a b c) nil)) + program-error) diff --git a/ansi-tests/cons-test-12.lsp b/ansi-tests/nthcdr.lsp similarity index 74% rename from ansi-tests/cons-test-12.lsp rename to ansi-tests/nthcdr.lsp index 2402b86a62b2fe8e768c150af37b52163a7c37e7..b5b200c10b7118ff15a195f0b0ea9ae5ca10e3dd 100644 --- a/ansi-tests/cons-test-12.lsp +++ b/ansi-tests/nthcdr.lsp @@ -1,15 +1,10 @@ ;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:38:26 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 12 +;;;; Created: Sat Apr 19 22:48:36 2003 +;;;; Contains: Tests of NTHCDR (in-package :cl-test) -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; nthcdr - (deftest nthcdr.error.1 (classify-error (nthcdr nil (copy-tree '(a b c d)))) type-error) @@ -82,22 +77,3 @@ i x y)) (b c d) 2 1 2) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; rest - -(deftest rest.1 - (rest (list 'a 'b 'c)) - (b c)) - -(deftest rest.order.1 - (let ((i 0)) - (values (rest (progn (incf i) '(a b))) i)) - (b) 1) - -(deftest rest.error.1 - (classify-error (rest)) - program-error) - -(deftest rest.error.2 - (classify-error (rest nil nil)) - program-error) diff --git a/ansi-tests/cons-test-21.lsp b/ansi-tests/nunion.lsp similarity index 97% rename from ansi-tests/cons-test-21.lsp rename to ansi-tests/nunion.lsp index cb0658f1e132356221f00aaa3ca642656fa76f00..496b2a45340c78a8eaf50594323ca91d31ef3f3e 100644 --- a/ansi-tests/cons-test-21.lsp +++ b/ansi-tests/nunion.lsp @@ -1,15 +1,10 @@ ;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 22:11:27 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 21 +;;;; Created: Sun Apr 20 07:42:35 2003 +;;;; Contains: Tests of NUNION (in-package :cl-test) -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; nunion - (deftest nunion.1 (nunion nil nil) nil) diff --git a/ansi-tests/pairlis.lsp b/ansi-tests/pairlis.lsp new file mode 100644 index 0000000000000000000000000000000000000000..a16f4b70e59c68b2701f11e389d3d05893def390 --- /dev/null +++ b/ansi-tests/pairlis.lsp @@ -0,0 +1,86 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:30:55 2003 +;;;; Contains: Tests of PAIRLIS + +(in-package :cl-test) + +;; Pairlis has two legal behaviors: the pairs +;; can be prepended in the same order, or in the +;; reverse order, that they appear in the first +;; two arguments + +(defun my-pairlis (x y &optional alist) + (if (null x) + alist + (acons (car x) (car y) + (my-pairlis (cdr x) (cdr y) alist)))) + +(deftest pairlis.1 + (pairlis nil nil nil) + nil) + +(deftest pairlis.2 + (pairlis '(a) '(b) nil) + ((a . b))) + +(deftest pairlis.3 + (let* ((x (copy-list '(a b c d e))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(1 2 3 4 5))) + (ycopy (make-scaffold-copy y)) + (result (pairlis x y)) + (expected (my-pairlis x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (or + (equal result expected) + (equal result (reverse expected))) + t)) + t) + +(deftest pairlis.4 + (let* ((x (copy-list '(a b c d e))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(1 2 3 4 5))) + (ycopy (make-scaffold-copy y)) + (z '((x . 10) (y . 20))) + (zcopy (make-scaffold-copy z)) + (result (pairlis x y z)) + (expected (my-pairlis x y z))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (check-scaffold-copy z zcopy) + (eqt (cdr (cddr (cddr result))) z) + (or + (equal result expected) + (equal result (append (reverse (subseq expected 0 5)) + (subseq expected 5)))) + t)) + t) + +(deftest pairlis.error.1 + (classify-error (pairlis)) + program-error) + +(deftest pairlis.error.2 + (classify-error (pairlis nil)) + program-error) + +(deftest pairlis.error.3 + (classify-error (pairlis nil nil nil nil)) + program-error) + +(deftest pairlis.error.4 + (classify-error (pairlis 'a '(1))) + type-error) + +(deftest pairlis.error.5 + (classify-error (pairlis '(a) 'b)) + type-error) + +(deftest pairlis.error.6 + (classify-error (pairlis '(a . b) '(c . d))) + type-error) diff --git a/ansi-tests/pop.lsp b/ansi-tests/pop.lsp new file mode 100644 index 0000000000000000000000000000000000000000..f6b7cc26b11ab4344b3885d588d1e9a4b9cd983f --- /dev/null +++ b/ansi-tests/pop.lsp @@ -0,0 +1,38 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:27:18 2003 +;;;; Contains: Tests of POP + + +(in-package :cl-test) + +(deftest pop.1 + (let ((x (copy-tree '(a b c)))) + (let ((y (pop x))) + (list x y))) + ((b c) a)) + +(deftest pop.2 + (let ((x nil)) + (let ((y (pop x))) + (list x y))) + (nil nil)) + +;;; Confirm argument is executed just once. +(deftest pop.order.1 + (let ((i 0) + (a (vector (list 'a 'b 'c)))) + (pop (aref a (progn (incf i) 0))) + (values a i)) + #((b c)) 1) + +(deftest push-and-pop + (let* ((x (copy-tree '(a b))) + (y x)) + (push 'c x) + (and + (eqt (cdr x) y) + (pop x))) + c) + +;;; Need to add tests of POP vs. various accessors diff --git a/ansi-tests/push.lsp b/ansi-tests/push.lsp new file mode 100644 index 0000000000000000000000000000000000000000..ee99f99de63f4cf9e4d3799fef164b5172a39807 --- /dev/null +++ b/ansi-tests/push.lsp @@ -0,0 +1,38 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:05:34 2003 +;;;; Contains: Tests of PUSH + +(in-package :cl-test) + +;;; See also places.lsp + +(deftest push.1 + (let ((x nil)) + (push 'a x)) + (a)) + +(deftest push.2 + (let ((x 'b)) + (push 'a x) + (push 'c x)) + (c a . b)) + +(deftest push.3 + (let ((x (copy-tree '(a)))) + (push x x) + (and + (eqt (car x) (cdr x)) + x)) + ((a) a)) + +(deftest push.order.1 + (let ((x (list nil)) (i 0) a b) + (values + (push (progn (setf a (incf i)) 'z) + (car (progn (setf b (incf i)) x))) + x + i a b)) + (z) ((z)) 2 1 2) + +;;; Need to add push vs. various accessors diff --git a/ansi-tests/pushnew.lsp b/ansi-tests/pushnew.lsp new file mode 100644 index 0000000000000000000000000000000000000000..745487514f89ba13ab8d16c128a95bc32d92fa0c --- /dev/null +++ b/ansi-tests/pushnew.lsp @@ -0,0 +1,175 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:28:35 2003 +;;;; Contains: Tests of PUSHNEW + +(in-package :cl-test) + +;;; See also places.lsp + +(deftest pushnew.1 + (let ((x nil)) + (let ((y (pushnew 'a x))) + (and + (eqt x y) + (equal x '(a)) + t))) + t) + +(deftest pushnew.2 + (let* ((x (copy-tree '(b c d a k f q))) + (y (pushnew 'a x))) + (and + (eqt x y) + x)) + (b c d a k f q)) + +(deftest pushnew.3 + (let* ((x (copy-tree '(1 2 3 4 5 6 7 8))) + (y (pushnew 7 x))) + (and + (eqt x y) + x)) + (1 2 3 4 5 6 7 8)) + +(deftest pushnew.4 + (let* ((x (copy-tree '((a b) 1 "and" c d e))) + (y (pushnew (copy-tree '(c d)) x + :test 'equal))) + (and (eqt x y) + x)) + ((c d) (a b) 1 "and" c d e)) + +(deftest pushnew.5 + (let* ((x (copy-tree '((a b) 1 "and" c d e))) + (y (pushnew (copy-tree '(a b)) x + :test 'equal))) + (and + (eqt x y) + x)) + ((a b) 1 "and" c d e)) + +(deftest pushnew.6 + (let* ((x (copy-tree '((a b) (c e) (d f) (g h)))) + (y (pushnew (copy-tree '(d i)) x :key #'car)) + (z (pushnew (copy-tree '(z 10)) x :key #'car))) + (and (eqt y (cdr z)) + (eqt z x) + x)) + ((z 10) (a b) (c e) (d f) (g h))) + +(deftest pushnew.7 + (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) + (y (pushnew (copy-tree '("def" 4)) x + :key #'car :test #'string=)) + (z (pushnew (copy-tree '("xyz" 10)) + x + :key #'car :test #'string=))) + (and + (eqt y (cdr x)) + (eqt x z) + x)) + (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) + +(deftest pushnew.8 + (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) + (y (pushnew (copy-tree '("def" 4)) x + :key #'car :test-not (complement #'string=))) + (z (pushnew (copy-tree '("xyz" 10)) x + :key #'car :test-not (complement #'string=)))) + (and + (eqt y (cdr x)) + (eqt x z) + x)) + (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) + +(deftest pushnew.9 + (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) + (y (pushnew (copy-tree '("def" 4)) x + :key 'car :test-not (complement #'string=))) + (z (pushnew (copy-tree '("xyz" 10)) x + :key 'car :test-not (complement #'string=)))) + (and + (eqt y (cdr x)) + (eqt x z) + x)) + (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) + +;; Check that a NIL :key argument is the same as no key argument at all +(deftest pushnew.10 + (let* ((x (list 'a 'b 'c 'd)) + (result (pushnew 'z x :key nil))) + result) + (z a b c d)) + +;; Check that a NIL :key argument is the same as no key argument at all +(deftest pushnew.11 + (let* ((x (copy-tree '((a b) 1 "and" c d e))) + (y (pushnew (copy-tree '(a b)) x + :test 'equal :key nil))) + (and + (eqt x y) + x)) + ((a b) 1 "and" c d e)) + +(deftest pushnew.12 + (let ((i 0) x y z (d '(b c))) + (values + (pushnew (progn (setf x (incf i)) 'a) + d + :key (progn (setf y (incf i)) #'identity) + :test (progn (setf z (incf i)) #'eql)) + d i x y z)) + (a b c) (a b c) + 3 1 2 3) + +(deftest pushnew.13 + (let ((i 0) x y z (d '(b c))) + (values + (pushnew (progn (setf x (incf i)) 'a) + d + :key (progn (setf y (incf i)) #'identity) + :test-not (progn (setf z (incf i)) (complement #'eql))) + d i x y z)) + (a b c) (a b c) + 3 1 2 3) + +(deftest pushnew.14 + (let ((i 0) x y z (d '(b c))) + (values + (pushnew (progn (setf x (incf i)) 'a) + d + :test (progn (setf z (incf i)) #'eql) + :key (progn (setf y (incf i)) #'identity)) + d i x y z)) + (a b c) (a b c) + 3 1 3 2) + +(deftest pushnew.15 + (let ((i 0) x y z (d '(b c))) + (values + (pushnew (progn (setf x (incf i)) 'a) + d + :test-not (progn (setf z (incf i)) (complement #'eql)) + :key (progn (setf y (incf i)) #'identity)) + d i x y z)) + (a b c) (a b c) + 3 1 3 2) + +(deftest pushnew.error.1 + (classify-error + (let ((x '(a b))) + (pushnew 'c x :test #'identity))) + program-error) + +(deftest pushnew.error.2 + (classify-error + (let ((x '(a b))) + (pushnew 'c x :test-not #'identity))) + program-error) + +(deftest pushnew.error.3 + (classify-error + (let ((x '(a b))) + (pushnew 'c x :key #'cons))) + program-error) diff --git a/ansi-tests/rassoc-if-not.lsp b/ansi-tests/rassoc-if-not.lsp new file mode 100644 index 0000000000000000000000000000000000000000..0139d3dd83501a16550bfa83d889f2a5b89afb18 --- /dev/null +++ b/ansi-tests/rassoc-if-not.lsp @@ -0,0 +1,141 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:35:27 2003 +;;;; Contains: Tests of RASSOC-IF-NOT + +(in-package :cl-test) + + +(deftest rassoc-if-not.1 + (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if-not #'oddp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (c . 6)) + +(deftest rassoc-if-not.2 + (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if-not #'evenp x :key #'1+))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (c . 6)) + +(deftest rassoc-if-not.3 + (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if-not #'oddp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (fourth x)) + result)) + (c . 6)) + +(deftest rassoc-if-not.4 + (rassoc-if-not #'identity + (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) + (e)) + +;;; Order of argument evaluation + +(deftest rassoc-if-not.order.1 + (let ((i 0) x y) + (values + (rassoc-if-not (progn (setf x (incf i)) #'identity) + (progn (setf y (incf i)) + '((1 . a) (2 . b) (17) (4 . d)))) + i x y)) + (17) 2 1 2) + +(deftest rassoc-if-not.order.2 + (let ((i 0) x y z) + (values + (rassoc-if-not (progn (setf x (incf i)) #'identity) + (progn (setf y (incf i)) + '((1 . a) (2 . b) (17) (4 . d))) + :key (progn (setf z (incf i)) #'null)) + i x y z)) + (1 . a) 3 1 2 3) + +;;; Keyword tests + +(deftest rassoc-if-not.allow-other-keys.1 + (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :bad t :allow-other-keys t) + (2)) + +(deftest rassoc-if-not.allow-other-keys.2 + (rassoc-if-not #'values '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t) + (2)) + +(deftest rassoc-if-not.allow-other-keys.3 + (rassoc-if-not #'not '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t + :key 'not) + (2)) + +(deftest rassoc-if-not.allow-other-keys.4 + (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t) + (2)) + +(deftest rassoc-if-not.allow-other-keys.5 + (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys nil) + (2)) + +(deftest rassoc-if-not.allow-other-keys.6 + (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t + :allow-other-keys nil :bad t) + (2)) + +(deftest rassoc-if-not.keywords.7 + (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :key #'not :key nil) + (1 . a)) + +;;; Error tests + +(deftest rassoc-if-not.error.1 + (classify-error (rassoc-if-not)) + program-error) + +(deftest rassoc-if-not.error.2 + (classify-error (rassoc-if-not #'null)) + program-error) + +(deftest rassoc-if-not.error.3 + (classify-error (rassoc-if-not #'null nil :bad t)) + program-error) + +(deftest rassoc-if-not.error.4 + (classify-error (rassoc-if-not #'null nil :key)) + program-error) + +(deftest rassoc-if-not.error.5 + (classify-error (rassoc-if-not #'null nil 1 1)) + program-error) + +(deftest rassoc-if-not.error.6 + (classify-error (rassoc-if-not #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest rassoc-if-not.error.7 + (classify-error (rassoc-if-not #'cons '((a . b)(c . d)))) + program-error) + +(deftest rassoc-if-not.error.8 + (classify-error (rassoc-if-not #'car '((a . b)(c . d)))) + type-error) + +(deftest rassoc-if-not.error.9 + (classify-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'cons)) + program-error) + +(deftest rassoc-if-not.error.10 + (classify-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'car)) + type-error) + +(deftest rassoc-if-not.error.11 + (classify-error (rassoc-if-not #'identity '((a . b) . c))) + type-error) diff --git a/ansi-tests/rassoc-if.lsp b/ansi-tests/rassoc-if.lsp new file mode 100644 index 0000000000000000000000000000000000000000..b5d347a8d577245ae1e29490de4f429f8848ea71 --- /dev/null +++ b/ansi-tests/rassoc-if.lsp @@ -0,0 +1,137 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:34:59 2003 +;;;; Contains: Tests of RASSOC-IF + +(in-package :cl-test) + +(deftest rassoc-if.1 + (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if #'evenp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (c . 6)) + +(deftest rassoc-if.2 + (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if #'oddp x :key #'1+))) + (and + (check-scaffold-copy x xcopy) + (eqt result (third x)) + result)) + (c . 6)) + +(deftest rassoc-if.3 + (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if #'evenp x))) + (and + (check-scaffold-copy x xcopy) + (eqt result (fourth x)) + result)) + (c . 6)) + +(deftest rassoc-if.4 + (rassoc-if #'null + (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) + (e)) + +;;; Order of argument evaluation + +(deftest rassoc-if.order.1 + (let ((i 0) x y) + (values + (rassoc-if (progn (setf x (incf i)) #'null) + (progn (setf y (incf i)) + '((1 . a) (2 . b) (17) (4 . d)))) + i x y)) + (17) 2 1 2) + +(deftest rassoc-if.order.2 + (let ((i 0) x y z) + (values + (rassoc-if (progn (setf x (incf i)) #'null) + (progn (setf y (incf i)) + '((1 . a) (2 . b) (17) (4 . d))) + :key (progn (setf z (incf i)) #'null)) + i x y z)) + (1 . a) 3 1 2 3) + + +;;; Keyword tests + +(deftest rassoc-if.allow-other-keys.1 + (rassoc-if #'null '((1 . a) (2) (3 . c)) :bad t :allow-other-keys t) + (2)) + +(deftest rassoc-if.allow-other-keys.2 + (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t) + (2)) + +(deftest rassoc-if.allow-other-keys.3 + (rassoc-if #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t + :key 'not) + (2)) + +(deftest rassoc-if.allow-other-keys.4 + (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys t) + (2)) + +(deftest rassoc-if.allow-other-keys.5 + (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys nil) + (2)) + +(deftest rassoc-if.keywords.6 + (rassoc-if #'identity '((1 . a) (2) (3 . c)) :key #'not :key #'identity) + (2)) + +;;; Error tests + +(deftest rassoc-if.error.1 + (classify-error (rassoc-if)) + program-error) + +(deftest rassoc-if.error.2 + (classify-error (rassoc-if #'null)) + program-error) + +(deftest rassoc-if.error.3 + (classify-error (rassoc-if #'null nil :bad t)) + program-error) + +(deftest rassoc-if.error.4 + (classify-error (rassoc-if #'null nil :key)) + program-error) + +(deftest rassoc-if.error.5 + (classify-error (rassoc-if #'null nil 1 1)) + program-error) + +(deftest rassoc-if.error.6 + (classify-error (rassoc-if #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest rassoc-if.error.7 + (classify-error (rassoc-if #'cons '((a . b)(c . d)))) + program-error) + +(deftest rassoc-if.error.8 + (classify-error (rassoc-if #'car '((a . b)(c . d)))) + type-error) + +(deftest rassoc-if.error.9 + (classify-error (rassoc-if #'identity '((a . b)(c . d)) :key #'cons)) + program-error) + +(deftest rassoc-if.error.10 + (classify-error (rassoc-if #'identity '((a . b)(c . d)) :key #'car)) + type-error) + +(deftest rassoc-if.error.11 + (classify-error (rassoc-if #'not '((a . b) . c))) + type-error) + diff --git a/ansi-tests/rassoc.lsp b/ansi-tests/rassoc.lsp new file mode 100644 index 0000000000000000000000000000000000000000..49877d2234d9e3a22ce1d85ac3fe88a5728d2985 --- /dev/null +++ b/ansi-tests/rassoc.lsp @@ -0,0 +1,287 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:33:49 2003 +;;;; Contains: Tests of RASSOC + +(in-package :cl-test) + +(deftest rassoc.1 + (rassoc nil nil) + nil) + +(deftest rassoc.2 + (rassoc nil '(nil)) + nil) + +(deftest rassoc.3 + (rassoc nil (rev-assoc-list '(nil (nil . 2) (a . b)))) + (2 . nil)) + +(deftest rassoc.4 + (rassoc nil '((a . b) (c . d))) + nil) + +(deftest rassoc.5 + (rassoc 'a '((b . a))) + (b . a)) + +(deftest rassoc.6 + (rassoc 'a (rev-assoc-list '((:a . b) (#:a . c) (a . d) (a . e) (z . f)))) + (d . a)) + +(deftest rassoc.7 + (let* ((x (copy-tree (rev-assoc-list '((a . b) (b . c) (c . d))))) + (xcopy (make-scaffold-copy x)) + (result (rassoc 'b x))) + (and + (eqt result (second x)) + (check-scaffold-copy x xcopy))) + t) + +(deftest rassoc.8 + (rassoc 1 (rev-assoc-list '((0 . a) (1 . b) (2 . c)))) + (b . 1)) + +(deftest rassoc.9 + (rassoc (copy-seq "abc") + (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3)))) + nil) + +(deftest rassoc.10 + (rassoc (copy-list '(a)) + (copy-tree (rev-assoc-list '(((a) b) ((a) (c)))))) + nil) + +(deftest rassoc.11 + (let ((x (list 'a 'b))) + (rassoc x + (rev-assoc-list `(((a b) c) (,x . d) (,x . e) ((a b) 1))))) + (d a b)) + + +(deftest rassoc.12 + (rassoc #\e + (copy-tree + (rev-assoc-list '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)))) + :key #'(lambda (x) (char x 1))) + (2 . "aevgd")) + +(deftest rassoc.13 + (rassoc nil + (copy-tree + (rev-assoc-list + '(((a) . b) ( nil . c ) ((nil) . d)))) + :key #'car) + (c)) + +(deftest rassoc.14 + (rassoc (copy-seq "abc") + (copy-tree + (rev-assoc-list + '((abc . 1) ("abc" . 2) ("abc" . 3)))) + :test #'equal) + (2 . "abc")) + +(deftest rassoc.15 + (rassoc (copy-seq "abc") + (copy-tree + (rev-assoc-list + '((abc . 1) ("abc" . 2) ("abc" . 3)))) + :test #'equalp) + (2 . "abc")) + +(deftest rassoc.16 + (rassoc (copy-list '(a)) + (copy-tree + (rev-assoc-list '(((a) b) ((a) (c))))) + :test #'equal) + ((b) a)) + +(deftest rassoc.17 + (rassoc (copy-seq "abc") + (copy-tree + (rev-assoc-list + '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)))) + :test-not (complement #'equalp)) + (2 . "abc")) + +(deftest rassoc.18 + (rassoc 'a + (copy-tree + (rev-assoc-list + '((a . d)(b . c)))) + :test-not #'eq) + (c . b)) + +(deftest rassoc.19 + (rassoc 'a + (copy-tree + (rev-assoc-list + '((a . d)(b . c)))) + :test (complement #'eq)) + (c . b)) + +(deftest rassoc.20 + (rassoc "a" + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test #'equal) + (6 . "A")) + +(deftest rassoc.21 + (rassoc "a" + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) x)) + :test #'equal) + (3 . "a")) + +(deftest rassoc.22 + (rassoc "a" + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test-not (complement #'equal)) + (6 . "A")) + +(deftest rassoc.23 + (rassoc "a" + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) x)) + :test-not (complement #'equal)) + (3 . "a")) + +;; Check that it works when test returns a true value +;; other than T + +(deftest rassoc.24 + (rassoc 'a + (copy-tree + (rev-assoc-list + '((b . 1) (a . 2) (c . 3)))) + :test #'(lambda (x y) (and (eqt x y) 'matched))) + (2 . a)) + +;; Check that the order of the arguments to :test is correct + +(deftest rassoc.25 + (block fail + (rassoc 'a '((1 . b) (2 . c) (3 . a)) + :test #'(lambda (x y) + (unless (eqt x 'a) (return-from fail 'fail)) + (eqt x y)))) + (3 . a)) + +;;; Order of argument evaluation + +(deftest rassoc.order.1 + (let ((i 0) x y) + (values + (rassoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c)))) + i x y)) + (3 . c) 2 1 2) + +(deftest rassoc.order.2 + (let ((i 0) x y z) + (values + (rassoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) + :test (progn (setf z (incf i)) #'eql)) + i x y z)) + (3 . c) 3 1 2 3) + +(deftest rassoc.order.3 + (let ((i 0) x y) + (values + (rassoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) + :test #'eql) + i x y)) + (3 . c) 2 1 2) + +(deftest rassoc.order.4 + (let ((i 0) x y z w) + (values + (rassoc (progn (setf x (incf i)) 'c) + (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf w (incf i)) #'not)) + i x y z w)) + (3 . c) 4 1 2 3 4) + +;;; Keyword tests + +(deftest rassoc.allow-other-keys.1 + (rassoc 'b '((1 . a) (2 . b) (3 . c)) :bad t :allow-other-keys t) + (2 . b)) + +(deftest rassoc.allow-other-keys.2 + (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys t :bad t) + (2 . b)) + +(deftest rassoc.allow-other-keys.3 + (rassoc 'a '((1 . a) (2 . b) (3 . c)) :allow-other-keys t :bad t + :test-not #'eql) + (2 . b)) + +(deftest rassoc.allow-other-keys.4 + (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys t) + (2 . b)) + +(deftest rassoc.allow-other-keys.5 + (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys nil) + (2 . b)) + +(deftest rassoc.keywords.6 + (rassoc 'b '((1 . a) (2 . b) (3 . c)) + :test #'eql :test (complement #'eql)) + (2 . b)) + +;;; Error tests + +(deftest rassoc.error.1 + (classify-error (rassoc)) + program-error) + +(deftest rassoc.error.2 + (classify-error (rassoc nil)) + program-error) + +(deftest rassoc.error.3 + (classify-error (rassoc nil nil :bad t)) + program-error) + +(deftest rassoc.error.4 + (classify-error (rassoc nil nil :key)) + program-error) + +(deftest rassoc.error.5 + (classify-error (rassoc nil nil 1 1)) + program-error) + +(deftest rassoc.error.6 + (classify-error (rassoc nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest rassoc.error.7 + (classify-error (rassoc 'a '((b . a)(c . d)) :test #'identity)) + program-error) + +(deftest rassoc.error.8 + (classify-error (rassoc 'a '((b . a)(c . d)) :test-not #'identity)) + program-error) + +(deftest rassoc.error.9 + (classify-error (rassoc 'a '((b . a)(c . d)) :key #'cons)) + program-error) + +(deftest rassoc.error.10 + (classify-error (rassoc 'z '((a . b) . c))) + type-error) diff --git a/ansi-tests/remf.lsp b/ansi-tests/remf.lsp new file mode 100644 index 0000000000000000000000000000000000000000..c3ef3aa1f52ec8ddfc5bded7c8a2fb8753db7a7a --- /dev/null +++ b/ansi-tests/remf.lsp @@ -0,0 +1,43 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:38:18 2003 +;;;; Contains: Tests of REMF + +(in-package :cl-test) + +(deftest remf.1 + (let ((x nil)) + (values (remf x 'a) x)) + nil ()) + +(deftest remf.2 + (let ((x (list 'a 'b))) + (values (not (null (remf x 'a))) x)) + t ()) + +(deftest remf.3 + (let ((x (list 'a 'b 'a 'c))) + (values (not (null (remf x 'a))) x)) + t (a c)) + +(deftest remf.4 + (let ((x (list 'a 'b 'c 'd))) + (values + (and (remf x 'c) t) + (loop + for ptr on x by #'cddr count + (not (eqt (car ptr) 'a))))) + t 0) + +(deftest remf.order.1 + (let ((i 0) x y + (p (make-array 1 :initial-element (copy-list '(a b c d e f))))) + (values + (notnot + (remf (aref p (progn (setf x (incf i)) 0)) + (progn (setf y (incf i)) + 'c))) + (aref p 0) + i x y)) + t (a b e f) 2 1 2) + diff --git a/ansi-tests/rest.lsp b/ansi-tests/rest.lsp new file mode 100644 index 0000000000000000000000000000000000000000..6cd50af124d3243d380ce9e1b29607b54caebe79 --- /dev/null +++ b/ansi-tests/rest.lsp @@ -0,0 +1,25 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:49:14 2003 +;;;; Contains: Tests of REST + +(in-package :cl-test) + +(deftest rest.1 + (rest (list 'a 'b 'c)) + (b c)) + +(deftest rest.order.1 + (let ((i 0)) + (values (rest (progn (incf i) '(a b))) i)) + (b) 1) + +(deftest rest.error.1 + (classify-error (rest)) + program-error) + +(deftest rest.error.2 + (classify-error (rest nil nil)) + program-error) + + diff --git a/ansi-tests/revappend.lsp b/ansi-tests/revappend.lsp new file mode 100644 index 0000000000000000000000000000000000000000..6c936d244627437bc756ca0f247c765e55c64762 --- /dev/null +++ b/ansi-tests/revappend.lsp @@ -0,0 +1,56 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:37:43 2003 +;;;; Contains: Tests of REVAPPEND + +(in-package :cl-test) + +(deftest revappend.1 + (let* ((x (list 'a 'b 'c)) + (y (list 'd 'e 'f)) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + ) + (let ((result (revappend x y))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (eqt (cdddr result) y) + result))) + (c b a d e f)) + +(deftest revappend.2 + (revappend (copy-tree '(a b c d e)) 10) + (e d c b a . 10)) + +(deftest revappend.3 + (revappend nil 'a) + a) + +(deftest revappend.4 + (revappend (copy-tree '(a (b c) d)) nil) + (d (b c) a)) + +(deftest revappend.order.1 + (let ((i 0) x y) + (values + (revappend (progn (setf x (incf i)) (copy-list '(a b c))) + (progn (setf y (incf i)) (copy-list '(d e f)))) + i x y)) + (c b a d e f) 2 1 2) + +(deftest revappend.error.1 + (classify-error (revappend)) + program-error) + +(deftest revappend.error.2 + (classify-error (revappend nil)) + program-error) + +(deftest revappend.error.3 + (classify-error (revappend nil nil nil)) + program-error) + +(deftest revappend.error.4 + (classify-error (revappend '(a . b) '(z))) + type-error) diff --git a/ansi-tests/rplaca.lsp b/ansi-tests/rplaca.lsp new file mode 100644 index 0000000000000000000000000000000000000000..9cc6917f43b8e5c163e70e7a8dcd9830465731a1 --- /dev/null +++ b/ansi-tests/rplaca.lsp @@ -0,0 +1,51 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:29:43 2003 +;;;; Contains: Tests of RPLACA + +(in-package :cl-test) + +(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) + +(deftest rplaca.order.1 + (let ((x (cons 'a 'b)) + (i 0) a b) + (values + (rplaca (progn (setf a (incf i)) x) + (progn (setf b (incf i)) 'c)) + i a b)) + (c . b) 2 1 2) + +;; rplaca on a fixnum is a type error +(deftest rplaca.error.1 + (loop for x in *universe* + thereis (and (not (consp x)) + (not (eq (catch-type-error (rplaca x 1)) 'type-error)))) + nil) + +(deftest rplaca.error.2 + (classify-error (rplaca)) + program-error) + +(deftest rplaca.error.3 + (classify-error (rplaca (cons 'a 'b))) + program-error) + +(deftest rplaca.error.4 + (classify-error (rplaca (cons 'a 'b) (cons 'c 'd) 'garbage)) + program-error) + +(deftest rplaca.error.5 + (classify-error (rplaca 'a 1)) + type-error) + +(deftest rplaca.error.6 + (classify-error (locally (rplaca 'a 1) t)) + type-error) diff --git a/ansi-tests/rplacd.lsp b/ansi-tests/rplacd.lsp new file mode 100644 index 0000000000000000000000000000000000000000..5738e5931fa353c2ea06b17e6c43522f00d432ad --- /dev/null +++ b/ansi-tests/rplacd.lsp @@ -0,0 +1,52 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:30:28 2003 +;;;; Contains: Tests of RPLACD + +(in-package :cl-test) + +(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) + +(deftest rplacd.order.1 + (let ((x (cons 'a 'b)) + (i 0) a b) + (values + (rplacd (progn (setf a (incf i)) x) + (progn (setf b (incf i)) 'c)) + i a b)) + (a . c) 2 1 2) + +;; rplacd on a fixnum is a type error +(deftest rplacd.error.1 + (loop for x in *universe* + thereis (and (not (consp x)) + (not (eq (catch-type-error (rplacd x 1)) 'type-error)))) + nil) + +(deftest rplacd.error.2 + (classify-error (rplacd)) + program-error) + +(deftest rplacd.error.3 + (classify-error (rplacd (cons 'a 'b))) + program-error) + +(deftest rplacd.error.4 + (classify-error (rplacd (cons 'a 'b) (cons 'c 'd) 'garbage)) + program-error) + +(deftest rplacd.error.5 + (classify-error (rplacd 'a 1)) + type-error) + +(deftest rplacd.error.6 + (classify-error (locally (rplacd 'a 1) t)) + type-error) + diff --git a/ansi-tests/set-difference.lsp b/ansi-tests/set-difference.lsp new file mode 100644 index 0000000000000000000000000000000000000000..356fbde9d3f201c2e1458d48b8354c3aafc7a390 --- /dev/null +++ b/ansi-tests/set-difference.lsp @@ -0,0 +1,314 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:44:06 2003 +;;;; Contains: Tests of SET-DIFFERENCE + +(in-package :cl-test) + +(deftest set-difference.1 + (set-difference nil nil) + nil) + +(deftest set-difference.2 + (let ((result + (set-difference-with-check '(a b c) nil))) + (check-set-difference '(a b c) nil result)) + t) + +(deftest set-difference.3 + (let ((result + (set-difference-with-check '(a b c d e f) '(f b d)))) + (check-set-difference '(a b c d e f) '(f b d) result)) + t) + +(deftest set-difference.4 + (sort + (copy-list + (set-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) + '(10 101 4 74 2 1391 7 17831))) + #'<) + (1 3 5 6 8)) + +(deftest set-difference.5 + (set-difference-with-check nil '(a b c d e f g h)) + nil) + +(deftest set-difference.6 + (set-difference-with-check '(a b c d e) '(d a b e) + :key nil) + (c)) + +(deftest set-difference.7 + (set-difference-with-check '(a b c d e) '(d a b e) :test #'eq) + (c)) + +(deftest set-difference.8 + (set-difference-with-check '(a b c d e) '(d a b e) :test #'eql) + (c)) + +(deftest set-difference.9 + (set-difference-with-check '(a b c d e) '(d a b e) :test #'equal) + (c)) + +(deftest set-difference.10 + (set-difference-with-check '(a b c d e) '(d a b e) + :test 'eq) + (c)) + +(deftest set-difference.11 + (set-difference-with-check '(a b c d e) '(d a b e) + :test 'eql) + (c)) + +(deftest set-difference.12 + (set-difference-with-check '(a b c d e) '(d a b e) + :test 'equal) + (c)) + +(deftest set-difference.13 + (do-random-set-differences 100 100) + nil) + +(deftest set-difference.14 + (set-difference-with-check '((a . 1) (b . 2) (c . 3)) + '((a . 1) (c . 3)) + :key 'car) + ((b . 2))) + +(deftest set-difference.15 + (set-difference-with-check '((a . 1) (b . 2) (c . 3)) + '((a . 1) (c . 3)) + :key #'car) + ((b . 2))) + +;; +;; Verify that the :test argument is called with the arguments +;; in the correct order +;; +(deftest set-difference.16 + (block fail + (sort + (copy-list + (set-difference-with-check + '(1 2 3 4) '(e f g h) + :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 set-difference.17 + (block fail + (sort + (copy-list + (set-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 set-difference.18 + (block fail + (sort + (copy-list + (set-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 set-difference.19 + (block fail + (sort + (copy-list + (set-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)) + +;;; Order of argument evaluation tests + +(deftest set-difference.order.1 + (let ((i 0) x y) + (values + (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) + (progn (setf y (incf i)) (list 2 3 4))) + i x y)) + (1) 2 1 2) + +(deftest set-difference.order.2 + (let ((i 0) x y z) + (values + (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) + (progn (setf y (incf i)) (list 2 3 4)) + :test (progn (setf z (incf i)) + #'(lambda (x y) (= x (1- y))))) + i x y z)) + (4) 3 1 2 3) + +(deftest set-difference.order.3 + (let ((i 0) x y z w) + (values + (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) + (progn (setf y (incf i)) (list 2 3 4)) + :test (progn (setf z (incf i)) + #'(lambda (x y) (= x (1- y)))) + :key (progn (setf w (incf i)) nil)) + i x y z w)) + (4) 4 1 2 3 4) + + +;;; Keyword tests + +(deftest set-difference.allow-other-keys.1 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :bad t :allow-other-keys t)) + #'<) + (1 5)) + +(deftest set-difference.allow-other-keys.2 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t :bad t)) + #'<) + (1 5)) + +(deftest set-difference.allow-other-keys.3 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y))))) + #'<) + (4 5)) + +(deftest set-difference.allow-other-keys.4 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t)) + #'<) + (1 5)) + +(deftest set-difference.allow-other-keys.5 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys nil)) + #'<) + (1 5)) + +(deftest set-difference.allow-other-keys.6 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t + :allow-other-keys nil)) + #'<) + (1 5)) + +(deftest set-difference.allow-other-keys.7 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :allow-other-keys t + :allow-other-keys nil + '#:x 1)) + #'<) + (1 5)) + +(deftest set-difference.keywords.8 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :test #'eql :test (complement #'eql))) + #'<) + (1 5)) + +(deftest set-difference.keywords.9 + (sort + (copy-list + (set-difference + (list 1 2 3 4 5) (list 2 3 4) + :test (complement #'eql) :test #'eql)) + #'<) + nil) + +;;; Error tests + + +(deftest set-difference.error.1 + (classify-error (set-difference)) + program-error) + +(deftest set-difference.error.2 + (classify-error (set-difference nil)) + program-error) + +(deftest set-difference.error.3 + (classify-error (set-difference nil nil :bad t)) + program-error) + +(deftest set-difference.error.4 + (classify-error (set-difference nil nil :key)) + program-error) + +(deftest set-difference.error.5 + (classify-error (set-difference nil nil 1 2)) + program-error) + +(deftest set-difference.error.6 + (classify-error (set-difference nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest set-difference.error.7 + (classify-error (set-difference (list 1 2) (list 3 4) :test #'identity)) + program-error) + +(deftest set-difference.error.8 + (classify-error (set-difference (list 1 2) (list 3 4) :test-not #'identity)) + program-error) + +(deftest set-difference.error.9 + (classify-error (set-difference (list 1 2) (list 3 4) :key #'cons)) + program-error) + +(deftest set-difference.error.10 + (classify-error (set-difference (list 1 2) (list 3 4) :key #'car)) + type-error) + +(deftest set-difference.error.11 + (classify-error (set-difference (list 1 2 3) (list* 4 5 6))) + type-error) + +(deftest set-difference.error.12 + (classify-error (set-difference (list* 1 2 3) (list 4 5 6))) + type-error) diff --git a/ansi-tests/set-exclusive-or.lsp b/ansi-tests/set-exclusive-or.lsp new file mode 100644 index 0000000000000000000000000000000000000000..78b3a2bd185e3546bf6fe3266b729a48fb2cf636 --- /dev/null +++ b/ansi-tests/set-exclusive-or.lsp @@ -0,0 +1,359 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Apr 20 07:45:46 2003 +;;;; Contains: Tests of SET-EXCLUSIVE-OR + +(in-package :cl-test) + +(deftest set-exclusive-or.1 + (set-exclusive-or nil nil) + nil) + +(deftest set-exclusive-or.2 + (let ((result + (set-exclusive-or-with-check '(a b c) nil))) + (check-set-exclusive-or '(a b c) nil result)) + t) + +(deftest set-exclusive-or.3 + (let ((result + (set-exclusive-or-with-check '(a b c d e f) '(f b d)))) + (check-set-exclusive-or '(a b c d e f) '(f b d) result)) + t) + +(deftest set-exclusive-or.4 + (sort + (copy-list + (set-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) + '(10 101 4 74 2 1391 7 17831))) + #'<) + (1 3 5 6 8 10 74 101 1391 17831)) + +(deftest set-exclusive-or.5 + (check-set-exclusive-or + nil + '(a b c d e f g h) + (set-exclusive-or-with-check nil '(a b c d e f g h))) + t) + +(deftest set-exclusive-or.6 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :key nil) + (c)) + +(deftest set-exclusive-or.7 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eq) + (c)) + +(deftest set-exclusive-or.7-a + (set-exclusive-or-with-check '(d a b e) '(a b c d e) :test #'eq) + (c)) + +(deftest set-exclusive-or.8 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eql) + (c)) + +(deftest set-exclusive-or.8-a + (set-exclusive-or-with-check '(e d b a) '(a b c d e) :test #'eql) + (c)) + +(deftest set-exclusive-or.8-b + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :test-not (complement #'eql)) + (c)) + +(deftest set-exclusive-or.9 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'equal) + (c)) + +(deftest set-exclusive-or.10 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'eq) + (c)) + +(deftest set-exclusive-or.11 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'eql) + (c)) + +(deftest set-exclusive-or.12 + (set-exclusive-or-with-check '(a b c d e) '(d a b e) + :test 'equal) + (c)) + +;;; (deftest set-exclusive-or.13 +;;; (do-random-set-exclusive-ors 100 100) +;;; nil) + +(deftest set-exclusive-or.14 + (set-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) + '((a . 10) (c . 3)) + :key 'car) + ((b . 2))) + +(deftest set-exclusive-or.15 + (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) + '((a . 1) (c . 3313)) + :key #'car) + ((b . 2))) + +(deftest set-exclusive-or.16 + (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) + '((a . 1) (c . 3313)) + :key #'car + :test-not (complement #'eql)) + ((b . 2))) + +;; +;; Check that set-exclusive-or does not invert +;; the order of the arguments to the test function +;; +(deftest set-exclusive-or.17 + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (set-exclusive-or-with-check + list1 list2 + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed))))))) + t) + +(deftest set-exclusive-or.17-a + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (set-exclusive-or-with-check + list1 list2 + :key #'identity + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed))))))) + t) + +(deftest set-exclusive-or.18 + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (set-exclusive-or-with-check + list1 list2 + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t))))) + t) + +(deftest set-exclusive-or.18-a + (let ((list1 '(a b c d)) + (list2 '(e f g h))) + (block fail + (notnot-mv + (set-exclusive-or-with-check + list1 list2 + :key #'identity + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t))))) + t) + +;;; Order of argument evaluation tests + +(deftest set-exclusive-or.order.1 + (let ((i 0) x y) + (values + (sort + (set-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10))) + #'<) + i x y)) + (2 4 6 10) 2 1 2) + +(deftest set-exclusive-or.order.2 + (let ((i 0) x y z) + (values + (sort + (set-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :test (progn (setf z (incf i)) + #'eql)) + #'<) + i x y z)) + (2 4 6 10) 3 1 2 3) + +(deftest set-exclusive-or.order.3 + (let ((i 0) x y z w) + (values + (sort + (set-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :test (progn (setf z (incf i)) + #'eql) + :key (progn (setf w (incf i)) nil)) + #'<) + i x y z w)) + (2 4 6 10) 4 1 2 3 4) + +(deftest set-exclusive-or.order.4 + (let ((i 0) x y z w) + (values + (sort + (set-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :key (progn (setf z (incf i)) nil) + :test (progn (setf w (incf i)) + #'eql)) + #'<) + i x y z w)) + (2 4 6 10) 4 1 2 3 4) + +(deftest set-exclusive-or.order.5 + (let ((i 0) x y z w) + (values + (sort + (set-exclusive-or (progn (setf x (incf i)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :key (progn (setf z (incf i)) nil) + :key (progn (setf w (incf i)) + (complement #'eql))) + #'<) + i x y z w)) + (2 4 6 10) 4 1 2 3 4) + + +;;; Keyword tests + +(deftest set-exclusive.allow-other-keys.1 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :bad t :allow-other-keys t) + #'<) + (1 2 5 6)) + +(deftest set-exclusive.allow-other-keys.2 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t :bad t) + #'<) + (1 2 5 6)) + +(deftest set-exclusive.allow-other-keys.3 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t :bad t + :test #'(lambda (x y) (= x (1- y)))) + #'<) + (1 6)) + +(deftest set-exclusive.allow-other-keys.4 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t) + #'<) + (1 2 5 6)) + +(deftest set-exclusive.allow-other-keys.5 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys nil) + #'<) + (1 2 5 6)) + +(deftest set-exclusive.allow-other-keys.6 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t + :allow-other-keys nil) + #'<) + (1 2 5 6)) + +(deftest set-exclusive.allow-other-keys.7 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :allow-other-keys t + :allow-other-keys nil + '#:x 1) + #'<) + (1 2 5 6)) + +(deftest set-exclusive.keywords.8 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :test #'eql + :test #'/=) + #'<) + (1 2 5 6)) + +(deftest set-exclusive.keywords.9 + (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) + :test #'/= + :test #'eql) + #'<) + nil) + +(deftest set-exclusive-or.error.1 + (classify-error (set-exclusive-or)) + program-error) + +(deftest set-exclusive-or.error.2 + (classify-error (set-exclusive-or nil)) + program-error) + +(deftest set-exclusive-or.error.3 + (classify-error (set-exclusive-or nil nil :bad t)) + program-error) + +(deftest set-exclusive-or.error.4 + (classify-error (set-exclusive-or nil nil :key)) + program-error) + +(deftest set-exclusive-or.error.5 + (classify-error (set-exclusive-or nil nil 1 2)) + program-error) + +(deftest set-exclusive-or.error.6 + (classify-error (set-exclusive-or nil nil :bad t :allow-other-keys nil)) + program-error) + +(deftest set-exclusive-or.error.7 + (classify-error (set-exclusive-or (list 1 2) (list 3 4) :test #'identity)) + program-error) + +(deftest set-exclusive-or.error.8 + (classify-error (set-exclusive-or (list 1 2) (list 3 4) :test-not #'identity)) + program-error) + +(deftest set-exclusive-or.error.9 + (classify-error (set-exclusive-or (list 1 2) (list 3 4) :key #'cons)) + program-error) + +(deftest set-exclusive-or.error.10 + (classify-error (set-exclusive-or (list 1 2) (list 3 4) :key #'car)) + type-error) + +(deftest set-exclusive-or.error.11 + (classify-error (set-exclusive-or (list 1 2 3) (list* 4 5 6))) + type-error) + +(deftest set-exclusive-or.error.12 + (classify-error (set-exclusive-or (list* 1 2 3) (list 4 5 6))) + type-error) + + +;;; Randomized test + +(deftest random-set-exclusive-or + (random-set-exclusive-or-test 10 100) + nil) + diff --git a/ansi-tests/sublis.lsp b/ansi-tests/sublis.lsp new file mode 100644 index 0000000000000000000000000000000000000000..ccaf27dff2fdb891edafc29aed7ac9fea473795a --- /dev/null +++ b/ansi-tests/sublis.lsp @@ -0,0 +1,170 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:32:50 2003 +;;;; Contains: Tests of SUBLIS + +(in-package :cl-test) + +(deftest sublis.1 + (check-sublis '((a b) g (d e 10 g h) 15 . g) + '((e . e2) (g . 17))) + ((a b) 17 (d e2 10 17 h) 15 . 17)) + +(deftest sublis.2 + (check-sublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) + '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) + :test #'equal) + (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b)))) + +(deftest sublis.3 + (check-sublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) + '((30 . "foo"))) + (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) + +(deftest sublis.4 + (check-sublis (sublis + (copy-tree '((a . 2) (b . 4) (c . 1))) + (copy-tree '(a b c d e (a b c a d b) f))) + '((t . "yes")) + :key #'(lambda (x) (and (typep x 'integer) + (evenp x)))) + ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) + +(deftest sublis.5 + (check-sublis '("fee" (("fee" "Fie" "foo")) + fie ("fee" "fie")) + `((,(copy-seq "fie") . #\f))) + ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) + +(deftest sublis.6 + (check-sublis '("fee" fie (("fee" "Fie" "foo") 1) + ("fee" "fie")) + `((,(copy-seq "fie") . #\f)) + :test 'equal) + ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) + +(deftest sublis.7 + (check-sublis '(("aa" a b) + (z "bb" d) + ((x . "aa"))) + `((,(copy-seq "aa") . 1) + (,(copy-seq "bb") . 2)) + :test 'equal + :key #'(lambda (x) (if (consp x) (car x) + '*not-present*))) + (1 (z . 2) ((x . "aa")))) + +;; Check that a null key arg is ignored. + +(deftest sublis.8 + (check-sublis + '(1 2 a b) + '((1 . 2) (a . b)) + :key nil) + (2 2 b b)) + +;;; Order of argument evaluation +(deftest sublis.order.1 + (let ((i 0) w x y z) + (values + (sublis + (progn (setf w (incf i)) + '((a . z))) + (progn (setf x (incf i)) + (copy-tree '(a b c d))) + :test (progn (setf y (incf i)) #'eql) + :key (progn (setf z (incf i)) #'identity)) + i w x y z)) + (z b c d) + 4 1 2 3 4) + +(deftest sublis.order.2 + (let ((i 0) w x y z) + (values + (sublis + (progn (setf w (incf i)) + '((a . z))) + (progn (setf x (incf i)) + (copy-tree '(a b c d))) + :key (progn (setf y (incf i)) #'identity) + :test-not (progn (setf z (incf i)) (complement #'eql)) + ) + i w x y z)) + (z b c d) + 4 1 2 3 4) + + +;;; Keyword tests + +(deftest sublis.allow-other-keys.1 + (sublis nil 'a :bad t :allow-other-keys t) + a) + +(deftest sublis.allow-other-keys.2 + (sublis nil 'a :allow-other-keys t :bad t) + a) + +(deftest sublis.allow-other-keys.3 + (sublis nil 'a :allow-other-keys t) + a) + +(deftest sublis.allow-other-keys.4 + (sublis nil 'a :allow-other-keys nil) + a) + +(deftest sublis.allow-other-keys.5 + (sublis nil 'a :allow-other-keys t :allow-other-keys t :bad t) + a) + +(deftest sublis.keywords.6 + (sublis '((1 . a)) (list 0 1 2) :key #'(lambda (x) (if (numberp x) (1+ x) x)) + :key #'identity) + (a 1 2)) + + +;; Argument error cases + +(deftest sublis.error.1 + (classify-error (sublis)) + program-error) + +(deftest sublis.error.2 + (classify-error (sublis nil)) + program-error) + +(deftest sublis.error.3 + (classify-error (sublis nil 'a :test)) + program-error) + +(deftest sublis.error.4 + (classify-error (sublis nil 'a :bad-keyword t)) + program-error) + +(deftest sublis.error.5 + (classify-error (sublis '((a . 1) (b . 2)) + (list 'a 'b 'c 'd) + :test #'identity)) + program-error) + +(deftest sublis.error.6 + (classify-error (sublis '((a . 1) (b . 2)) + (list 'a 'b 'c 'd) + :key #'cons)) + program-error) + +(deftest sublis.error.7 + (classify-error (sublis '((a . 1) (b . 2)) + (list 'a 'b 'c 'd) + :test-not #'identity)) + program-error) + +(deftest sublis.error.8 + (classify-error (sublis '((a . 1) . bad) + (list 'a 'b 'c 'd))) + type-error) + +(deftest sublis.shared + (let* ((shared-piece (list 'a 'b)) + (a (list shared-piece shared-piece))) + (check-sublis a '((a . b) (b . a)))) + ((b a) (b a))) diff --git a/ansi-tests/cons-test-24.lsp b/ansi-tests/subsetp.lsp similarity index 97% rename from ansi-tests/cons-test-24.lsp rename to ansi-tests/subsetp.lsp index 8d0ed9c62f93302a94c72ae068ac10a0413a0ab6..450490ea7cf6de997bf43a9467d140e52f8fcaee 100644 --- a/ansi-tests/cons-test-24.lsp +++ b/ansi-tests/subsetp.lsp @@ -1,15 +1,10 @@ ;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Wed Apr 1 22:10:54 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 24 +;;;; Contains: Tests of SUBSETP (in-package :cl-test) -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; subsetp - (defvar cons-test-24-var '(78 "z" (8 9))) (deftest subsetp.1 diff --git a/ansi-tests/subst-if-not.lsp b/ansi-tests/subst-if-not.lsp new file mode 100644 index 0000000000000000000000000000000000000000..8b0df98d79fe56139700666a9f79ef24d950bc83 --- /dev/null +++ b/ansi-tests/subst-if-not.lsp @@ -0,0 +1,115 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:48:22 2003 +;;;; Contains: Tests of SUBST-IF-NOT + +(in-package :cl-test) + +(deftest subst-if-not.1 + (check-subst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) + ((x) + ((x) (x) x) + ((x) (x) (x) x) + ((x) (x) (x) (x) x) + x)) + +(deftest subst-if-not.2 + (check-subst-if-not 'a (complement #'listp) + '((100 1) (2 3) (4 3 2 1) (a b c))) + a) + +(deftest subst-if-not.3 + (check-subst-if-not 'c #'identity + '((100 1) (2 3) (4 3 2 1) (a b c)) + :key (complement #'listp)) + c) + +(deftest subst-if-not.4 + (check-subst-if-not + 40 + #'(lambda (x) (not (eql x 17))) + '((17) (17 22) (17 22 31) (17 21 34 54)) + :key #'(lambda (x) + (and (consp x) + (car x)))) + (40 40 40 40)) + +(deftest subst-if-not.5 + (check-subst-if-not 'a #'(lambda (x) (not (eql x 'b))) + '((a) (b) (c) (d)) + :key nil) + ((a) (a) (c) (d))) + +(deftest subst-if-not.7 + (let ((i 0) w x y z) + (values + (subst-if-not + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) #'(lambda (x) (not (eql x 'b)))) + (progn (setf y (incf i)) (copy-list '(1 2 a b c))) + :key (progn (setf z (incf i)) #'identity)) + i w x y z)) + (1 2 a a c) + 4 1 2 3 4) + +;;; Keywords tests for subst-if-not + +(deftest subst-if-not.allow-other-keys.1 + (subst-if-not 'a #'identity nil :bad t :allow-other-keys t) + a) + +(deftest subst-if-not.allow-other-keys.2 + (subst-if-not 'a #'identity nil :allow-other-keys t) + a) + +(deftest subst-if-not.allow-other-keys.3 + (subst-if-not 'a #'identity nil :allow-other-keys nil) + a) + +(deftest subst-if-not.allow-other-keys.4 + (subst-if-not 'a #'identity nil :allow-other-keys t :bad t) + a) + +(deftest subst-if-not.allow-other-keys.5 + (subst-if-not 'a #'identity nil :allow-other-keys t + :allow-other-keys nil :bad t) + a) + +(deftest subst-if-not.keywords.6 + (subst-if-not 'a #'identity nil :key nil :key (constantly 'b)) + a) + +;;; error cases + +(deftest subst-if-not.error.1 + (classify-error (subst-if-not)) + program-error) + +(deftest subst-if-not.error.2 + (classify-error (subst-if-not 'a)) + program-error) + +(deftest subst-if-not.error.3 + (classify-error (subst-if-not 'a #'null)) + program-error) + +(deftest subst-if-not.error.4 + (classify-error (subst-if-not 'a #'null nil :foo nil)) + program-error) + +(deftest subst-if-not.error.5 + (classify-error (subst-if-not 'a #'null nil :test)) + program-error) + +(deftest subst-if-not.error.6 + (classify-error (subst-if-not 'a #'null nil 1)) + program-error) + +(deftest subst-if-not.error.7 + (classify-error (subst-if-not 'a #'null nil + :bad t :allow-other-keys nil)) + program-error) + +(deftest subst-if-not.error.8 + (classify-error (subst-if-not 'a #'null (list 'a nil 'c) :key #'cons)) + program-error) diff --git a/ansi-tests/subst-if.lsp b/ansi-tests/subst-if.lsp new file mode 100644 index 0000000000000000000000000000000000000000..63bcf19ab12cfb8735a355d26e39c58166e33deb --- /dev/null +++ b/ansi-tests/subst-if.lsp @@ -0,0 +1,115 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:39:42 2003 +;;;; Contains: Tests of SUBST-IF + +(in-package :cl-test) + +(deftest subst-if.1 + (check-subst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) + a) + +(deftest subst-if.2 + (check-subst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) + (17 (17 17) (17 17 17) (17 nil 17 17 17))) + +(deftest subst-if.3 + (check-subst-if '(z) + (complement #'consp) + '(a (a b) (c d e) (f g h i))) + ((z) + ((z) (z) z) + ((z) (z) (z) z) + ((z) (z) (z) (z) z) + z)) + +(deftest subst-if.4 + (check-subst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) + :key #'listp) + b) + +(deftest subst-if.5 + (check-subst-if 4 #'(lambda (x) (eql x 1)) + '((1 3) (1) (1 10 20 30) (1 3 x y)) + :key #'(lambda (x) + (and (consp x) + (car x)))) + (4 4 4 4)) + +(deftest subst-if.6 + (check-subst-if 'a #'(lambda (x) (eql x 'b)) + '((a) (b) (c) (d)) + :key nil) + ((a) (a) (c) (d))) + +(deftest subst-if.7 + (let ((i 0) w x y z) + (values + (subst-if + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) #'(lambda (x) (eql x 'b))) + (progn (setf y (incf i)) (copy-list '(1 2 a b c))) + :key (progn (setf z (incf i)) #'identity)) + i w x y z)) + (1 2 a a c) + 4 1 2 3 4) + +;;; Keyword tests for subst-if + +(deftest subst-if.allow-other-keys.1 + (subst-if 'a #'null nil :bad t :allow-other-keys t) + a) + +(deftest subst-if.allow-other-keys.2 + (subst-if 'a #'null nil :allow-other-keys t) + a) + +(deftest subst-if.allow-other-keys.3 + (subst-if 'a #'null nil :allow-other-keys nil) + a) + +(deftest subst-if.allow-other-keys.4 + (subst-if 'a #'null nil :allow-other-keys t :bad t) + a) + +(deftest subst-if.allow-other-keys.5 + (subst-if 'a #'null nil :allow-other-keys t :allow-other-keys nil :bad t) + a) + +(deftest subst-if.keywords.6 + (subst-if 'a #'null nil :key nil :key (constantly 'b)) + a) + +;;; Error tests + +(deftest subst-if.error.1 + (classify-error (subst-if)) + program-error) + +(deftest subst-if.error.2 + (classify-error (subst-if 'a)) + program-error) + +(deftest subst-if.error.3 + (classify-error (subst-if 'a #'null)) + program-error) + +(deftest subst-if.error.4 + (classify-error (subst-if 'a #'null nil :foo nil)) + program-error) + +(deftest subst-if.error.5 + (classify-error (subst-if 'a #'null nil :test)) + program-error) + +(deftest subst-if.error.6 + (classify-error (subst-if 'a #'null nil 1)) + program-error) + +(deftest subst-if.error.7 + (classify-error (subst-if 'a #'null nil :bad t :allow-other-keys nil)) + program-error) + +(deftest subst-if.error.8 + (classify-error (subst-if 'a #'null (list 'a nil 'c) :key #'cons)) + program-error) \ No newline at end of file diff --git a/ansi-tests/subst.lsp b/ansi-tests/subst.lsp new file mode 100644 index 0000000000000000000000000000000000000000..dcdaba805f688a1602f2a6c5edb6c8afbdfe38a6 --- /dev/null +++ b/ansi-tests/subst.lsp @@ -0,0 +1,157 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 21:37:56 2003 +;;;; Contains: Tests of SUBST + +(in-package :cl-test) + +(defvar *subst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) + +(deftest subst.1 + (check-subst "Z" 30 (copy-tree *subst-tree-1*)) + (10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) + +(deftest subst.2 + (check-subst "A" 0 (copy-tree *subst-tree-1*)) + (10 (30 20 10) (20 10) (10 20 30 40))) + +(deftest subst.3 + (check-subst "Z" 100 (copy-tree *subst-tree-1*) :test-not #'eql) + "Z") + +(deftest subst.4 + (check-subst 'grape 'dick + '(melville wrote (moby dick))) + (melville wrote (moby grape))) + +(deftest subst.5 + (check-subst 'cha-cha-cha 'nil '(melville wrote (moby dick))) + (melville wrote (moby dick . cha-cha-cha) . cha-cha-cha)) + +(deftest subst.6 + (check-subst + '(1 2) '(foo . bar) + '((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) + :test #'equal) + ((foo . baz) (1 2) (bar . foo) (baz 1 2))) + +(deftest subst.7 + (check-subst + 'foo "aaa" + '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) + :key #'(lambda (x) (if (and (numberp x) (evenp x)) + "aaa" + nil)) + :test #'string=) + ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) + +(deftest subst.8 + (check-subst + 'foo nil + '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) + :key #'(lambda (x) (if (and (numberp x) (evenp x)) + (copy-seq "aaa") + nil)) + :test-not #'equal) + ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) + +(deftest subst.9 + (check-subst 'a 'b + (copy-tree '(a b c d a b)) + :key nil) + (a a c d a a)) + +;;; Order of argument evaluation +(deftest subst.order.1 + (let ((i 0) v w x y z) + (values + (subst (progn (setf v (incf i)) 'b) + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) + :key (progn (setf y (incf i)) #'identity) + :test (progn (setf z (incf i)) #'eql)) + i v w x y z)) + ((10 b . b) b b c ((b)) z) + 5 1 2 3 4 5) + +(deftest subst.order.2 + (let ((i 0) v w x y z) + (values + (subst (progn (setf v (incf i)) 'b) + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) + :test-not (progn (setf y (incf i)) (complement #'eql)) + :key (progn (setf z (incf i)) #'identity) + ) + i v w x y z)) + ((10 b . b) b b c ((b)) z) + 5 1 2 3 4 5) + + + +;;; Keyword tests for subst + +(deftest subst.allow-other-keys.1 + (subst 'a 'b (list 'a 'b 'c) :bad t :allow-other-keys t) + (a a c)) + +(deftest subst.allow-other-keys.2 + (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t) + (a a c)) + +(deftest subst.allow-other-keys.3 + (subst 'a 'b (list 'a 'b 'c) :allow-other-keys nil) + (a a c)) + +(deftest subst.allow-other-keys.4 + (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t :bad t) + (a a c)) + +(deftest subst.allow-other-keys.5 + (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t :allow-other-keys nil + :bad t) + (a a c)) + +(deftest subst.keywords.6 + (subst 'a 'b (list 'a 'b 'c) :test #'eq :test (complement #'eq)) + (a a c)) + +(deftest subst.error.1 + (classify-error (subst)) + program-error) + +(deftest subst.error.2 + (classify-error (subst 'a)) + program-error) + +(deftest subst.error.3 + (classify-error (subst 'a 'b)) + program-error) + +(deftest subst.error.4 + (classify-error (subst 'a 'b nil :foo nil)) + program-error) + +(deftest subst.error.5 + (classify-error (subst 'a 'b nil :test)) + program-error) + +(deftest subst.error.6 + (classify-error (subst 'a 'b nil 1)) + program-error) + +(deftest subst.error.7 + (classify-error (subst 'a 'b nil :bad t :allow-other-keys nil)) + program-error) + +(deftest subst.error.8 + (classify-error (subst 'a 'b (list 'a 'b) :test #'identity)) + program-error) + +(deftest subst.error.9 + (classify-error (subst 'a 'b (list 'a 'b) :test-not #'identity)) + program-error) + +(deftest subst.error.10 + (classify-error (subst 'a 'b (list 'a 'b) :key #'equal)) + program-error) diff --git a/ansi-tests/tailp.lsp b/ansi-tests/tailp.lsp new file mode 100644 index 0000000000000000000000000000000000000000..8a44ae8b0ec44120f7713f5951bde332a7a269df --- /dev/null +++ b/ansi-tests/tailp.lsp @@ -0,0 +1,95 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Apr 19 22:47:26 2003 +;;;; Contains: Tests of TAILP + +(in-package :cl-test) + +(deftest tailp.1 + (let ((x (copy-tree '(a b c d e . f)))) + (and + (tailp x x) + (tailp (cdr x) x) + (tailp (cddr x) x) + (tailp (cdddr x) x) + (tailp (cddddr x) x) + t)) + t) + +;; The next four tests test that tailp handles dotted lists. See +;; TAILP-NIL:T in the X3J13 documentation. + +(deftest tailp.2 + (notnot-mv (tailp 'e (copy-tree '(a b c d . e)))) + t) + +(deftest tailp.3 + (tailp 'z (copy-tree '(a b c d . e))) + nil) + +(deftest tailp.4 + (notnot-mv (tailp 10203040506070 + (list* 'a 'b (1- 10203040506071)))) + t) + +(deftest tailp.5 + (let ((x "abcde")) (tailp x (list* 'a 'b (copy-seq x)))) + nil) + +(deftest tailp.error.5 + (classify-error (tailp)) + program-error) + +(deftest tailp.error.6 + (classify-error (tailp nil)) + program-error) + +(deftest tailp.error.7 + (classify-error (tailp nil nil nil)) + program-error) + +;; Test that tailp does not modify its arguments + +(deftest tailp.6 + (let* ((x (copy-list '(a b c d e))) + (y (cddr x))) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (and + (tailp y x) + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)))) + t) + +;; Note! The spec is ambiguous on whether this next test +;; is correct. The spec says that tailp should be prepared +;; to signal an error if the list argument is not a proper +;; list or dotted list. If listp is false, the list argument +;; is neither (atoms are not dotted lists). +;; +;; However, the sample implementation *does* work even if +;; the list argument is an atom. +;; + +#| +(defun tailp.7-body () + (loop + for x in *universe* + count (and (not (listp x)) + (eqt 'type-error + (catch-type-error (tailp x x)))))) + +(deftest tailp.7 + (tailp.7-body) + 0) +|# + +(deftest tailp.order.1 + (let ((i 0) x y) + (values + (notnot + (tailp (progn (setf x (incf i)) 'd) + (progn (setf y (incf i)) '(a b c . d)))) + i x y)) + t 2 1 2) + diff --git a/ansi-tests/cons-test-20.lsp b/ansi-tests/union.lsp similarity index 97% rename from ansi-tests/cons-test-20.lsp rename to ansi-tests/union.lsp index aac1033dff78ca2ce1125e11c45a6b32f1a3cb3d..4e84766c117b69d1c357b6cee166f42972cee505 100644 --- a/ansi-tests/cons-test-20.lsp +++ b/ansi-tests/union.lsp @@ -1,15 +1,10 @@ ;-*- Mode: Lisp -*- ;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 22:11:27 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 20 +;;;; Created: Sun Apr 20 07:41:24 2003 +;;;; Contains: Tests of UNION (in-package :cl-test) -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; union - (deftest union.1 (union nil nil) nil) @@ -408,8 +403,3 @@ (deftest union.error.12 (classify-error (union (list* 1 2 3) (list 4 5 6))) type-error) - - - - -