diff options
-rw-r--r-- | srfi/ChangeLog | 5 | ||||
-rw-r--r-- | srfi/srfi-1.c | 36 | ||||
-rw-r--r-- | srfi/srfi-1.h | 5 | ||||
-rw-r--r-- | srfi/srfi-1.scm | 20 |
4 files changed, 41 insertions, 25 deletions
diff --git a/srfi/ChangeLog b/srfi/ChangeLog index ad303dc6b..be9c5924b 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,8 +1,9 @@ 2002-12-01 Mikael Djurfeldt <mdj@linnaeus> * srfi-1.scm: Load srfi-1 extension. - (map, map-in-order, for-each, member): Replaced by primitives in - srfi-1.c. + (map, map-in-order, for-each, member, assoc): Replaced by + primitives in srfi-1.c. + (map1): Defined as `map'. * Makefile.am: Added rules for srfi-1.c. diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index 8783e8384..35e9bc389 100644 --- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -288,11 +288,13 @@ equal_trampoline (SCM proc, SCM arg1, SCM arg2) SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0, (SCM x, SCM lst, SCM pred), "Return the first sublist of @var{lst} whose car is\n" - "@code{equal?} to @var{x} where the sublists of @var{lst} are\n" + "@var{equal?} to @var{x} where the sublists of @var{lst} are\n" "the non-empty lists returned by @code{(list-tail @var{lst}\n" "@var{k})} for @var{k} less than the length of @var{lst}. If\n" "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n" - "empty list) is returned.") + "empty list) is returned. If optional third argument @var{equal?}\n" + "isn't given, @code{equal?} is used for comparison.\n" + "(Extended from R5RS.)\n") #define FUNC_NAME s_scm_srfi1_member { scm_t_trampoline_2 equal_p; @@ -313,6 +315,36 @@ SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0, } #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 + { + equal_p = scm_trampoline_2 (pred); + SCM_ASSERT (equal_p, pred, 3, FUNC_NAME); + } + for(; SCM_CONSP (ls); ls = SCM_CDR (ls)) + { + SCM tmp = SCM_CAR (ls); + SCM_ASSERT_TYPE (SCM_CONSP (tmp), alist, SCM_ARG2, FUNC_NAME, + "association list"); + if (SCM_NFALSEP (equal_p (pred, SCM_CAR (tmp), key))) + 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 + void scm_init_srfi_1 (void) { diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h index b42f4f97a..5914ff742 100644 --- a/srfi/srfi-1.h +++ b/srfi/srfi-1.h @@ -58,9 +58,10 @@ # define SCM_SRFI1_API extern #endif -SCM_API SCM scm_srfi1_map (SCM proc, SCM arg1, SCM args); -SCM_API SCM scm_srfi1_for_each (SCM proc, SCM arg1, SCM args); +SCM_SRFI1_API SCM scm_srfi1_map (SCM proc, SCM arg1, SCM args); +SCM_SRFI1_API SCM scm_srfi1_for_each (SCM proc, SCM arg1, SCM args); SCM_SRFI1_API SCM scm_srfi1_member (SCM obj, SCM ls, SCM pred); +SCM_SRFI1_API SCM scm_srfi1_assoc (SCM key, SCM alist, SCM pred); SCM_SRFI1_API void scm_init_srfi_1 (void); diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index f1208e37e..fe6e7abe9 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -609,16 +609,7 @@ ;; Internal helper procedure. Map `f' over the single list `ls'. ;; -(define (map1 f ls) - (if (null? ls) - ls - (let ((ret (list (f (car ls))))) - (let lp ((ls (cdr ls)) (p ret)) ; tail pointer - (if (null? ls) - ret - (begin - (set-cdr! p (list (f (car ls)))) - (lp (cdr ls) (cdr p)))))))) +(define map1 map) (define (append-map f clist1 . rest) (if (null? rest) @@ -884,15 +875,6 @@ ;;; Association lists -(define (assoc key alist . rest) - (let ((k= (if (pair? rest) (car rest) equal?))) - (let lp ((a alist)) - (if (null? a) - #f - (if (k= key (caar a)) - (car a) - (lp (cdr a))))))) - (define (alist-cons key datum alist) (acons key datum alist)) |