diff --git a/ansi-tests/acons.lsp b/ansi-tests/acons.lsp index cc193d4c8f0a43466fdee44a7828f7bfb2c6fc6a..d4a6ca3b61c5445e74fc50f1e1fcb275b5d2a411 100644 --- a/ansi-tests/acons.lsp +++ b/ansi-tests/acons.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest acons.1 (let* ((x (copy-tree '((c . d) (e . f)))) (xcopy (make-scaffold-copy x)) diff --git a/ansi-tests/adjoin.lsp b/ansi-tests/adjoin.lsp index 669881f4fa2391994e38ebd70624b8dfd42e416d..c0848757bdb88129416d8cf431bd749751edf525 100644 --- a/ansi-tests/adjoin.lsp +++ b/ansi-tests/adjoin.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest adjoin.1 (adjoin 'a nil) (a)) diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 1e4d0b217854796849453430b2aa9bb31b59f4d0..20ec6bc75c1cc233075fd1dc33548983e6724b2a 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -363,54 +363,6 @@ the condition to go uncaught if it cannot be classified." (handler-case (and (stringp (write-to-string obj)) t) (condition (c) (declare (ignore c)) nil))))) -;;; -;;; A scaffold is a structure that is used to remember the object -;;; identities of the cons cells in a (noncircular) data structure. -;;; This lets us check if the data structure has been changed by -;;; an operation. -;;; - -(defstruct scaffold - node - car - cdr) - -(defun make-scaffold-copy (x) - "Make a tree that will be used to check if a tree has been changed." - (if - (consp x) - (make-scaffold :node x - :car (make-scaffold-copy (car x)) - :cdr (make-scaffold-copy (cdr x))) - (make-scaffold :node x - :car nil - :cdr nil))) - -(defun check-scaffold-copy (x xcopy) - "Return t if xcopy were produced from x by make-scaffold-copy, - and none of the cons cells in the tree rooted at x have been - changed." - - (and (eq x (scaffold-node xcopy)) - (or - (not (consp x)) - (and - (check-scaffold-copy (car x) (scaffold-car xcopy)) - (check-scaffold-copy (cdr x) (scaffold-cdr xcopy)))))) - -(defun create-c*r-test (n) - (cond - ((<= n 0) 'none) - (t - (cons (create-c*r-test (1- n)) - (create-c*r-test (1- n)))))) - -(defun nth-1-body (x) - (loop - for e in x - and i from 0 - count (not (eqt e (nth i x))))) - ;;; ;;; The function SUBTYPEP should return two generalized booleans. ;;; This auxiliary function returns booleans instead @@ -862,472 +814,6 @@ the condition to go uncaught if it cannot be classified." (defun even-size-p (a) (some #'evenp (array-dimensions a))) -(defun check-cons-copy (x y) - "Check that the tree x is a copy of the tree y, - returning t if it is, nil if not." - (cond - ((consp x) - (and (consp y) - (not (eqt x y)) - (check-cons-copy (car x) (car y)) - (check-cons-copy (cdr x) (cdr y)))) - ((eqt x y) t) - (t nil))) - -(defun check-sublis (a al &key (key 'no-key) test test-not) - "Apply sublis al a with various keys. Check that - the arguments are not themselves changed. Return nil - if the arguments do get changed." - (setf a (copy-tree a)) - (setf al (copy-tree al)) - (let ((acopy (make-scaffold-copy a)) - (alcopy (make-scaffold-copy al))) - (let ((as - (apply #'sublis al a - `(,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)) - ,@(unless (eqt key 'no-key) `(:key ,key)))))) - (and - (check-scaffold-copy a acopy) - (check-scaffold-copy al alcopy) - as)))) - -(defun check-nsublis (a al &key (key 'no-key) test test-not) - "Apply nsublis al a, copying these arguments first." - (setf a (copy-tree a)) - (setf al (copy-tree al)) - (let ((as - (apply #'sublis (copy-tree al) (copy-tree a) - `(,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)) - ,@(unless (eqt key 'no-key) `(:key ,key)))))) - as)) - -(defun check-subst (new old tree &key (key 'no-key) test test-not) - "Call subst new old tree, with keyword arguments if present. - Check that the arguments are not changed." - (setf new (copy-tree new)) - (setf old (copy-tree old)) - (setf tree (copy-tree tree)) - (let ((newcopy (make-scaffold-copy new)) - (oldcopy (make-scaffold-copy old)) - (treecopy (make-scaffold-copy tree))) - (let ((result - (apply #'subst new old tree - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)))))) - (and (check-scaffold-copy new newcopy) - (check-scaffold-copy old oldcopy) - (check-scaffold-copy tree treecopy) - result)))) - - -(defun check-subst-if (new pred tree &key (key 'no-key)) - "Call subst-if new pred tree, with various keyword arguments - if present. Check that the arguments are not changed." - (setf new (copy-tree new)) - (setf tree (copy-tree tree)) - (let ((newcopy (make-scaffold-copy new)) - (predcopy (make-scaffold-copy pred)) - (treecopy (make-scaffold-copy tree))) - (let ((result - (apply #'subst-if new pred tree - (unless (eqt key 'no-key) `(:key ,key))))) - (and (check-scaffold-copy new newcopy) - (check-scaffold-copy pred predcopy) - (check-scaffold-copy tree treecopy) - result)))) - -(defun check-subst-if-not (new pred tree &key (key 'no-key)) - "Call subst-if-not new pred tree, with various keyword arguments - if present. Check that the arguments are not changed." - (setf new (copy-tree new)) - (setf tree (copy-tree tree)) - (let ((newcopy (make-scaffold-copy new)) - (predcopy (make-scaffold-copy pred)) - (treecopy (make-scaffold-copy tree))) - (let ((result - (apply #'subst-if-not new pred tree - (unless (eqt key 'no-key) `(:key ,key))))) - (and (check-scaffold-copy new newcopy) - (check-scaffold-copy pred predcopy) - (check-scaffold-copy tree treecopy) - result)))) - -(defun check-nsubst (new old tree &key (key 'no-key) test test-not) - "Call nsubst new old tree, with keyword arguments if present." - (setf new (copy-tree new)) - (setf old (copy-tree old)) - (setf tree (copy-tree tree)) - (apply #'nsubst new old tree - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not))))) - -(defun check-nsubst-if (new pred tree &key (key 'no-key)) - "Call nsubst-if new pred tree, with keyword arguments if present." - (setf new (copy-tree new)) - (setf tree (copy-tree tree)) - (apply #'nsubst-if new pred tree - (unless (eqt key 'no-key) `(:key ,key)))) - -(defun check-nsubst-if-not (new pred tree &key (key 'no-key)) - "Call nsubst-if-not new pred tree, with keyword arguments if present." - (setf new (copy-tree new)) - (setf tree (copy-tree tree)) - (apply #'nsubst-if-not new pred tree - (unless (eqt key 'no-key) `(:key ,key)))) - -(defun check-copy-list-copy (x y) - "Check that y is a copy of the list x." - (if - (consp x) - (and (consp y) - (not (eqt x y)) - (eqt (car x) (car y)) - (check-copy-list-copy (cdr x) (cdr y))) - (and (eqt x y) t))) - -(defun check-copy-list (x) - "Apply copy-list, checking that it properly copies, - and checking that it does not change its argument." - (let ((xcopy (make-scaffold-copy x))) - (let ((y (copy-list x))) - (and - (check-scaffold-copy x xcopy) - (check-copy-list-copy x y) - y)))) - -(defun append-6-body () - (let* ((cal (min 2048 call-arguments-limit)) - (step (max 1 (floor (/ cal) 64)))) - (loop - for n from 0 - below cal - by step - count - (not - (equal - (apply #'append (loop for i from 1 to n - collect '(a))) - (make-list n :initial-element 'a)))))) - -(defun is-intersection (x y z) - "Check that z is the intersection of x and y." - (and - (listp x) - (listp y) - (listp z) - (loop for e in x - always (or (not (member e y)) - (member e z))) - (loop for e in y - always (or (not (member e x)) - (member e z))) - (loop for e in z - always (and (member e x) (member e y))) - t)) - -(defun shuffle (x) - (cond - ((null x) nil) - ((null (cdr x)) x) - (t - (multiple-value-bind - (y z) - (split-list x) - (append (shuffle y) (shuffle z)))))) - -(defun split-list (x) - (cond - ((null x) (values nil nil)) - ((null (cdr x)) (values x nil)) - (t - (multiple-value-bind - (y z) - (split-list (cddr x)) - (values (cons (car x) y) (cons (cadr x) z)))))) - -(defun intersection-12-body (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size - collect (random maxelem state)))) - (y (shuffle (loop for j from 1 to size - collect (random maxelem state))))) - (let ((z (intersection x y))) - (let ((is-good (is-intersection x y z))) - (unless is-good (return (values x y z))))))) - nil)) - -(defun nintersection-with-check (x y &key test) - (let ((ycopy (make-scaffold-copy y))) - (let ((result (if test - (nintersection x y :test test) - (nintersection x y)))) - (if (check-scaffold-copy y ycopy) - result - 'failed)))) - -(defun nintersection-12-body (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state t))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size - collect (random maxelem state)))) - (y (shuffle (loop for j from 1 to size - collect (random maxelem state))))) - (let ((z (nintersection-with-check (copy-list x) y))) - (when (eqt z 'failed) (return (values x y z))) - (let ((is-good (is-intersection x y z))) - (unless is-good (return (values x y z))))))) - nil)) - - -(defun union-with-check (x y &key test test-not) - (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (let ((result (cond - (test (union x y :test test)) - (test-not (union x y :test-not test-not)) - (t (union x y))))) - (if (and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - result - 'failed)))) - -(defun union-with-check-and-key (x y key &key test test-not) - (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (let ((result (cond - (test (union x y :key key :test test)) - (test-not (union x y :key key :test-not test-not)) - (t (union x y :key key))))) - (if (and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - result - 'failed)))) - -(defun check-union (x y z) - (and (listp x) - (listp y) - (listp z) - (loop for e in z always (or (member e x) (member e y))) - (loop for e in x always (member e z)) - (loop for e in y always (member e z)) - t)) - -(defun do-random-unions (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) - (let ((z (union x y))) - (let ((is-good (check-union x y z))) - (unless is-good (return (values x y z))))))) - nil)) - -(defun nunion-with-copy (x y &key test test-not) - (setf x (copy-list x)) - (setf y (copy-list y)) - (cond - (test (nunion x y :test test)) - (test-not (nunion x y :test-not test-not)) - (t (nunion x y)))) - -(defun nunion-with-copy-and-key (x y key &key test test-not) - (setf x (copy-list x)) - (setf y (copy-list y)) - (cond - (test (nunion x y :key key :test test)) - (test-not (nunion x y :key key :test-not test-not)) - (t (nunion x y :key key)))) - -(defun do-random-nunions (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) - (let ((z (nunion-with-copy x y))) - (let ((is-good (check-union x y z))) - (unless is-good (return (values x y z))))))) - nil)) - -(defun set-difference-with-check (x y &key (key 'no-key) - test test-not) - (setf x (copy-list x)) - (setf y (copy-list y)) - (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (let ((result (apply #'set-difference - x y - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)))))) - (cond - ((and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - result) - (t - 'failed))))) - -(defun check-set-difference (x y z &key (key #'identity) - (test #'eql)) - (and - ;; (not (eqt 'failed z)) - (listp x) - (listp y) - (listp z) - (loop for e in z always (member e x :key key :test test)) - (loop for e in x always (or (member e y :key key :test test) - (member e z :key key :test test))) - (loop for e in y never (member e z :key key :test test)) - t)) - -(defun do-random-set-differences (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) - (let ((z (set-difference-with-check x y))) - (let ((is-good (check-set-difference x y z))) - (unless is-good (return (values x y z))))))) - nil)) -(defun nset-difference-with-check (x y &key (key 'no-key) - test test-not) - (setf x (copy-list x)) - (setf y (copy-list y)) - (apply #'nset-difference - x y - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not))))) - -(defun check-nset-difference (x y z &key (key #'identity) - (test #'eql)) - (and - (listp x) - (listp y) - (listp z) - (loop for e in z always (member e x :key key :test test)) - (loop for e in x always (or (member e y :key key :test test) - (member e z :key key :test test))) - (loop for e in y never (member e z :key key :test test)) - t)) - -(defun do-random-nset-differences (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) - (let ((z (nset-difference-with-check x y))) - (let ((is-good (check-nset-difference x y z))) - (unless is-good (return (values x y z))))))) - nil)) - -(defun set-exclusive-or-with-check (x y &key (key 'no-key) - test test-not) - (setf x (copy-list x)) - (setf y (copy-list y)) - (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (let ((result (apply #'set-exclusive-or - x y - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)))))) - (cond - ((and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - result) - (t - 'failed))))) - -(defun check-set-exclusive-or (x y z &key (key #'identity) - (test #'eql)) - (and - ;; (not (eqt 'failed z)) - (listp x) - (listp y) - (listp z) - (loop for e in z always (or (member e x :key key :test test) - (member e y :key key :test test))) - (loop for e in x always (if (member e y :key key :test test) - (not (member e z :key key :test test)) - (member e z :key key :test test))) - (loop for e in y always (if (member e x :key key :test test) - (not (member e z :key key :test test)) - (member e z :key key :test test))) - t)) - -#| -(defun do-random-set-exclusive-ors (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) - (let ((z (set-exclusive-or-with-check x y))) - (let ((is-good (check-set-exclusive-or x y z))) - (unless is-good (return (values x y z))))))) - nil)) -|# - -(defun nset-exclusive-or-with-check (x y &key (key 'no-key) - test test-not) - (setf x (copy-list x)) - (setf y (copy-list y)) - (apply #'nset-exclusive-or - x y - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not))))) - -#| -(defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) - (let ((z (nset-exclusive-or-with-check x y))) - (let ((is-good (check-set-exclusive-or x y z))) - (unless is-good (return (values x y z))))))) - nil)) -|# - -(defun subsetp-with-check (x y &key (key 'no-key) test test-not) - (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (let ((result - (apply #'subsetp x y - `(,@(unless (eqt key 'no-key) - `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)))))) - (cond - ((and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - (not (not result))) - (t 'failed))))) (defun safe-elt (x n) (classify-error* (elt x n))) diff --git a/ansi-tests/append.lsp b/ansi-tests/append.lsp index f37f72a07865bd7e4b678a8696d2f5e3d6204954..702a7b16a8ce9945f9df6b9f163115a76e3cbb2e 100644 --- a/ansi-tests/append.lsp +++ b/ansi-tests/append.lsp @@ -5,6 +5,7 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") (deftest append.1 (append) diff --git a/ansi-tests/assoc-if-not.lsp b/ansi-tests/assoc-if-not.lsp index 239a35d218d1d0239a5d9a24ea36a0440d4db9e9..4ae14aa9d5f4e91ff70b1a9adb674c477623b4da 100644 --- a/ansi-tests/assoc-if-not.lsp +++ b/ansi-tests/assoc-if-not.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest assoc-if-not.1 (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) diff --git a/ansi-tests/assoc-if.lsp b/ansi-tests/assoc-if.lsp index 347f1c25441079caf8b86214ba885f5b8de4551b..6348f604099147ac553f7b45b4faaa3dc4cc16fc 100644 --- a/ansi-tests/assoc-if.lsp +++ b/ansi-tests/assoc-if.lsp @@ -5,6 +5,7 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") (deftest assoc-if.1 (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) diff --git a/ansi-tests/assoc.lsp b/ansi-tests/assoc.lsp index 37f32609294d921b537ba4dd75c58494c4f2ad0f..8915ccf77c0a149114c239ff8aa7355de2afb313 100644 --- a/ansi-tests/assoc.lsp +++ b/ansi-tests/assoc.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest assoc.1 (assoc nil nil) nil) diff --git a/ansi-tests/atom.lsp b/ansi-tests/atom.lsp index 9b4af9e1869ec1b83ed90551c5f82cbd5894dfb8..b9905c6bbed9c7d914992bec1cc3c10542157220 100644 --- a/ansi-tests/atom.lsp +++ b/ansi-tests/atom.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +; (compile-and-load "cons-aux.lsp") + (deftest atom.order.1 (let ((i 0)) (values (atom (progn (incf i) '(a b))) i)) diff --git a/ansi-tests/butlast.lsp b/ansi-tests/butlast.lsp index 5a531e11912247d1110735e73f3864081821b0b0..46ac2d4ee953347030f3a9fcb3b4199544960e12 100644 --- a/ansi-tests/butlast.lsp +++ b/ansi-tests/butlast.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest butlast.1 (let ((x (list 'a 'b 'c 'd 'e))) (let ((xcopy (make-scaffold-copy x))) diff --git a/ansi-tests/cons-aux.lsp b/ansi-tests/cons-aux.lsp index d6fbf4a9436a25ea1856d9579021d7040a33209c..e5f2e1372c903105a194024a9a522831a15d4bed 100644 --- a/ansi-tests/cons-aux.lsp +++ b/ansi-tests/cons-aux.lsp @@ -5,6 +5,521 @@ (in-package :cl-test) +;;; +;;; A scaffold is a structure that is used to remember the object +;;; identities of the cons cells in a (noncircular) data structure. +;;; This lets us check if the data structure has been changed by +;;; an operation. +;;; + +(defstruct scaffold + node + car + cdr) + +(defun make-scaffold-copy (x) + "Make a tree that will be used to check if a tree has been changed." + (if + (consp x) + (make-scaffold :node x + :car (make-scaffold-copy (car x)) + :cdr (make-scaffold-copy (cdr x))) + (make-scaffold :node x + :car nil + :cdr nil))) + +(defun check-scaffold-copy (x xcopy) + "Return t if xcopy were produced from x by make-scaffold-copy, + and none of the cons cells in the tree rooted at x have been + changed." + + (and (eq x (scaffold-node xcopy)) + (or + (not (consp x)) + (and + (check-scaffold-copy (car x) (scaffold-car xcopy)) + (check-scaffold-copy (cdr x) (scaffold-cdr xcopy)))))) + +(defun create-c*r-test (n) + (cond + ((<= n 0) 'none) + (t + (cons (create-c*r-test (1- n)) + (create-c*r-test (1- n)))))) + +(defun nth-1-body (x) + (loop + for e in x + and i from 0 + count (not (eqt e (nth i x))))) + +(defun check-cons-copy (x y) + "Check that the tree x is a copy of the tree y, + returning t if it is, nil if not." + (cond + ((consp x) + (and (consp y) + (not (eqt x y)) + (check-cons-copy (car x) (car y)) + (check-cons-copy (cdr x) (cdr y)))) + ((eqt x y) t) + (t nil))) + +(defun check-sublis (a al &key (key 'no-key) test test-not) + "Apply sublis al a with various keys. Check that + the arguments are not themselves changed. Return nil + if the arguments do get changed." + (setf a (copy-tree a)) + (setf al (copy-tree al)) + (let ((acopy (make-scaffold-copy a)) + (alcopy (make-scaffold-copy al))) + (let ((as + (apply #'sublis al a + `(,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)) + ,@(unless (eqt key 'no-key) `(:key ,key)))))) + (and + (check-scaffold-copy a acopy) + (check-scaffold-copy al alcopy) + as)))) + +(defun check-nsublis (a al &key (key 'no-key) test test-not) + "Apply nsublis al a, copying these arguments first." + (setf a (copy-tree a)) + (setf al (copy-tree al)) + (let ((as + (apply #'sublis (copy-tree al) (copy-tree a) + `(,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)) + ,@(unless (eqt key 'no-key) `(:key ,key)))))) + as)) + +(defun check-subst (new old tree &key (key 'no-key) test test-not) + "Call subst new old tree, with keyword arguments if present. + Check that the arguments are not changed." + (setf new (copy-tree new)) + (setf old (copy-tree old)) + (setf tree (copy-tree tree)) + (let ((newcopy (make-scaffold-copy new)) + (oldcopy (make-scaffold-copy old)) + (treecopy (make-scaffold-copy tree))) + (let ((result + (apply #'subst new old tree + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) + (and (check-scaffold-copy new newcopy) + (check-scaffold-copy old oldcopy) + (check-scaffold-copy tree treecopy) + result)))) + + +(defun check-subst-if (new pred tree &key (key 'no-key)) + "Call subst-if new pred tree, with various keyword arguments + if present. Check that the arguments are not changed." + (setf new (copy-tree new)) + (setf tree (copy-tree tree)) + (let ((newcopy (make-scaffold-copy new)) + (predcopy (make-scaffold-copy pred)) + (treecopy (make-scaffold-copy tree))) + (let ((result + (apply #'subst-if new pred tree + (unless (eqt key 'no-key) `(:key ,key))))) + (and (check-scaffold-copy new newcopy) + (check-scaffold-copy pred predcopy) + (check-scaffold-copy tree treecopy) + result)))) + +(defun check-subst-if-not (new pred tree &key (key 'no-key)) + "Call subst-if-not new pred tree, with various keyword arguments + if present. Check that the arguments are not changed." + (setf new (copy-tree new)) + (setf tree (copy-tree tree)) + (let ((newcopy (make-scaffold-copy new)) + (predcopy (make-scaffold-copy pred)) + (treecopy (make-scaffold-copy tree))) + (let ((result + (apply #'subst-if-not new pred tree + (unless (eqt key 'no-key) `(:key ,key))))) + (and (check-scaffold-copy new newcopy) + (check-scaffold-copy pred predcopy) + (check-scaffold-copy tree treecopy) + result)))) + +(defun check-nsubst (new old tree &key (key 'no-key) test test-not) + "Call nsubst new old tree, with keyword arguments if present." + (setf new (copy-tree new)) + (setf old (copy-tree old)) + (setf tree (copy-tree tree)) + (apply #'nsubst new old tree + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not))))) + +(defun check-nsubst-if (new pred tree &key (key 'no-key)) + "Call nsubst-if new pred tree, with keyword arguments if present." + (setf new (copy-tree new)) + (setf tree (copy-tree tree)) + (apply #'nsubst-if new pred tree + (unless (eqt key 'no-key) `(:key ,key)))) + +(defun check-nsubst-if-not (new pred tree &key (key 'no-key)) + "Call nsubst-if-not new pred tree, with keyword arguments if present." + (setf new (copy-tree new)) + (setf tree (copy-tree tree)) + (apply #'nsubst-if-not new pred tree + (unless (eqt key 'no-key) `(:key ,key)))) + +(defun check-copy-list-copy (x y) + "Check that y is a copy of the list x." + (if + (consp x) + (and (consp y) + (not (eqt x y)) + (eqt (car x) (car y)) + (check-copy-list-copy (cdr x) (cdr y))) + (and (eqt x y) t))) + +(defun check-copy-list (x) + "Apply copy-list, checking that it properly copies, + and checking that it does not change its argument." + (let ((xcopy (make-scaffold-copy x))) + (let ((y (copy-list x))) + (and + (check-scaffold-copy x xcopy) + (check-copy-list-copy x y) + y)))) + +(defun append-6-body () + (let* ((cal (min 2048 call-arguments-limit)) + (step (max 1 (floor (/ cal) 64)))) + (loop + for n from 0 + below cal + by step + count + (not + (equal + (apply #'append (loop for i from 1 to n + collect '(a))) + (make-list n :initial-element 'a)))))) + +(defun is-intersection (x y z) + "Check that z is the intersection of x and y." + (and + (listp x) + (listp y) + (listp z) + (loop for e in x + always (or (not (member e y)) + (member e z))) + (loop for e in y + always (or (not (member e x)) + (member e z))) + (loop for e in z + always (and (member e x) (member e y))) + t)) + +(defun shuffle (x) + (cond + ((null x) nil) + ((null (cdr x)) x) + (t + (multiple-value-bind + (y z) + (split-list x) + (append (shuffle y) (shuffle z)))))) + +(defun split-list (x) + (cond + ((null x) (values nil nil)) + ((null (cdr x)) (values x nil)) + (t + (multiple-value-bind + (y z) + (split-list (cddr x)) + (values (cons (car x) y) (cons (cadr x) z)))))) + +(defun intersection-12-body (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size + collect (random maxelem state)))) + (y (shuffle (loop for j from 1 to size + collect (random maxelem state))))) + (let ((z (intersection x y))) + (let ((is-good (is-intersection x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(defun nintersection-with-check (x y &key test) + (let ((ycopy (make-scaffold-copy y))) + (let ((result (if test + (nintersection x y :test test) + (nintersection x y)))) + (if (check-scaffold-copy y ycopy) + result + 'failed)))) + +(defun nintersection-12-body (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state t))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size + collect (random maxelem state)))) + (y (shuffle (loop for j from 1 to size + collect (random maxelem state))))) + (let ((z (nintersection-with-check (copy-list x) y))) + (when (eqt z 'failed) (return (values x y z))) + (let ((is-good (is-intersection x y z))) + (unless is-good (return (values x y z))))))) + nil)) + + +(defun union-with-check (x y &key test test-not) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (cond + (test (union x y :test test)) + (test-not (union x y :test-not test-not)) + (t (union x y))))) + (if (and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + result + 'failed)))) + +(defun union-with-check-and-key (x y key &key test test-not) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (cond + (test (union x y :key key :test test)) + (test-not (union x y :key key :test-not test-not)) + (t (union x y :key key))))) + (if (and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + result + 'failed)))) + +(defun check-union (x y z) + (and (listp x) + (listp y) + (listp z) + (loop for e in z always (or (member e x) (member e y))) + (loop for e in x always (member e z)) + (loop for e in y always (member e z)) + t)) + +(defun do-random-unions (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (union x y))) + (let ((is-good (check-union x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(defun nunion-with-copy (x y &key test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (cond + (test (nunion x y :test test)) + (test-not (nunion x y :test-not test-not)) + (t (nunion x y)))) + +(defun nunion-with-copy-and-key (x y key &key test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (cond + (test (nunion x y :key key :test test)) + (test-not (nunion x y :key key :test-not test-not)) + (t (nunion x y :key key)))) + +(defun do-random-nunions (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (nunion-with-copy x y))) + (let ((is-good (check-union x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(defun set-difference-with-check (x y &key (key 'no-key) + test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (apply #'set-difference + x y + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) + (cond + ((and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + result) + (t + 'failed))))) + +(defun check-set-difference (x y z &key (key #'identity) + (test #'eql)) + (and + ;; (not (eqt 'failed z)) + (listp x) + (listp y) + (listp z) + (loop for e in z always (member e x :key key :test test)) + (loop for e in x always (or (member e y :key key :test test) + (member e z :key key :test test))) + (loop for e in y never (member e z :key key :test test)) + t)) + +(defun do-random-set-differences (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (set-difference-with-check x y))) + (let ((is-good (check-set-difference x y z))) + (unless is-good (return (values x y z))))))) + nil)) +(defun nset-difference-with-check (x y &key (key 'no-key) + test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (apply #'nset-difference + x y + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not))))) + +(defun check-nset-difference (x y z &key (key #'identity) + (test #'eql)) + (and + (listp x) + (listp y) + (listp z) + (loop for e in z always (member e x :key key :test test)) + (loop for e in x always (or (member e y :key key :test test) + (member e z :key key :test test))) + (loop for e in y never (member e z :key key :test test)) + t)) + +(defun do-random-nset-differences (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (nset-difference-with-check x y))) + (let ((is-good (check-nset-difference x y z))) + (unless is-good (return (values x y z))))))) + nil)) + +(defun set-exclusive-or-with-check (x y &key (key 'no-key) + test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result (apply #'set-exclusive-or + x y + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) + (cond + ((and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + result) + (t + 'failed))))) + +(defun check-set-exclusive-or (x y z &key (key #'identity) + (test #'eql)) + (and + ;; (not (eqt 'failed z)) + (listp x) + (listp y) + (listp z) + (loop for e in z always (or (member e x :key key :test test) + (member e y :key key :test test))) + (loop for e in x always (if (member e y :key key :test test) + (not (member e z :key key :test test)) + (member e z :key key :test test))) + (loop for e in y always (if (member e x :key key :test test) + (not (member e z :key key :test test)) + (member e z :key key :test test))) + t)) + +#| +(defun do-random-set-exclusive-ors (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (set-exclusive-or-with-check x y))) + (let ((is-good (check-set-exclusive-or x y z))) + (unless is-good (return (values x y z))))))) + nil)) +|# + +(defun nset-exclusive-or-with-check (x y &key (key 'no-key) + test test-not) + (setf x (copy-list x)) + (setf y (copy-list y)) + (apply #'nset-exclusive-or + x y + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not))))) + +#| +(defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size))) + (let ((state (make-random-state))) + (loop + for i from 1 to niters do + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (nset-exclusive-or-with-check x y))) + (let ((is-good (check-set-exclusive-or x y z))) + (unless is-good (return (values x y z))))))) + nil)) +|# + +(defun subsetp-with-check (x y &key (key 'no-key) test test-not) + (let ((xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y))) + (let ((result + (apply #'subsetp x y + `(,@(unless (eqt key 'no-key) + `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) + (cond + ((and (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)) + (not (not result))) + (t 'failed))))) + (defun my-set-exclusive-or (set1 set2 &key key test test-not) (assert (not (and test test-not))) diff --git a/ansi-tests/cons-test-01.lsp b/ansi-tests/cons-test-01.lsp index 41141e608694f1637512fabccb06b162ef0e7adb..02c15a0ed3a1aaa5544d67f76e97beb3648c517f 100644 --- a/ansi-tests/cons-test-01.lsp +++ b/ansi-tests/cons-test-01.lsp @@ -7,6 +7,8 @@ (declaim (optimize (safety 3))) +(compile-and-load "cons-aux.lsp") + ;; ;; Test the subtype relationships between null, list, cons and atom ;; diff --git a/ansi-tests/cons-test-03.lsp b/ansi-tests/cons-test-03.lsp index 1aa54ccc1eae1c3610e8abe67fb3c09358165f3f..43173434b17c2a964ab07aae4f1733559810cc65 100644 --- a/ansi-tests/cons-test-03.lsp +++ b/ansi-tests/cons-test-03.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (typep <obj> 'list) diff --git a/ansi-tests/cons-test-05.lsp b/ansi-tests/cons-test-05.lsp index 349f2d7684e989b774eac3435e76ab8d0a7e7554..1c4f80db1f2ee8ff2e1457398f56ed46b3b0fafe 100644 --- a/ansi-tests/cons-test-05.lsp +++ b/ansi-tests/cons-test-05.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (defparameter *cons-accessors* '(first second third fourth fifth sixth seventh eighth ninth tenth car cdr caar cadr cdar cddr diff --git a/ansi-tests/cons.lsp b/ansi-tests/cons.lsp index b4991e34820e1fd66a6151e78b50c39b2a53de4d..ae3ee676343f52f773451a24cc519e791e237b73 100644 --- a/ansi-tests/cons.lsp +++ b/ansi-tests/cons.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + ;;; Various easy tests of cons (deftest cons-of-symbols diff --git a/ansi-tests/consp.lsp b/ansi-tests/consp.lsp index f9e4e6bc8a6843afe15e5b99e9821273ed11b685..13493d4c3dff6bebad7001674cb9090a65c743c5 100644 --- a/ansi-tests/consp.lsp +++ b/ansi-tests/consp.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + ;; Lists satisfy consp (deftest consp-list (notnot-mv (consp '(a))) diff --git a/ansi-tests/copy-alist.lsp b/ansi-tests/copy-alist.lsp index 93c9c9fbbaa05075903934c1b2f53d6aa8a31b65..9eaed81d93ea53e96d7c9f51691cecfdbd38c7fc 100644 --- a/ansi-tests/copy-alist.lsp +++ b/ansi-tests/copy-alist.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest copy-alist.1 (let* ((x (copy-tree '((a . b) (c . d) nil (e f) ((x) ((y z)) w) ("foo" . "bar") (#\w . 1.234) diff --git a/ansi-tests/copy-list.lsp b/ansi-tests/copy-list.lsp index 9a8e0390c458e7753e89645a5226f4e23d85c65b..73b3d8ee4a169571280b0372cbbde5d5d10d4b4a 100644 --- a/ansi-tests/copy-list.lsp +++ b/ansi-tests/copy-list.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest copy-list.1 (check-copy-list '(a b c d)) (a b c d)) diff --git a/ansi-tests/copy-tree.lsp b/ansi-tests/copy-tree.lsp index 1ee8314dd49bb35aa3ecfa40cc0298b3bdb11334..390c6a0b16f445486a09d3e49563ec0bac8a780f 100644 --- a/ansi-tests/copy-tree.lsp +++ b/ansi-tests/copy-tree.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + ;; Try copy-tree on a tree containing elements of various kinds (deftest copy-tree.1 (let* ((x (cons 'a (list diff --git a/ansi-tests/cxr.lsp b/ansi-tests/cxr.lsp index b4dd6390e6ed7d35b1f8b8e95c1818857aca6a0f..a1d936ea1167c27fed2390c49e5cb0ce58415abd 100644 --- a/ansi-tests/cxr.lsp +++ b/ansi-tests/cxr.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + ;; Tests of car, cdr and compound forms (deftest cons.23 (car '(a)) diff --git a/ansi-tests/endp.lsp b/ansi-tests/endp.lsp index a82029832131141adde1122795c9288fc45dd678..76154f47242ac1664c0787ef7957fa44925349e8 100644 --- a/ansi-tests/endp.lsp +++ b/ansi-tests/endp.lsp @@ -5,8 +5,7 @@ (in-package :cl-test) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; endp +(compile-and-load "cons-aux.lsp") (deftest endp-nil (notnot-mv (endp nil)) diff --git a/ansi-tests/get-properties.lsp b/ansi-tests/get-properties.lsp index c848154314a7c29dd258a0254fe4de26bdbe2594..d26f375d5769c05a02897669af952fd508e34ddb 100644 --- a/ansi-tests/get-properties.lsp +++ b/ansi-tests/get-properties.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest get-properties.1 (get-properties nil nil) nil nil nil) diff --git a/ansi-tests/getf.lsp b/ansi-tests/getf.lsp index f27389032d23ef84ab4dcd12ece690a813a387b0..7aa717e6e1bce7fb6c7b1c0099f52614cac4ba7b 100644 --- a/ansi-tests/getf.lsp +++ b/ansi-tests/getf.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest getf.1 (getf nil 'a) nil) diff --git a/ansi-tests/intersection.lsp b/ansi-tests/intersection.lsp index 358e8254575787402dd746d3b3aeef8ae0493bca..5706c11e16967b201358762248ccda3d8e5ecdb0 100644 --- a/ansi-tests/intersection.lsp +++ b/ansi-tests/intersection.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest intersection.1 (intersection nil nil) nil) diff --git a/ansi-tests/last.lsp b/ansi-tests/last.lsp index 4ad339b6f87e1b5ca031827e9de06e1c497e3129..df2b6801e8371fbeca1106d89ddd832cffbcf5b1 100644 --- a/ansi-tests/last.lsp +++ b/ansi-tests/last.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest last.1 (last nil) nil) diff --git a/ansi-tests/ldiff.lsp b/ansi-tests/ldiff.lsp index 19f5939acacea83c35c0f6569adc4fe07e36e991..6714f63ec43385cfbac5f81ce04f17d2f467266f 100644 --- a/ansi-tests/ldiff.lsp +++ b/ansi-tests/ldiff.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest ldiff.1 (let* ((x (copy-tree '(a b c d e f))) (xcopy (make-scaffold-copy x))) diff --git a/ansi-tests/list-length.lsp b/ansi-tests/list-length.lsp index 50876c649041a0caa141918e7467d1e0985c4ed3..aba9f3488e9d8ee3da804f9b63c4fab2a2d77d62 100644 --- a/ansi-tests/list-length.lsp +++ b/ansi-tests/list-length.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest list-length-nil (list-length nil) 0) diff --git a/ansi-tests/list.lsp b/ansi-tests/list.lsp index 64d8ac489aabac4203f6e5deebf0813316aabb11..5fe585ad98dba54e5e2823be39dfc6799d239cce 100644 --- a/ansi-tests/list.lsp +++ b/ansi-tests/list.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest list.1 (list 'a 'b 'c) (a b c)) diff --git a/ansi-tests/listp.lsp b/ansi-tests/listp.lsp index 81e4ed06d9aac63a290c857ff757df15a751cec1..bfc0810ef2645c4ecbc37f611e6f014ff5352fd4 100644 --- a/ansi-tests/listp.lsp +++ b/ansi-tests/listp.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest listp-nil (notnot-mv (listp nil)) t) diff --git a/ansi-tests/load-cons.lsp b/ansi-tests/load-cons.lsp index 3b522089b513d22627ea3da05a2e9b477f08bf0b..ea366af746d5edbbed2e3116b6f41b9e626511cd 100644 --- a/ansi-tests/load-cons.lsp +++ b/ansi-tests/load-cons.lsp @@ -1,6 +1,6 @@ ;;; Tests of conses -(compile-and-load "cons-aux.lsp") +;;; (compile-and-load "cons-aux.lsp") (load "cons.lsp") (load "consp.lsp") diff --git a/ansi-tests/make-list.lsp b/ansi-tests/make-list.lsp index e5b9d0b04c410f078cf998f6a2f256aefe9e4abb..466fbae8a54fffd3f17be21fd5936ff69456d41f 100644 --- a/ansi-tests/make-list.lsp +++ b/ansi-tests/make-list.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest make-list-empty.1 (make-list 0) nil) diff --git a/ansi-tests/mapc.lsp b/ansi-tests/mapc.lsp index 944fe2e9bd8e8ed200dfeee9292ec80355e7067e..1be931e9b6bef423b027a399619173720a0d330c 100644 --- a/ansi-tests/mapc.lsp +++ b/ansi-tests/mapc.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest mapc.1 (mapc #'list nil) nil) diff --git a/ansi-tests/mapcan.lsp b/ansi-tests/mapcan.lsp index 4208a82d31b859f8459ba4e7ef2f32c8989f14e4..4278e1e729070d37e577f4f7672413e898e03516 100644 --- a/ansi-tests/mapcan.lsp +++ b/ansi-tests/mapcan.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest mapcan.1 (mapcan #'list nil) nil) diff --git a/ansi-tests/mapcar.lsp b/ansi-tests/mapcar.lsp index 312c4fc3593134951a730096a7090e5245c50c83..d7aaccadcb37890f36cf8e25861b304fdd92e485 100644 --- a/ansi-tests/mapcar.lsp +++ b/ansi-tests/mapcar.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest mapcar.1 (mapcar #'1+ nil) nil) diff --git a/ansi-tests/mapcon.lsp b/ansi-tests/mapcon.lsp index 3def313ae3f85865ab294bf9f2ff67823cb84ddf..bfefb8a97d117cd6602cfbfc9af76ebd576f4d60 100644 --- a/ansi-tests/mapcon.lsp +++ b/ansi-tests/mapcon.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest mapcon.1 (mapcon #'(lambda (x) (append '(a) x nil)) nil) nil) diff --git a/ansi-tests/mapl.lsp b/ansi-tests/mapl.lsp index 9f649f6923844bc8cd3a970e3174e68cca400db6..d7e7bff7678b69257082546eaa924ec29bf0fa68 100644 --- a/ansi-tests/mapl.lsp +++ b/ansi-tests/mapl.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest mapl.1 (mapl #'list nil) nil) diff --git a/ansi-tests/maplist.lsp b/ansi-tests/maplist.lsp index bb3e8c94a53a75280e92e93eac2136ce47c96093..cdf72f941f51efbfef15482fd02eeb490e4e3cbf 100644 --- a/ansi-tests/maplist.lsp +++ b/ansi-tests/maplist.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest maplist.1 (maplist #'list nil) nil) diff --git a/ansi-tests/member-if-not.lsp b/ansi-tests/member-if-not.lsp index 814416049a3ada7170fd9e268761e40837307225..85d22c9d0cfd73e5bad372600223570324fc3743 100644 --- a/ansi-tests/member-if-not.lsp +++ b/ansi-tests/member-if-not.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest member-if-not.1 (member-if-not #'listp nil) nil) diff --git a/ansi-tests/member-if.lsp b/ansi-tests/member-if.lsp index 50f5b936c48b04fa543256936e9cc4336750ca2d..51915185fe5f2abc5de2b23ede5b61c2bdee3bd7 100644 --- a/ansi-tests/member-if.lsp +++ b/ansi-tests/member-if.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest member-if.1 (member-if #'listp nil) nil) diff --git a/ansi-tests/member.lsp b/ansi-tests/member.lsp index 235018b84f81f33d119f51cef1e69b9ae7793ef5..56666a2db786a3e71be15a24a3891367e7014dcf 100644 --- a/ansi-tests/member.lsp +++ b/ansi-tests/member.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest member.1 (let* ((x (copy-tree '(a b c d e f))) (xcopy (make-scaffold-copy x)) diff --git a/ansi-tests/nbutlast.lsp b/ansi-tests/nbutlast.lsp index c9360a39a86e62abec941f93eeb407994c3ce19e..d1275103c6a2bf61b38a4ee2192ffe96678ac731 100644 --- a/ansi-tests/nbutlast.lsp +++ b/ansi-tests/nbutlast.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (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 index 894280574550054da87082736ed4e16ca2b48e80..8f3faf5b5f7e4dbde895843527fa64357e519f2e 100644 --- a/ansi-tests/nconc.lsp +++ b/ansi-tests/nconc.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest nconc.1 (nconc) nil) diff --git a/ansi-tests/nintersection.lsp b/ansi-tests/nintersection.lsp index 3ab1db0f04c385568be9780b305ea06bc3890a8a..81b0b69ee9302c8645791d69ea3a1fc2fa96d73f 100644 --- a/ansi-tests/nintersection.lsp +++ b/ansi-tests/nintersection.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest nintersection.1 (nintersection nil nil) nil) diff --git a/ansi-tests/nreconc.lsp b/ansi-tests/nreconc.lsp index 328369ba1f32c8496a7e34e963396041804745da..b9567dcf31b09006a35931022531b71e658a773d 100644 --- a/ansi-tests/nreconc.lsp +++ b/ansi-tests/nreconc.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest nreconc.1 (let* ((x (list 'a 'b 'c)) (y (copy-tree '(d e f))) diff --git a/ansi-tests/nset-difference.lsp b/ansi-tests/nset-difference.lsp index b32f4eafd8acd1fb2f5ac6f4de9d8c8af328f948..a1fb829e2a4f85d91bb0025a2f75fc899de63aa0 100644 --- a/ansi-tests/nset-difference.lsp +++ b/ansi-tests/nset-difference.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest nset-difference.1 (nset-difference nil nil) nil) diff --git a/ansi-tests/nset-exclusive-or.lsp b/ansi-tests/nset-exclusive-or.lsp index c0795454f7fa0e801367017fdfc0081c86793904..68e3a25476a22c2de14f0b71b372bfe5c63caa83 100644 --- a/ansi-tests/nset-exclusive-or.lsp +++ b/ansi-tests/nset-exclusive-or.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest nset-exclusive-or.1 (nset-exclusive-or nil nil) nil) diff --git a/ansi-tests/nsublis.lsp b/ansi-tests/nsublis.lsp index 6d5eedd1fd28b35afb0647241ace03f5dd975498..5ee2c3a2f1b8448c75129a25c3f58ac0e5ac426d 100644 --- a/ansi-tests/nsublis.lsp +++ b/ansi-tests/nsublis.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest nsublis.1 (check-nsublis '((a b) g (d e 10 g h) 15 . g) '((e . e2) (g . 17))) diff --git a/ansi-tests/nsubst-if-not.lsp b/ansi-tests/nsubst-if-not.lsp index c08be3cb5607da08525100632ecbd6a65a15af3e..521c2d2f5e037e27afe0423634fda3223bef865d 100644 --- a/ansi-tests/nsubst-if-not.lsp +++ b/ansi-tests/nsubst-if-not.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest nsubst-if-not.1 (check-nsubst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) ((x) diff --git a/ansi-tests/nsubst-if.lsp b/ansi-tests/nsubst-if.lsp index 95597e859af3530255d315e606fd13eaf5ae403a..6cce9fbba8d53037792177c0aa6907c58e1d776e 100644 --- a/ansi-tests/nsubst-if.lsp +++ b/ansi-tests/nsubst-if.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest nsubst-if.1 (check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) a) diff --git a/ansi-tests/nsubst.lsp b/ansi-tests/nsubst.lsp index 06e37477f609dadba79cfc425a1781a9b909afbc..f20b800ff9c6108c2358096f4224b0bdbe98f4f5 100644 --- a/ansi-tests/nsubst.lsp +++ b/ansi-tests/nsubst.lsp @@ -5,6 +5,7 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") (defvar *nsubst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) diff --git a/ansi-tests/nth.lsp b/ansi-tests/nth.lsp index fa63cbfa64f326667d4b607ce34b56a5ed7732f2..090042aec1638d298358c4517141dc968b312614 100644 --- a/ansi-tests/nth.lsp +++ b/ansi-tests/nth.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest nth.1 (nth-1-body (loop for i from 1 to 2000 collect (* 4 i))) 0) diff --git a/ansi-tests/nthcdr.lsp b/ansi-tests/nthcdr.lsp index 6fdffd7f08836bef58527950964e3660a5e0f6c2..4823c1cc60a41ea07d2eed80ada52db1f5610a0c 100644 --- a/ansi-tests/nthcdr.lsp +++ b/ansi-tests/nthcdr.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + ;;; Error tests (deftest nthcdr.error.1 diff --git a/ansi-tests/nunion.lsp b/ansi-tests/nunion.lsp index 877d32207f7da85f69eea55c3240851294d382e4..53df8a39b64bcf8ec10a04f81e4c288854a9505b 100644 --- a/ansi-tests/nunion.lsp +++ b/ansi-tests/nunion.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest nunion.1 (nunion nil nil) nil) diff --git a/ansi-tests/pairlis.lsp b/ansi-tests/pairlis.lsp index 15e3813b5442bee657ac455163728dcb52867454..2aa7bd09cd59389d3e3ad21ceed52afce8a4e7d3 100644 --- a/ansi-tests/pairlis.lsp +++ b/ansi-tests/pairlis.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + ;; 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 diff --git a/ansi-tests/pop.lsp b/ansi-tests/pop.lsp index f58d8f065ebd2ea9027a285e95b07cafe3c0276b..f33d9cd8b6bd7e4a2ebd6d47bccae09dda680505 100644 --- a/ansi-tests/pop.lsp +++ b/ansi-tests/pop.lsp @@ -3,9 +3,10 @@ ;;;; Created: Sat Apr 19 22:27:18 2003 ;;;; Contains: Tests of POP - (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest pop.1 (let ((x (copy-tree '(a b c)))) (let ((y (pop x))) diff --git a/ansi-tests/push.lsp b/ansi-tests/push.lsp index 41e8f90729702d32e4fff94bfba55e81ebd19614..3ba4957aa09cc65f83ad8daa435429ba2bded3a8 100644 --- a/ansi-tests/push.lsp +++ b/ansi-tests/push.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + ;;; See also places.lsp (deftest push.1 diff --git a/ansi-tests/pushnew.lsp b/ansi-tests/pushnew.lsp index f65d04136b8d8c9ee9b8fa972d6295c1338c5794..ba8bc1ad2f1013ec028926ce2f14c869a62f2301 100644 --- a/ansi-tests/pushnew.lsp +++ b/ansi-tests/pushnew.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest pushnew.1 (let ((x nil)) (let ((y (pushnew 'a x))) diff --git a/ansi-tests/rassoc-if-not.lsp b/ansi-tests/rassoc-if-not.lsp index 37e649d1e53d598a63312df5d1ddce2315582a62..f426a74863ec3e0741f7644af2ed3953467ea725 100644 --- a/ansi-tests/rassoc-if-not.lsp +++ b/ansi-tests/rassoc-if-not.lsp @@ -5,6 +5,7 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") (deftest rassoc-if-not.1 (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) diff --git a/ansi-tests/rassoc-if.lsp b/ansi-tests/rassoc-if.lsp index e121d4b74e94bbe9f18be19e183e04d03286b376..96ce39b663097f4adee3360141213de9e39ccc2d 100644 --- a/ansi-tests/rassoc-if.lsp +++ b/ansi-tests/rassoc-if.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest rassoc-if.1 (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) (xcopy (make-scaffold-copy x)) diff --git a/ansi-tests/remf.lsp b/ansi-tests/remf.lsp index 6a1af54116ce2ac4dffcdeca1328c79f889c10ef..e3c3dbd408dce9e998f4426f7a2eac9c9f639f79 100644 --- a/ansi-tests/remf.lsp +++ b/ansi-tests/remf.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest remf.1 (let ((x nil)) (values (remf x 'a) x)) diff --git a/ansi-tests/rest.lsp b/ansi-tests/rest.lsp index 2fe471b2059c7d3b4e1b8f24bd5e776b6726c4e8..6fb9f5ec3a29b26b8004978a4d1417f847e04f16 100644 --- a/ansi-tests/rest.lsp +++ b/ansi-tests/rest.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest rest.1 (rest (list 'a 'b 'c)) (b c)) diff --git a/ansi-tests/revappend.lsp b/ansi-tests/revappend.lsp index dc725a633e75287e97806b488438b0ad2304cec7..f711cfa1777048d7f4306bc6534314b8b4987dd4 100644 --- a/ansi-tests/revappend.lsp +++ b/ansi-tests/revappend.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest revappend.1 (let* ((x (list 'a 'b 'c)) (y (list 'd 'e 'f)) diff --git a/ansi-tests/rplaca.lsp b/ansi-tests/rplaca.lsp index fe793b4d193d0d73d08b24e68cfe7030016d150e..ec5ea782b142800f73fe84a0fa712ddce9705b76 100644 --- a/ansi-tests/rplaca.lsp +++ b/ansi-tests/rplaca.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest rplaca.1 (let ((x (cons 'a 'b))) (let ((y x)) diff --git a/ansi-tests/rplacd.lsp b/ansi-tests/rplacd.lsp index 41977db709ca7171c91a6345c0a352ee60074dae..f8e55119a90d02884825ffd8c7ee09dc23a2e8fc 100644 --- a/ansi-tests/rplacd.lsp +++ b/ansi-tests/rplacd.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest rplacd.1 (let ((x (cons 'a 'b))) (let ((y x)) diff --git a/ansi-tests/set-difference.lsp b/ansi-tests/set-difference.lsp index 3b0cb62fe006fa90615bf94dca1b6bb2347f5b22..7a84b4cb8f88d6c15ef3c8fa28cb21a50ea8e7ab 100644 --- a/ansi-tests/set-difference.lsp +++ b/ansi-tests/set-difference.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest set-difference.1 (set-difference nil nil) nil) diff --git a/ansi-tests/set-exclusive-or.lsp b/ansi-tests/set-exclusive-or.lsp index 16ced6eb845f8366f318891911095579c735081e..b937263a973cece12c40e44c49bb49d60b994cbc 100644 --- a/ansi-tests/set-exclusive-or.lsp +++ b/ansi-tests/set-exclusive-or.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest set-exclusive-or.1 (set-exclusive-or nil nil) nil) diff --git a/ansi-tests/sublis.lsp b/ansi-tests/sublis.lsp index aabe95d0e851d2a861401b26bcda7af7e73fb940..daa2e49e11399b25b37263b9501ed1274462174c 100644 --- a/ansi-tests/sublis.lsp +++ b/ansi-tests/sublis.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest sublis.1 (check-sublis '((a b) g (d e 10 g h) 15 . g) '((e . e2) (g . 17))) diff --git a/ansi-tests/subsetp.lsp b/ansi-tests/subsetp.lsp index 55f661acd6a0b2dfd5393068b5ca99671899f6a2..9116091e0adbeabcb057a6d2e83d78a1439dfc7a 100644 --- a/ansi-tests/subsetp.lsp +++ b/ansi-tests/subsetp.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (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 index 79cc576d8fd067c0650ce79f30f83bf5e7abb702..bbc93fe79b31174e8b8d32f93ffc65f9f92d3bea 100644 --- a/ansi-tests/subst-if-not.lsp +++ b/ansi-tests/subst-if-not.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest subst-if-not.1 (check-subst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) ((x) diff --git a/ansi-tests/subst-if.lsp b/ansi-tests/subst-if.lsp index f9992c3036a9547d5d83120bada6c4385ab3b628..cb2cdaa77bb3f69c18402aec04a46b8849fbbf1f 100644 --- a/ansi-tests/subst-if.lsp +++ b/ansi-tests/subst-if.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest subst-if.1 (check-subst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) a) diff --git a/ansi-tests/subst.lsp b/ansi-tests/subst.lsp index f3cc0ff1f9efd4390ceaf7e027dae3b025ab1e60..11a6026b8f9451fc21a762c7e3860da19ab205f6 100644 --- a/ansi-tests/subst.lsp +++ b/ansi-tests/subst.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (defvar *subst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) (deftest subst.1 diff --git a/ansi-tests/tailp.lsp b/ansi-tests/tailp.lsp index 895090d3fa3da4e37352f65f28ca96368a971f79..22505712126a9c40558e32b77001b3724941e2ff 100644 --- a/ansi-tests/tailp.lsp +++ b/ansi-tests/tailp.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest tailp.1 (let ((x (copy-tree '(a b c d e . f)))) (and diff --git a/ansi-tests/tree-equal.lsp b/ansi-tests/tree-equal.lsp index 9733f4c00325f2f1653e1c3c36a716a557961f58..060f5a5373b5b52e8c1c97302ba8cda498cac3d0 100644 --- a/ansi-tests/tree-equal.lsp +++ b/ansi-tests/tree-equal.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest tree-equal.1 (notnot-mv (tree-equal 'a 'a)) t) diff --git a/ansi-tests/union.lsp b/ansi-tests/union.lsp index d54834f6fe1d4d909f7273cbe7158d256f7ff6f8..7446049498723cd108be6f19702d2a0d13e519a9 100644 --- a/ansi-tests/union.lsp +++ b/ansi-tests/union.lsp @@ -5,6 +5,8 @@ (in-package :cl-test) +(compile-and-load "cons-aux.lsp") + (deftest union.1 (union nil nil) nil)