[Guile-commits] 03/10: srfi-1: Rewrite 'assoc' in Scheme.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guile.

commit a15acbb828dd2e75b35bbc76d48858b230591639
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Jun 17 17:59:35 2020 +0200

    srfi-1: Rewrite 'assoc' in Scheme.
    
    * libguile/srfi-1.c (scm_srfi1_assoc): Remove.
    * libguile/srfi-1.h (scm_srfi1_assoc): Likewise.
    * module/srfi/srfi-1.scm (assoc): New procedure.
---
 libguile/srfi-1.c      | 31 -------------------------------
 libguile/srfi-1.h      |  1 -
 module/srfi/srfi-1.scm | 17 +++++++++++++++++
 3 files changed, 17 insertions(+), 32 deletions(-)

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 1651bcd..b18ba41 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -710,37 +710,6 @@ SCM_DEFINE (scm_srfi1_lset_difference_x, 
"lset-difference!", 2, 0, 1,
 }
 #undef FUNC_NAME
 
-
-SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
-           (SCM key, SCM alist, SCM pred),
-           "Behaves like @code{assq} but uses third argument @var{pred}\n"
-           "for key comparison.  If @var{pred} is not supplied,\n"
-           "@code{equal?} is used.  (Extended from R5RS.)\n")
-#define FUNC_NAME s_scm_srfi1_assoc
-{
-  SCM ls = alist;
-  scm_t_trampoline_2 equal_p;
-  if (SCM_UNBNDP (pred))
-    equal_p = equal_trampoline;
-  else
-    {
-      SCM_VALIDATE_PROC (SCM_ARG3, pred);
-      equal_p = scm_call_2;
-    }
-  for(; scm_is_pair (ls); ls = SCM_CDR (ls)) 
-    {
-      SCM tmp = SCM_CAR (ls);
-      SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
-                      "association list");
-      if (scm_is_true (equal_p (pred, key, SCM_CAR (tmp))))
-       return tmp;
-    }
-  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
-                  "association list");
-  return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
 SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
            (SCM pred, SCM list),
            "Partition the elements of @var{list} with predicate @var{pred}.\n"
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index 3faaaa4..9dafb9c 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -36,7 +36,6 @@ SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM 
pred);
 SCM_INTERNAL SCM scm_srfi1_length_plus (SCM lst);
 SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest);
 SCM_INTERNAL SCM scm_srfi1_list_copy (SCM lst);
-SCM_INTERNAL SCM scm_srfi1_assoc (SCM key, SCM alist, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list);
 SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list);
 SCM_INTERNAL SCM scm_srfi1_remove (SCM pred, SCM list);
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 1fc7a0e..680ee94 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -923,6 +923,23 @@ and those making the associations."
 
 ;;; Delete / assoc / member
 
+(define* (assoc key alist #:optional (= equal?))
+  "Behaves like @code{assq} but uses third argument @var{pred} for key
+comparison.  If @var{pred} is not supplied, @code{equal?} is
+used.  (Extended from R5RS.)"
+  (cond
+   ((eq? = eq?) (assq key alist))
+   ((eq? = eqv?) (assv key alist))
+   (else
+    (check-arg procedure? = assoc)
+    (let loop ((alist alist))
+      (and (pair? alist)
+           (let ((item (car alist)))
+             (check-arg pair? item assoc)
+             (if (= key (car item))
+                 item
+                 (loop (cdr alist)))))))))
+
 (define* (member x ls #:optional (= equal?))
   (cond
    ;; This might be performance-sensitive, so punt on the check here,