mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 17:20:29 +02:00
Code Activity

(filter-map): Rewrite in C.

Browse source
This commit is contained in:
Kevin Ryde 2005-03-17 23:15:19 +00:00
parent 8ff3ca467c
commit c16359466b
3 changed files with 113 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

112
srfi/srfi-1.c
View file

@ -496,6 +496,118 @@ SCM_DEFINE (scm_srfi1_drop_right, "drop-right", 2, 0, 0,
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_filter_map, "filter-map", 2, 0, 1,
(SCM proc, SCM list1, SCM rest),
"Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
"return a list of the results as per SRFI-1 @code{map}, except\n"
"that any @code{#f} results are omitted from the list returned.")
#define FUNC_NAME s_scm_srfi1_filter_map
{
SCM ret, *loc, elem, newcell, lst;
int argnum;
SCM_VALIDATE_REST_ARGUMENT (rest);
ret = SCM_EOL;
loc = &ret;
if (SCM_NULLP (rest))
{
/* one list */
scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
{
elem = proc_tramp (proc, SCM_CAR (list1));
if (scm_is_true (elem))
{
newcell = scm_cons (elem, SCM_EOL);
*loc = newcell;
loc = SCM_CDRLOC (newcell);
}
}
/* check below that list1 is a proper list, and done */
lst = list1;
argnum = 2;
}
else if (SCM_NULLP (SCM_CDR (rest)))
{
/* two lists */
scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
SCM list2 = SCM_CAR (rest);
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
for (;;)
{
if (! scm_is_pair (list1))
{
lst = list1;
argnum = 2;
goto check_lst_and_done;
}
if (! scm_is_pair (list2))
{
lst = list2;
argnum = 3;
goto check_lst_and_done;
}
elem = proc_tramp (proc, SCM_CAR (list1), SCM_CAR (list2));
if (scm_is_true (elem))
{
newcell = scm_cons (elem, SCM_EOL);
*loc = newcell;
loc = SCM_CDRLOC (newcell);
}
list1 = SCM_CDR (list1);
list2 = SCM_CDR (list2);
}
}
else
{
/* three or more lists */
SCM lstlst, args, l, a;
/* lstlst is a list of the list arguments */
lstlst = scm_cons (list1, rest);
/* args is the argument list to pass to proc, same length as lstlst,
re-used for each call */
args = scm_list_copy (lstlst);
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_is_pair (l);
l = SCM_CDR (l), a = SCM_CDR (a), argnum++)
{
lst = SCM_CAR (l); /* list argument */
if (! scm_is_pair (lst))
goto check_lst_and_done;
SCM_SETCAR (a, SCM_CAR (lst)); /* arg for proc */
SCM_SETCAR (l, SCM_CDR (lst)); /* keep rest of lst */
}
elem = scm_apply (proc, args, SCM_EOL);
if (scm_is_true (elem))
{
newcell = scm_cons (elem, SCM_EOL);
*loc = newcell;
loc = SCM_CDRLOC (newcell);
}
}
}
check_lst_and_done:
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
return ret;
}
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_find, "find", 2, 0, 0,
(SCM pred, SCM lst),
"Return the first element of @var{lst} which satisfies the\n"

1
srfi/srfi-1.h
View file

@ -38,6 +38,7 @@ 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);
SCM_SRFI1_API SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred);
SCM_SRFI1_API SCM scm_srfi1_drop_right (SCM lst, SCM n);
SCM_SRFI1_API SCM scm_srfi1_filter_map (SCM proc, SCM list1, SCM rest);
SCM_SRFI1_API SCM scm_srfi1_find (SCM pred, SCM lst);
SCM_SRFI1_API SCM scm_srfi1_find_tail (SCM pred, SCM lst);
SCM_SRFI1_API SCM scm_srfi1_length_plus (SCM lst);

19
srfi/srfi-1.scm
View file

@ -515,25 +515,6 @@
(apply f l)
(lp (map1 cdr l)))))))
(define (filter-map f clist1 . rest)
(if (null? rest)
(let lp ((l clist1)
(rl '()))
(if (null? l)
(reverse! rl)
(let ((res (f (car l))))
(if res
(lp (cdr l) (cons res rl))
(lp (cdr l) rl)))))
(let lp ((l (cons clist1 rest))
(rl '()))
(if (any1 null? l)
(reverse! rl)
(let ((res (apply f (map1 car l))))
(if res
(lp (map1 cdr l) (cons res rl))
(lp (map1 cdr l) rl)))))))
;;; Searching
(define (take-while pred ls)