(count): Rewrite in C, avoiding non-tail recursion.

diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index 76d5678..c50b478 100644 (file)
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -71,6 +71,109 @@ SCM_REGISTER_PROC (s_srfi1_concatenate,   "concatenate",  1, 0, 0, scm_append);
 SCM_REGISTER_PROC (s_srfi1_concatenate_x, "concatenate!", 1, 0, 0, scm_append_x);
 
 
+SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1,
+            (SCM pred, SCM lst1, SCM rest),
+           "Return a count of the number of times @var{pred} returns true\n"
+           "when called on elements from the given lists.\n"
+           "\n"
+           "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
+           "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
+           "corresponding @var{lst1} @dots{} @var{lstN}.  The first call is\n"
+           "with the first element of each list, the second with the second\n"
+           "element from each, and so on.\n"
+           "\n"
+           "Counting stops when the end of the shortest list is reached.\n"
+           "At least one list must be non-circular.")
+#define FUNC_NAME s_scm_srfi1_count
+{
+  long  count;
+  SCM_VALIDATE_REST_ARGUMENT (rest);
+
+  count = 0;
+
+  if (SCM_NULLP (rest))
+    {
+      /* one list */
+      scm_t_trampoline_1 pred_tramp;
+      pred_tramp = scm_trampoline_1 (pred);
+      SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+      for ( ; SCM_CONSP (lst1); lst1 = SCM_CDR (lst1))
+        count += ! SCM_FALSEP (pred_tramp (pred, SCM_CAR (lst1)));
+
+    end_lst1:
+      SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst1), lst1, SCM_ARG2, FUNC_NAME,
+                       "list");
+    }
+  else if (SCM_CONSP (rest) && SCM_NULLP (SCM_CDR (rest)))
+    {
+      /* two lists */
+      scm_t_trampoline_2 pred_tramp;
+      SCM lst2;
+
+      pred_tramp = scm_trampoline_2 (pred);
+      SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+      lst2 = SCM_CAR (rest);
+      for (;;)
+        {
+          if (! SCM_CONSP (lst1))
+            goto end_lst1;
+          if (! SCM_CONSP (lst2))
+            {
+              SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst2), lst2, SCM_ARG3,
+                               FUNC_NAME, "list");
+              break;
+            }
+          count += ! SCM_FALSEP (pred_tramp
+                                 (pred, SCM_CAR (lst1), SCM_CAR (lst2)));
+          lst1 = SCM_CDR (lst1);
+          lst2 = SCM_CDR (lst2);
+        }
+    }
+  else
+    {
+      /* three or more lists */
+      SCM  lstlst, args, l, a, lst;
+      int  argnum;
+
+      /* lstlst is a list of the list arguments */
+      lstlst = scm_cons (lst1, rest);
+
+      /* args is the argument list to pass to pred, same length as lstlst,
+         re-used for each call */
+      args = SCM_EOL;
+      for (l = lstlst; SCM_CONSP (l); l = SCM_CDR (l))
+        args = scm_cons (SCM_BOOL_F, args);
+
+      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_CONSP (l);
+               l = SCM_CDR (l), a = SCM_CDR (a), argnum++)
+            {
+              lst = SCM_CAR (l);  /* list argument */
+              if (! SCM_CONSP (lst))
+                {
+                  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst,
+                                   argnum, FUNC_NAME, "list");
+                  goto done;
+                }
+              SCM_SETCAR (a, SCM_CAR (lst));  /* arg for pred */
+              SCM_SETCAR (l, SCM_CDR (lst));  /* keep rest of lst */
+            }
+
+          count += ! SCM_FALSEP (scm_apply (pred, args, SCM_EOL));
+        }
+    }
+ done:
+  return SCM_MAKINUM (count);
+}
+#undef FUNC_NAME
+
+
 SCM_DEFINE (scm_srfi1_delete, "delete", 2, 1, 0,
             (SCM x, SCM lst, SCM pred),
            "Return a list containing the elements of @var{lst} but with\n"

diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h
index 3d23c0d..e53fd4e 100644 (file)
--- a/srfi/srfi-1.h
+++ b/srfi/srfi-1.h
@@ -32,6 +32,7 @@
 # define SCM_SRFI1_API extern
 #endif
 
+SCM_SRFI1_API SCM scm_srfi1_count (SCM pred, SCM lst1, SCM rest);
 SCM_SRFI1_API SCM scm_srfi1_delete (SCM x, SCM lst, SCM pred);
 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);

diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm
index b22806a..171c98c 100644 (file)
--- a/srfi/srfi-1.scm
+++ b/srfi/srfi-1.scm
@@ -442,25 +442,6 @@
   (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)
          (map1 fifth l)))
 
-(define (count pred clist1 . rest)
-  (if (null? rest)
-      (count1 pred clist1)
-      (let lp ((lists (cons clist1 rest)))
-       (cond ((any1 null? lists)
-              0)
-             (else
-              (if (apply pred (map1 car lists))
-                (+ 1 (lp (map1 cdr lists)))
-                (lp (map1 cdr lists))))))))
-
-(define (count1 pred clist)
-  (let lp ((result 0) (rest clist))
-    (if (null? rest)
-       result
-       (if (pred (car rest))
-           (lp (+ 1 result) (cdr rest))
-           (lp result (cdr rest))))))
-
 ;;; Fold, unfold & map
 
 (define (fold kons knil list1 . rest)