mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

(delete, delete!): Add more tests.

Browse source 
(delete-duplicates, delete-duplicates!): Add tests.
This commit is contained in:
Kevin Ryde 2003-07-08 00:13:06 +00:00
parent 9388c70ac0
commit 72f1b979f6
1 changed files with 141 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

143
test-suite/tests/srfi-1.test
View file

@ -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