mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

srfi-1 count: move from C to Scheme

Browse source 
* libguile/srfi-1.c (scm_srfi1_count): delete.
* libguile/srfi-1.h (scm_srfi1_count): delete.
* module/srfi/srfi-1.scm: add count.
This commit is contained in:
Rob Browning 2024-07-17 21:08:01 -05:00
parent 372a52e6aa
commit 58246aee24
3 changed files with 21 additions and 100 deletions
Download patch file Download diff file Expand all files Collapse all files

99
libguile/srfi-1.c
View file

@ -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"

1
libguile/srfi-1.h
View file

@ -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);

21
module/srfi/srfi-1.scm
View file

@ -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