On Sat, May 03, 2014 at 10:45:04PM -0700, Evan Hanson wrote: > @ -hackers: I think `alist-ref`'s fallback search function should match > the behavior of core's versions. Objections?
I agree. Here's a patch to do that. I've taken the opportunity to get rid of the square brackets in this procedure's definition, too. Cheers, Peter -- http://www.more-magic.net
>From 68debfa6e9321bc99bcc6ea9ee23296d610a0440 Mon Sep 17 00:00:00 2001 From: Peter Bex <[email protected]> Date: Sun, 4 May 2014 11:27:10 +0200 Subject: [PATCH] For consistency, raise an exception from alist-ref when passed a non-list. Problem reported by Andy Bennett, solution suggested by Evan Hanson. --- NEWS | 6 ++++++ data-structures.scm | 26 +++++++++++++++----------- tests/data-structures-tests.scm | 14 ++++++++++++++ 3 files changed, 35 insertions(+), 11 deletions(-) diff --git a/NEWS b/NEWS index a750718..984f771 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,9 @@ +4.9.1 + +- Core libraries + - alist-ref from unit data-structures now gives an error when passed + a non-list, for consistency with assv/assq/assoc. + 4.9.0 - Security fixes diff --git a/data-structures.scm b/data-structures.scm index 8f62ad9..bf114af 100644 --- a/data-structures.scm +++ b/data-structures.scm @@ -233,18 +233,22 @@ (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] - [(eq? equal? cmp) assoc] - [else + (let* ((aq (cond ((eq? eq? cmp) assq) + ((eq? eqv? cmp) assv) + ((eq? equal? cmp) assoc) + (else (lambda (x lst) - (let loop ([lst lst]) - (and (pair? lst) - (let ([a (##sys#slot lst 0)]) - (if (and (pair? a) (cmp (##sys#slot a 0) x)) - a - (loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ] - [item (aq x lst)] ) + (let loop ((lst lst)) + (cond + ((null? lst) #f) + ((pair? lst) + (let ((a (##sys#slot lst 0))) + (##sys#check-pair a 'alist-ref) + (if (cmp (##sys#slot a 0) x) + a + (loop (##sys#slot lst 1)) ) )) + (else (error 'alist-ref "bad argument type" lst)) ) ) ) ) ) ) + (item (aq x lst)) ) (if item (##sys#slot item 1) default) ) ) diff --git a/tests/data-structures-tests.scm b/tests/data-structures-tests.scm index 8c160a8..51c25a9 100644 --- a/tests/data-structures-tests.scm +++ b/tests/data-structures-tests.scm @@ -7,6 +7,20 @@ ((_ expr) (assert (handle-exceptions _ #t expr #f))))) +(assert (equal? 'bar (alist-ref 'foo '((foo . bar))))) +(assert (not (alist-ref 'foo '()))) +(assert (not (alist-ref 'foo '((bar . foo))))) +(assert-error (alist-ref 'foo 'bar)) +(assert-error (alist-ref 'foo '(bar))) + +(let ((cmp (lambda (x y) (eqv? x y)))) + (assert (equal? 'bar (alist-ref 'foo '((foo . bar)) cmp))) + (assert (not (alist-ref 'foo '() cmp))) + (assert (not (alist-ref 'foo '((bar . foo)) cmp))) + (assert-error (alist-ref 'foo 'bar cmp)) + (assert-error (alist-ref 'foo '(bar) cmp))) + + (let ((alist '((foo . 123) ("bar" . "baz")))) (alist-update! 'foo 999 alist) (assert (= (alist-ref 'foo alist) 999)) -- 1.7.10.4
_______________________________________________ Chicken-users mailing list [email protected] https://lists.nongnu.org/mailman/listinfo/chicken-users
