(delete, delete!): Add more tests.

(delete-duplicates, delete-duplicates!): Add tests.

diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index deef6d0..a96aa08 100644 (file)
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -20,22 +20,161 @@
 (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)))))
+
+(define (ref-delete-duplicates lst . proc)
+  "Reference implemenation of srfi-1 `delete-duplicates'."
+  (set! proc (if (null? proc) equal? (car proc)))
+  (if (null? lst)
+      '()
+      (do ((keep '()))
+         ((null? lst)
+          (reverse! keep))
+       (let ((elem (car lst)))
+         (set! keep (cons elem keep))
+         (set! lst  (ref-delete elem lst proc))))))
+
 
 ;;
 ;; 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-exception "too many args" exception:wrong-num-args
+      (delete-proc 0 '() equal? 99))
+    
+    (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))
+    (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!)))
+    (common-tests delete!)
+    
+    (test-lists
+     (lambda (lst)
+       (pass-if lst
+        (equal? (delete!    #f lst)
+                (ref-delete #f lst)))))))
+
+;;
+;; delete-duplicates and delete-duplicates!
+;;
+
+(let ()        
+  ;; Call (PROC lst) for all lists of length 1 <= n <= 4, with all
+  ;; combinations of numbers 1 to n in the elements
+  (define (test-lists proc)
+    (do ((n 1 (1+ n)))
+       ((> n 4))
+      (do ((limit (integer-expt n n))
+          (i 0 (1+ i)))
+         ((>= i limit))
+       (let ((lst '()))
+         (do ((j 0 (1+ j))
+              (rem i (quotient rem n)))
+             ((>= j n))
+           (set! lst (cons (remainder rem n) lst)))
+         (proc lst)))))
+
+  (define (common-tests delete-duplicates-proc)
+    (pass-if-exception "too few args" exception:wrong-num-args
+      (delete-duplicates-proc))
+    
+    (pass-if-exception "too many args" exception:wrong-num-args
+      (delete-duplicates-proc '() equal? 99))
+    
+    (pass-if "empty"
+      (eq? '() (delete-duplicates-proc '())))
+    
+    (pass-if "equal? (the default)"
+      (equal? '((2))
+             (delete-duplicates-proc '((2) (2) (2)))))
+    
+    (pass-if "eq?"
+      (equal? '((2) (2) (2))
+             (delete-duplicates-proc '((2) (2) (2)) eq?)))
+
+    (pass-if "called arg order"
+      (let ((ok #t))
+       (delete-duplicates-proc '(1 2 3 4 5)
+                               (lambda (x y)
+                                 (if (> x y)
+                                     (set! ok #f))
+                                 #f))
+       ok)))
+  
+  (with-test-prefix "delete-duplicates"
+    (common-tests delete-duplicates)
+    
+    (test-lists
+     (lambda (lst)
+       (let ((lst-copy (list-copy lst)))
+        (with-test-prefix lst-copy
+          (pass-if "result"
+            (equal? (delete-duplicates     lst)
+                    (ref-delete-duplicates lst)))
+          (pass-if "non-destructive"
+            (equal? lst-copy lst)))))))  
+  
+  (with-test-prefix "delete-duplicates!"
+    (common-tests delete-duplicates!)
+    
+    (test-lists
+     (lambda (lst)
+       (pass-if lst
+        (equal? (delete-duplicates!    lst)
+                (ref-delete-duplicates lst)))))))
 
 ;;
 ;; drop