From 110348aee92a143f66a905f9b631d190e374e15e Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Dec 2003 21:12:20 +0000 Subject: [PATCH] (count): Rewrite in C, avoiding non-tail recursion. --- srfi/srfi-1.c | 103 ++++++++++++++++++++++++++++++++++++++++++++++++ srfi/srfi-1.h | 1 + srfi/srfi-1.scm | 19 --------- 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)