~ chicken-core (chicken-5) 34ae5a3ee51081cacda90523919c29682950bf48

commit 34ae5a3ee51081cacda90523919c29682950bf48
Author:     Moritz Heidkamp <moritz@twoticketsplease.de>
AuthorDate: Tue Sep 13 15:17:10 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Wed Sep 14 09:11:17 2011 +0200

    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!
    
    --
    Fixed type in types.db (one argument was missing) and added entry
    in manifest for tests/data-structures-tests.scm.
    
    Signed off by felix.

diff --git a/data-structures.import.scm b/data-structures.import.scm
index 245c7c4d..2fd71bfb 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 7da36987..8d47f7f5 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/distribution/manifest b/distribution/manifest
index 9a8f72e8..adc0ba9c 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -100,6 +100,7 @@ build-version.c
 buildid
 buildtag.h
 tests/thread-list.scm
+tests/data-structures-tests.scm
 tests/environment-tests.scm
 tests/gobble.scm
 tests/test-optional.scm
diff --git a/manual/Unit data-structures b/manual/Unit data-structures
index 6f3e8c1b..5412ea4d 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 00000000..df4b5591
--- /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 4a24457a..f0c19ceb 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 859a2891..8ab8b343 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)