>From fa0a758cf2bac89a5507c6aaf548527974e2ef1d Mon Sep 17 00:00:00 2001
From: Moritz Heidkamp <address@hidden>
Date: Tue, 13 Sep 2011 15:17:10 +0200
Subject: [PATCH] add alist-update, a non-destructive version of alist-update!

alist-update only copies as much of the alist as needed (i.e. up until the matching pair)
add documentation and a types.db entry for alist-update
add tests for both alist-update and alist-update!
---
 data-structures.import.scm      |    1 +
 data-structures.scm             |   13 +++++++++++++
 manual/Unit data-structures     |    7 ++++---
 tests/data-structures-tests.scm |   18 ++++++++++++++++++
 tests/runtests.sh               |    3 +++
 types.db                        |    1 +
 6 files changed, 40 insertions(+), 3 deletions(-)
 create mode 100644 tests/data-structures-tests.scm

diff --git a/data-structures.import.scm b/data-structures.import.scm
index 245c7c4..2fd71bf 100644
--- a/data-structures.import.scm
+++ b/data-structures.import.scm
@@ -29,6 +29,7 @@
  '(->string
    alist-ref
    alist-update!
+   alist-update
    always?				; DEPRECATED
    any?
    atom?
diff --git a/data-structures.scm b/data-structures.scm
index 7da3698..8d47f7f 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -231,6 +231,19 @@ EOF
 	  lst)
 	(cons (cons x y) lst) ) ) )
 
+(define (alist-update k v lst #!optional (cmp eqv?))
+  (let loop ((lst lst))
+    (if (null? lst)
+        (list (cons k v))
+        (let ((a (##sys#slot lst 0)))
+          (cond ((not (pair? a))
+                 (error 'alist-update "bad argument type" a))
+                ((cmp (##sys#slot a 0) k)
+                 (cons (cons k v) (##sys#slot lst 1)))
+                (else
+                 (cons (cons (##sys#slot a 0) (##sys#slot a 1))
+                       (loop (##sys#slot lst 1)))))))))
+
 (define (alist-ref x lst #!optional (cmp eqv?) (default #f))
   (let* ([aq (cond [(eq? eq? cmp) assq]
 		   [(eq? eqv? cmp) assv]
diff --git a/manual/Unit data-structures b/manual/Unit data-structures
index 6f3e8c1..5412ea4 100644
--- a/manual/Unit data-structures	
+++ b/manual/Unit data-structures	
@@ -19,15 +19,16 @@ Looks up {{KEY}} in {{ALIST}} using {{TEST}} as the comparison function (or {{eq
 no test was given) and returns the cdr of the found pair, or {{DEFAULT}} (which defaults to {{#f}}).
 
 
-==== alist-update!
+==== alist-update
 
+<procedure>(alist-update KEY VALUE ALIST [TEST])</procedure>
 <procedure>(alist-update! KEY VALUE ALIST [TEST])</procedure>
 
 If the list {{ALIST}} contains a pair of the form {{(KEY . X)}}, then this procedure
 replaces {{X}} with {{VALUE}} and returns {{ALIST}}. If {{ALIST}} contains no such item, then
-{{alist-update!}} returns {{((KEY . VALUE) . ALIST)}}. The optional argument
+{{alist-update}} returns {{((KEY . VALUE) . ALIST)}}. The optional argument
 {{TEST}} specifies the comparison procedure to search a matching pair in {{ALIST}}
-and defaults to {{eqv?}}.
+and defaults to {{eqv?}}. {{alist-update!}} is the destructive version of {{alist-update}}.
 
 
 ==== atom?
diff --git a/tests/data-structures-tests.scm b/tests/data-structures-tests.scm
new file mode 100644
index 0000000..df4b559
--- /dev/null
+++ b/tests/data-structures-tests.scm
@@ -0,0 +1,18 @@
+;;;; data-structures-tests.scm
+
+
+(use data-structures)
+
+(let ((alist '((foo . 123) ("bar" . "baz"))))
+  (alist-update! 'foo 999 alist)
+  (assert (= (alist-ref 'foo alist) 999))
+  (alist-update! 'qux 'nope alist)
+  (assert (not (alist-ref 'qux alist)))
+  (assert (eq? 'yep (alist-ref 'qux (alist-update! 'qux 'yep alist))))
+  (assert (eq? 'ok (alist-ref "bar" (alist-update! "bar" 'ok alist equal?) equal?))))
+
+(let ((alist '((foo . 123) ("bar" . "baz"))))
+  (alist-update 'foo 999 alist)
+  (assert (= (alist-ref 'foo alist) 123))
+  (assert (eq? 'yep (alist-ref 'qux (alist-update 'qux 'yep alist))))
+  (assert (eq? 'ok (alist-ref "bar" (alist-update "bar" 'ok alist equal?) equal?))))
\ No newline at end of file
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 4a24457..f0c19ce 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -294,6 +294,9 @@ echo "======================================== srfi-18 tests ..."
 $interpret -s simple-thread-test.scm
 $interpret -s mutex-test.scm
 
+echo "======================================== data-structures tests ..."
+$interpret -s data-structures-tests.scm
+
 echo "======================================== path tests ..."
 $interpret -bnq path-tests.scm
 
diff --git a/types.db b/types.db
index a131e34..61a2e05 100644
--- a/types.db
+++ b/types.db
@@ -1095,6 +1095,7 @@
 
 (alist-ref (#(procedure #:clean #:enforce) alist-ref (* (list pair) #!optional (procedure (* *) *) *) *))
 (alist-update! (#(procedure #:enforce) alist-update! (* * (list pair) #!optional (procedure (* *) *)) *))
+(alist-update (#(procedure #:clean #:enforce) alist-update (* (list pair) #!optional (procedure (* *) *) *) *))
 (always? deprecated)
 
 (any? (#(procedure #:pure) any? (*) boolean)
-- 
1.7.6.1