From 27036c046d6ee2dd76ffa7070285d92e394b3702 Mon Sep 17 00:00:00 2001
From: Kevin Ryde <user42@zip.com.au>
Date: Sun, 5 Dec 2004 22:32:01 +0000
Subject: [PATCH] (delete, delete!): New tests.

---
 test-suite/tests/srfi-1.test | 71 ++++++++++++++++++++++++++++++++++++
 1 file changed, 71 insertions(+)

diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index 3293730d6..d32c7aafc 100644
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -44,6 +44,16 @@
 (use-modules (srfi srfi-1)
 	     (test-suite lib))
 
+(define (ref-delete x lst . proc)
+  "Reference implemenation of srfi-1 `delete'."
+  (set! proc (if (null? proc) equal? (car proc)))
+  (do ((ret '())
+       (lst lst (cdr lst)))
+      ((null? lst)
+       (reverse! ret))
+    (if (not (proc x (car lst)))
+	(set! ret (cons (car lst) ret)))))
+
 ;;
 ;; alist-copy
 ;;
@@ -301,6 +311,67 @@
       (pass-if "" (= 1 (count or3 '(#t #t #t) '(#t) '(#t #t))))
       (pass-if "" (= 1 (count or3 '(#t #t #t) '(#t #t) '(#t)))))))
 
+;;
+;; delete and delete!
+;;
+
+(let ()	
+  ;; Call (PROC lst) for all lists of length up to 6, with all combinations
+  ;; of elements to be retained or deleted.  Elements to retain are numbers,
+  ;; 0 upwards.  Elements to be deleted are #f.
+  (define (test-lists proc)
+    (do ((n 0 (1+ n)))
+	((>= n 6))
+      (do ((limit (ash 1 n))
+	   (i 0 (1+ i)))
+	  ((>= i limit))
+	(let ((lst '()))
+	  (do ((bit 0 (1+ bit)))
+	      ((>= bit n))
+	    (set! lst  (cons (if (logbit? bit i) bit #f) lst)))
+	  (proc lst)))))
+  
+  (define (common-tests delete-proc)
+    (pass-if-exception "too few args" exception:wrong-num-args
+      (delete-proc 0))
+    
+    (pass-if "empty"
+      (eq? '() (delete-proc 0 '())))
+    
+    (pass-if "equal? (the default)"
+      (equal? '((1) (3))
+	      (delete-proc '(2) '((1) (2) (3)))))
+    
+    (pass-if "eq?"
+      (equal? '((1) (2) (3))
+	      (delete-proc '(2) '((1) (2) (3)) eq?)))
+    
+    (pass-if "called arg order"
+      (equal? '(1 2 3)
+	      (delete-proc 3 '(1 2 3 4 5) <))))
+  
+  (with-test-prefix "delete"
+    (common-tests delete)
+    
+    (test-lists
+     (lambda (lst)
+       (let ((lst-copy (list-copy lst)))
+	 (with-test-prefix lst-copy
+	   (pass-if "result"
+	     (equal? (delete     #f lst)
+		     (ref-delete #f lst)))
+	   (pass-if "non-destructive"
+	     (equal? lst-copy lst)))))))  
+  
+  (with-test-prefix "delete!"
+    (common-tests delete!)
+    
+    (test-lists
+     (lambda (lst)
+       (pass-if lst
+	 (equal? (delete!    #f lst)
+		 (ref-delete #f lst)))))))
+
 ;;
 ;; filter-map
 ;;