* srfi-1.scm: Load srfi-1 extension.

(map, map-in-order, for-each, member, assoc): Replaced by
primitives in srfi-1.c.
(map1): Defined as `map'.

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
+	(map, map-in-order, for-each, member, assoc): Replaced by
-	srfi-1.c.
+	primitives in srfi-1.c.
+	(map1): Defined as `map'.
 
 	* Makefile.am: Added rules for srfi-1.c.
 

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)
 {

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_SRFI1_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_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);
 

srfi/srfi-1.scm

@@ -609,16 +609,7 @@
 
 ;; Internal helper procedure.  Map `f' over the single list `ls'.
 ;;
-(define (map1 f ls)
+(define map1 map)
-  (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 (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))