diff options
-rw-r--r-- | libguile/srfi-1.c | 31 | ||||
-rw-r--r-- | libguile/srfi-1.h | 1 | ||||
-rw-r--r-- | 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 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, |