Hi Felix,
Felix <fe...@call-with-current-continuation.org> writes:
> Thanks, Moritz. Here a few suggestions:
>
> - alist-update copies more of the argument list than necessary, it
> only has to copy up to the first matching entry
> - an entry for types.db is missing
thanks for the feedback, attached is an updated version of the patch. I
hope I got the types.db entry right!
By the way: I noticed that when an unknown comparison procedure is
passed alist-update! it will also accept non-alists, e.g.:
#;1> (alist-update! 123 123 '(x y z) =)
((123 . 123) x y z)
Whereas for example the default (eqv?) gives:
#;2> (alist-update! 123 123 '(x y z))
Error: (assv) bad argument type: x
Not sure if this is really a problem.
Moritz
>From fa0a758cf2bac89a5507c6aaf548527974e2ef1d Mon Sep 17 00:00:00 2001
From: Moritz Heidkamp <mor...@twoticketsplease.de>
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
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
