summaryrefslogtreecommitdiff
path: root/srfi
diff options
context:
space:
mode:
Diffstat (limited to 'srfi')
-rw-r--r--srfi/srfi-1.c103
-rw-r--r--srfi/srfi-1.h1
-rw-r--r--srfi/srfi-1.scm19
3 files changed, 104 insertions, 19 deletions
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index 76d5678af..c50b47850 100644
--- 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 3d23c0d4a..e53fd4e63 100644
--- 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 b22806ad2..171c98c1b 100644
--- 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)