mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-23 04:50:28 +02:00
Code Activity

(drop-right, partition!, take-right): New tests.

Browse source
This commit is contained in:
Kevin Ryde 2005-03-15 21:16:32 +00:00
parent 2b077051db
commit ba9fb62d10
1 changed files with 117 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -674,6 +674,42 @@
(equal? 'c
(drop '(a b . c) 2))))
;;
;; drop-right
;;
(with-test-prefix "drop-right"
(pass-if-exception "() -1" exception:out-of-range
(drop-right '() -1))
(pass-if (equal? '() (drop-right '() 0)))
(pass-if-exception "() 1" exception:wrong-type-arg
(drop-right '() 1))
(pass-if-exception "(1) -1" exception:out-of-range
(drop-right '(1) -1))
(pass-if (equal? '(1) (drop-right '(1) 0)))
(pass-if (equal? '() (drop-right '(1) 1)))
(pass-if-exception "(1) 2" exception:wrong-type-arg
(drop-right '(1) 2))
(pass-if-exception "(4 5) -1" exception:out-of-range
(drop-right '(4 5) -1))
(pass-if (equal? '(4 5) (drop-right '(4 5) 0)))
(pass-if (equal? '(4) (drop-right '(4 5) 1)))
(pass-if (equal? '() (drop-right '(4 5) 2)))
(pass-if-exception "(4 5) 3" exception:wrong-type-arg
(drop-right '(4 5) 3))
(pass-if-exception "(4 5 6) -1" exception:out-of-range
(drop-right '(4 5 6) -1))
(pass-if (equal? '(4 5 6) (drop-right '(4 5 6) 0)))
(pass-if (equal? '(4 5) (drop-right '(4 5 6) 1)))
(pass-if (equal? '(4) (drop-right '(4 5 6) 2)))
(pass-if (equal? '() (drop-right '(4 5 6) 3)))
(pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
(drop-right '(4 5 6) 4)))
;;
;; filter-map
;;
@ -1138,6 +1174,49 @@
(and (= (length odd) 10000)
(= (length even) 0))))))
;;
;; partition!
;;
(define (test-partition! pred list kept-good dropped-good)
(call-with-values (lambda ()
(partition! pred list))
(lambda (kept dropped)
(and (equal? kept kept-good)
(equal? dropped dropped-good)))))
(with-test-prefix "partition!"
(pass-if "with dropped tail"
(test-partition! even? (list 1 2 3 4 5 6 7)
'(2 4 6) '(1 3 5 7)))
(pass-if "with kept tail"
(test-partition! even? (list 1 2 3 4 5 6)
'(2 4 6) '(1 3 5)))
(pass-if "with everything dropped"
(test-partition! even? (list 1 3 5 7)
'() '(1 3 5 7)))
(pass-if "with everything kept"
(test-partition! even? (list 2 4 6)
'(2 4 6) '()))
(pass-if "with empty list"
(test-partition! even? '()
'() '()))
(pass-if "with reasonably long list"
;; the old implementation from SRFI-1 reference implementation
;; would signal a stack-overflow for a list of only 500 elements!
(call-with-values (lambda ()
(partition! even?
(make-list 10000 1)))
(lambda (even odd)
(and (= (length odd) 10000)
(= (length even) 0))))))
;;
;; reduce
;;
@ -1354,3 +1433,41 @@
(pass-if "nnn"
(test-span '(-1 -2 -3) '() '(-1 -2 -3))))
;;
;; take-right
;;
(with-test-prefix "take-right"
(pass-if-exception "() -1" exception:out-of-range
(take-right '() -1))
(pass-if (equal? '() (take-right '() 0)))
(pass-if-exception "() 1" exception:wrong-type-arg
(take-right '() 1))
(pass-if-exception "(1) -1" exception:out-of-range
(take-right '(1) -1))
(pass-if (equal? '() (take-right '(1) 0)))
(pass-if (equal? '(1) (take-right '(1) 1)))
(pass-if-exception "(1) 2" exception:wrong-type-arg
(take-right '(1) 2))
(pass-if-exception "(4 5) -1" exception:out-of-range
(take-right '(4 5) -1))
(pass-if (equal? '() (take-right '(4 5) 0)))
(pass-if (equal? '(5) (take-right '(4 5) 1)))
(pass-if (equal? '(4 5) (take-right '(4 5) 2)))
(pass-if-exception "(4 5) 3" exception:wrong-type-arg
(take-right '(4 5) 3))
(pass-if-exception "(4 5 6) -1" exception:out-of-range
(take-right '(4 5 6) -1))
(pass-if (equal? '() (take-right '(4 5 6) 0)))
(pass-if (equal? '(6) (take-right '(4 5 6) 1)))
(pass-if (equal? '(5 6) (take-right '(4 5 6) 2)))
(pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3)))
(pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
(take-right '(4 5 6) 4)))