summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--srfi/ChangeLog5
-rw-r--r--srfi/srfi-1.c36
-rw-r--r--srfi/srfi-1.h5
-rw-r--r--srfi/srfi-1.scm20
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))