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

(delete, delete!): New tests.

Browse source
This commit is contained in:
Kevin Ryde 2004-12-05 22:32:01 +00:00
parent 49046d53e0
commit 27036c046d
1 changed files with 71 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

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

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