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

(alist-copy): New tests.

Browse source
This commit is contained in:
Kevin Ryde 2004-12-05 21:53:53 +00:00
parent bbf21c8a13
commit d4dfc9d426
1 changed files with 46 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -44,6 +44,52 @@
(use-modules (srfi srfi-1)
(test-suite lib))
;;
;; alist-copy
;;
(with-test-prefix "alist-copy"
;; return a list which is the pairs making up alist A, the spine and cells
(define (alist-pairs a)
(let more ((a a)
(result a))
(if (pair? a)
(more (cdr a) (cons a result))
result)))
;; return a list of the elements common to lists X and Y, compared with eq?
(define (common-elements x y)
(if (null? x)
'()
(if (memq (car x) y)
(cons (car x) (common-elements (cdr x) y))
(common-elements (cdr x) y))))
;; validate an alist-copy of OLD to NEW
;; lists must be equal, and must comprise new pairs
(define (valid-alist-copy? old new)
(and (equal? old new)
(null? (common-elements old new))))
(pass-if-exception "too few args" exception:wrong-num-args
(alist-copy))
(pass-if-exception "too many args" exception:wrong-num-args
(alist-copy '() '()))
(let ((old '()))
(pass-if old (valid-alist-copy? old (alist-copy old))))
(let ((old '((1 . 2))))
(pass-if old (valid-alist-copy? old (alist-copy old))))
(let ((old '((1 . 2) (3 . 4))))
(pass-if old (valid-alist-copy? old (alist-copy old))))
(let ((old '((1 . 2) (3 . 4) (5 . 6))))
(pass-if old (valid-alist-copy? old (alist-copy old)))))
;;
;; append-map
;;