[Guile-commits] 09/17: srfi-1 count: move from C to Scheme

[Rob Browning]

rlb pushed a commit to branch main
in repository guile.

commit 58246aee24be908307117b3f8ae8040460f86ce7
Author: Rob Browning <rlb@defaultvalue.org>
AuthorDate: Wed Jul 17 21:08:01 2024 -0500

    srfi-1 count: move from C to Scheme
    
    * libguile/srfi-1.c (scm_srfi1_count): delete.
    * libguile/srfi-1.h (scm_srfi1_count): delete.
    * module/srfi/srfi-1.scm: add count.
---
 libguile/srfi-1.c      | 99 --------------------------------------------------
 libguile/srfi-1.h      |  1 -
 module/srfi/srfi-1.scm | 21 +++++++++++
 3 files changed, 21 insertions(+), 100 deletions(-)

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 798f4e7bb..aaa156d3e 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -85,105 +85,6 @@ list_copy_part (SCM lst, int count, SCM *dst)
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1,
-            (SCM pred, SCM list1, 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{list1} @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   lst;
-  int   argnum;
-  SCM_VALIDATE_REST_ARGUMENT (rest);
-
-  count = 0;
-
-  if (scm_is_null (rest))
-    {
-      /* one list */
-      SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, 
FUNC_NAME);
-
-      for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
-        count += scm_is_true (scm_call_1 (pred, SCM_CAR (list1)));
-
-      /* check below that list1 is a proper list, and done */
-    end_list1:
-      lst = list1;
-      argnum = 2;
-    }
-  else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
-    {
-      /* two lists */
-      SCM list2;
-
-      SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, 
FUNC_NAME);
-
-      list2 = SCM_CAR (rest);
-      for (;;)
-        {
-          if (! scm_is_pair (list1))
-            goto end_list1;
-          if (! scm_is_pair (list2))
-            {
-              lst = list2;
-              argnum = 3;
-              break;
-            }
-          count += scm_is_true (scm_call_2
-                               (pred, SCM_CAR (list1), SCM_CAR (list2)));
-          list1 = SCM_CDR (list1);
-          list2 = SCM_CDR (list2);
-        }
-    }
-  else
-    {
-      /* three or more lists */
-      SCM  vec, args, a;
-      size_t  len, i;
-
-      /* vec is the list arguments */
-      vec = scm_vector (scm_cons (list1, rest));
-      len = SCM_SIMPLE_VECTOR_LENGTH (vec);
-
-      /* args is the argument list to pass to pred, same length as vec,
-         re-used for each call */
-      args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
-
-      for (;;)
-        {
-          /* first elem of each list in vec into args, and step those
-             vec entries onto their next element */
-          for (i = 0, a = args, argnum = 2;
-               i < len;
-               i++, a = SCM_CDR (a), argnum++)
-            {
-              lst = SCM_SIMPLE_VECTOR_REF (vec, i);  /* list argument */
-              if (! scm_is_pair (lst))
-                goto check_lst_and_done;
-              SCM_SETCAR (a, SCM_CAR (lst));  /* arg for pred */
-              SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst));  /* rest of lst */
-            }
-
-          count += scm_is_true (scm_apply_0 (pred, args));
-        }
-    }
-
- check_lst_and_done:
-  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
-  return scm_from_long (count);
-}
-#undef FUNC_NAME
-
-
 SCM_DEFINE (scm_srfi1_delete_duplicates, "delete-duplicates", 1, 1, 0,
            (SCM lst, SCM pred),
            "Return a list containing the elements of @var{lst} but without\n"
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index 329988745..9a4eeef6f 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -24,7 +24,6 @@
 
 #include "libguile/scm.h"
 
-SCM_INTERNAL SCM scm_srfi1_count (SCM pred, SCM list1, SCM rest);
 SCM_INTERNAL SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred);
 SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest);
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 31623cdc6..2ecdcd7ff 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -546,6 +546,27 @@ result.  This is equivalent to @code{(append! (reverse!  
@var{rev-head})
   (values (map first l) (map second l) (map third l) (map fourth l)
          (map fifth l)))
 
+(define count
+  (case-lambda
+    ((pred lst)
+     (let lp ((lst lst) (c 0))
+       (if (null? lst)
+           c
+           (lp (cdr lst) (if (pred (car lst)) (1+ c) c)))))
+    ((pred l1 l2)
+     (let lp ((l1 l1) (l2 l2) (c 0))
+       (if (or (null? l1) (null? l2))
+           c
+           (lp (cdr l1) (cdr l2)
+               (if (pred (car l1) (car l2)) (1+ c) c)))))
+    ((pred lst . lists)
+     (let lp ((lst lst) (lists lists) (c 0))
+       (if (or (null? lst) (any null? lists))
+           c
+           (lp (cdr lst)
+               (map cdr lists)
+               (if (apply pred (car lst) (map car lists)) (1+ c) c)))))))
+
 ;;; Fold, unfold & map
 
 (define fold