From aa50b82422c096527cd46ddd9f4207ee8d8df5f7 Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Sun, 10 Nov 2002 22:34:33 +0000
Subject: [PATCH] Fixed up the randomized tests; they were passing regardless
 of what happened.  They now print out the arg list on which a failure
 occured.  REMOVE/etc. are failing when COUNT is negative.

---
 ansi-tests/remove-aux.lsp |  9 +++++++--
 ansi-tests/remove.lsp     | 36 +++++++++++++++++++++++++++++-------
 2 files changed, 36 insertions(+), 9 deletions(-)

diff --git a/ansi-tests/remove-aux.lsp b/ansi-tests/remove-aux.lsp
index f46f51e1..5f27acff 100644
--- a/ansi-tests/remove-aux.lsp
+++ b/ansi-tests/remove-aux.lsp
@@ -136,8 +136,10 @@
 		   (if start (+ start (random (- len start)))
 		     (random (1+ len)))))
 	 (from-end (coin))
-	 (count (and (coin)
-		     (random (1+ len))))
+	 (count (case (random 5)
+		  ((0 1) nil)
+		  ((2 3) (random (1+ len)))
+		  (t (if (coin) -1 -10000000000000))))
 	 (seq (multiple-value-bind (x y z) (make-random-remove-input len type element-type)
 		y))
 	 (key (and (coin)
@@ -199,6 +201,8 @@
        ((not (equalp seq1r seq2r)) :fail3)
        (t t)))))
 
+(defparameter *remove-fail-args* nil)
+
 (defun random-test-remove-if (maxlen &optional (negate nil))
   (multiple-value-bind (element seq arg-list)
       (random-test-remove-args maxlen)
@@ -221,6 +225,7 @@
 			   fn seq1 arg-list))
 	     (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if)
 			   fn seq2 arg-list)))
+	(setq *remove-fail-args* (cons seq1 arg-list))
 	(cond
 	 ((not (equalp seq seq1)) :fail1)
 	 ((not (equalp seq seq2)) :fail2)
diff --git a/ansi-tests/remove.lsp b/ansi-tests/remove.lsp
index 7a1ea225..5bbb0dc1 100644
--- a/ansi-tests/remove.lsp
+++ b/ansi-tests/remove.lsp
@@ -266,36 +266,58 @@
     (and (equalp orig x) y))
   (1 2 2 6 1 2 4 1 3 2 7))
 
+(deftest remove-list.27
+  (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7))
+	 (x (copy-seq orig))
+	 (y (remove 3 x :count -1)))
+    (and (equalp orig x)
+	 (equalpt x y)))
+  t)
+
+(deftest remove-list.28
+  (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7))
+	 (x (copy-seq orig))
+	 (y (remove 3 x :count -1000000000000)))
+    (and (equalp orig x)
+	 (equalpt x y)))
+  t)
+
 ;;; Randomized tests
 
 (deftest remove-random
   (loop for i from 1 to 2500
-	always (random-test-remove 20))
+	unless (eq (random-test-remove 20) t)
+	do (return *remove-fail-args*))
   t)
 
 (deftest remove-if-random
   (loop for i from 1 to 2500
-	always (random-test-remove-if 20))
+	unless (eq (random-test-remove-if 20) t)
+	do (return *remove-fail-args*))
   t)
 
 (deftest remove-if-not-random
   (loop for i from 1 to 2500
-	always (random-test-remove-if 20 t))
+	unless (eq (random-test-remove-if 20 t) t)
+	do (return *remove-fail-args*))
   t)
 
 (deftest delete-random
   (loop for i from 1 to 2500
-	always (random-test-delete 20))
+	unless (eq (random-test-delete 20) t)
+	do (return *remove-fail-args*))
   t)
-
+1
 (deftest delete-if-random
   (loop for i from 1 to 2500
-	always (random-test-delete-if 20))
+	unless (eq (random-test-delete-if 20) t)
+	do (return *remove-fail-args*))
   t)
 
 (deftest delete-if-not-random
   (loop for i from 1 to 2500
-	always (random-test-delete-if 20 t))
+	unless (eq (random-test-delete-if 20 t) t)
+	do (return *remove-fail-args*))
   t)
 
 ;;; Additional tests with KEY = NIL
-- 
GitLab