summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/srfi-1.c31
-rw-r--r--libguile/srfi-1.h1
-rw-r--r--module/srfi/srfi-1.scm17
3 files changed, 17 insertions, 32 deletions
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 1651bcd5b..b18ba41c7 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 3faaaa428..9dafb9c0d 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 1fc7a0e26..680ee94b5 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,