[Chicken-hackers] [PATCH] Add non-destructive version of alist-update!

[Moritz Heidkamp]

Hi all,

I'd like to continue with Christian's initiative. Find attached a simple
patch that adds a non-destructive version of alist-update! named
(obviously) alist-update to the data-structures unit. It also updates
the manual accordingly and adds a few test cases for both alist-update!
and alist-update. Since the patch is so trivial I won't discuss it in
detail, just take a look and you'll get the idea :-)

Regards
Moritz

>From 58fde20c0eefd7527886bb5342ac1489b805f4bc Mon Sep 17 00:00:00 2001
From: Moritz Heidkamp <address@hidden>
Date: Tue, 6 Sep 2011 15:03:06 +0200
Subject: [PATCH] add non-destructive version of alist-update! named
 alist-update and add some tests for both of them

---
 data-structures.import.scm      |    1 +
 data-structures.scm             |    3 +++
 manual/Unit data-structures     |    7 ++++---
 tests/data-structures-tests.scm |   18 ++++++++++++++++++
 tests/runtests.sh               |    3 +++
 5 files changed, 29 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..7cb8e98 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -231,6 +231,9 @@ EOF
          lst)
        (cons (cons x y) lst) ) ) )
 
+(define (alist-update k v lst #!optional (cmp eqv?))
+  (alist-update! k v (map (lambda (elt) (cons (car elt) (cdr elt))) lst) cmp))
+
 (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
 
-- 
1.7.6.1