From f9a95cfe2aebcdb888ae1e3ddf4cbac9c4982c1e Mon Sep 17 00:00:00 2001
From: Kevin Ryde <user42@zip.com.au>
Date: Sun, 5 Dec 2004 21:49:48 +0000
Subject: [PATCH] (alist-copy): New tests.

---
 test-suite/tests/srfi-1.test | 48 +++++++++++++++++++++++++++++++++++-
 1 file changed, 47 insertions(+), 1 deletion(-)

diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index e60edfa99..d34f1b60d 100644
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -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
 ;;