~ chicken-core (chicken-5) 1b00bdfd5cd3319c26e1ad911caea31803f0bc07

commit 1b00bdfd5cd3319c26e1ad911caea31803f0bc07
Author:     Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Sun May 4 11:27:10 2014 +0200
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Mon May 5 07:34:03 2014 +1200

    For consistency, raise an exception from alist-ref when passed a non-list.
    
    Problem reported by Andy Bennett, solution suggested by Evan Hanson.
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/NEWS b/NEWS
index a7507186..984f771b 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 8f62ad9c..51d7e142 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 8c160a82..51c25a9e 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))