>From 68debfa6e9321bc99bcc6ea9ee23296d610a0440 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
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