(filter-map): Rewrite in C.

diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index 8bf077b..256c963 100644 (file)
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -496,6 +496,118 @@ SCM_DEFINE (scm_srfi1_drop_right, "drop-right", 2, 0, 0,
 #undef FUNC_NAME
 
 
+SCM_DEFINE (scm_srfi1_filter_map, "filter-map", 2, 0, 1,
+            (SCM proc, SCM list1, SCM rest),
+           "Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
+           "return a list of the results as per SRFI-1 @code{map}, except\n"
+           "that any @code{#f} results are omitted from the list returned.")
+#define FUNC_NAME s_scm_srfi1_filter_map
+{
+  SCM  ret, *loc, elem, newcell, lst;
+  int  argnum;
+
+  SCM_VALIDATE_REST_ARGUMENT (rest);
+
+  ret = SCM_EOL;
+  loc = &ret;
+
+  if (SCM_NULLP (rest))
+    {
+      /* one list */
+      scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
+      SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+      for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
+        {
+          elem = proc_tramp (proc, SCM_CAR (list1));
+          if (scm_is_true (elem))
+            {
+              newcell = scm_cons (elem, SCM_EOL);
+              *loc = newcell;
+              loc = SCM_CDRLOC (newcell);
+            }
+        }
+
+      /* check below that list1 is a proper list, and done */
+      lst = list1;
+      argnum = 2;
+    }
+  else if (SCM_NULLP (SCM_CDR (rest)))
+    {
+      /* two lists */
+      scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
+      SCM list2 = SCM_CAR (rest);
+      SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+      for (;;)
+        {
+          if (! scm_is_pair (list1))
+            {
+              lst = list1;
+              argnum = 2;
+              goto check_lst_and_done;
+            }
+          if (! scm_is_pair (list2))
+            {
+              lst = list2;
+              argnum = 3;
+              goto check_lst_and_done;
+            }
+          elem = proc_tramp (proc, SCM_CAR (list1), SCM_CAR (list2));
+          if (scm_is_true (elem))
+            {
+              newcell = scm_cons (elem, SCM_EOL);
+              *loc = newcell;
+              loc = SCM_CDRLOC (newcell);
+            }
+          list1 = SCM_CDR (list1);
+          list2 = SCM_CDR (list2);
+        }
+    }
+  else
+    {
+      /* three or more lists */
+      SCM  lstlst, args, l, a;
+
+      /* lstlst is a list of the list arguments */
+      lstlst = scm_cons (list1, rest);
+
+      /* args is the argument list to pass to proc, same length as lstlst,
+         re-used for each call */
+      args = scm_list_copy (lstlst);
+
+      for (;;)
+        {
+          /* first elem of each list in lstlst into args, and step those
+             lstlst entries onto their next element */
+          for (l = lstlst, a = args, argnum = 2;
+               scm_is_pair (l);
+               l = SCM_CDR (l), a = SCM_CDR (a), argnum++)
+            {
+              lst = SCM_CAR (l);  /* list argument */
+              if (! scm_is_pair (lst))
+                goto check_lst_and_done;
+              SCM_SETCAR (a, SCM_CAR (lst));  /* arg for proc */
+              SCM_SETCAR (l, SCM_CDR (lst));  /* keep rest of lst */
+            }
+
+          elem = scm_apply (proc, args, SCM_EOL);
+          if (scm_is_true (elem))
+            {
+              newcell = scm_cons (elem, SCM_EOL);
+              *loc = newcell;
+              loc = SCM_CDRLOC (newcell);
+            }
+        }
+    }
+
+ check_lst_and_done:
+  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
+  return ret;
+}
+#undef FUNC_NAME
+
+
 SCM_DEFINE (scm_srfi1_find, "find", 2, 0, 0,
             (SCM pred, SCM lst),
            "Return the first element of @var{lst} which satisfies the\n"

diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h
index b13927b..467e025 100644 (file)
--- a/srfi/srfi-1.h
+++ b/srfi/srfi-1.h
@@ -38,6 +38,7 @@ SCM_SRFI1_API SCM scm_srfi1_delete_x (SCM x, SCM lst, SCM pred);
 SCM_SRFI1_API SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred);
 SCM_SRFI1_API SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred);
 SCM_SRFI1_API SCM scm_srfi1_drop_right (SCM lst, SCM n);
+SCM_SRFI1_API SCM scm_srfi1_filter_map (SCM proc, SCM list1, SCM rest);
 SCM_SRFI1_API SCM scm_srfi1_find (SCM pred, SCM lst);
 SCM_SRFI1_API SCM scm_srfi1_find_tail (SCM pred, SCM lst);
 SCM_SRFI1_API SCM scm_srfi1_length_plus (SCM lst);

diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm
index 3676f9b..4ddf12d 100644 (file)
--- a/srfi/srfi-1.scm
+++ b/srfi/srfi-1.scm
@@ -515,25 +515,6 @@
          (apply f l)
          (lp (map1 cdr l)))))))
 
-(define (filter-map f clist1 . rest)
-  (if (null? rest)
-    (let lp ((l clist1)
-            (rl '()))
-      (if (null? l)
-       (reverse! rl)
-       (let ((res (f (car l))))
-         (if res
-           (lp (cdr l) (cons res rl))
-           (lp (cdr l) rl)))))
-    (let lp ((l (cons clist1 rest))
-            (rl '()))
-      (if (any1 null? l)
-       (reverse! rl)
-       (let ((res (apply f (map1 car l))))
-         (if res
-           (lp (map1 cdr l) (cons res rl))
-           (lp (map1 cdr l) rl)))))))
-
 ;;; Searching
 
 (define (take-while pred ls)