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

(alist-copy): New tests.

Browse source
This commit is contained in:
Kevin Ryde 2004-12-05 21:49:48 +00:00
parent 64f7942092
commit f9a95cfe2a
1 changed files with 47 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,6 @@
;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
;;;;
;;;; Copyright 2003 Free Software Foundation, Inc.
;;;; Copyright 2003, 2004 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
@ -43,6 +43,52 @@
(set! lst (ref-delete elem lst proc))))))
;;
;; 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
;;