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

SRFI-1: Rewrite `filter-map' in Scheme.

Browse source 
This partially reverts commit c16359466b
(Thu Mar 17 2005).

* libguile/srfi-1.c (scm_srfi1_filter_map): Remove.
* libguile/srfi-1.h (scm_srfi1_filter_map): Ditto.

* module/srfi/srfi-1.scm (filter-map): New procedure.
This commit is contained in:
Ludovic Courtès 2010-10-08 11:03:51 +02:00
parent a6505cb49c
commit 58ee1beabe
3 changed files with 22 additions and 110 deletions
Download patch file Download diff file Expand all files Collapse all files

109
libguile/srfi-1.c
View file

@ -616,115 +616,6 @@ 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_is_null (rest))
{
/* one list */
SCM_VALIDATE_PROC (SCM_ARG1, proc);
for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
{
elem = scm_call_1 (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 */
end_list1:
lst = list1;
argnum = 2;
}
else if (scm_is_null (SCM_CDR (rest)))
{
/* two lists */
SCM list2 = SCM_CAR (rest);
SCM_VALIDATE_PROC (SCM_ARG1, proc);
for (;;)
{
if (! scm_is_pair (list1))
goto end_list1;
if (! scm_is_pair (list2))
{
lst = list2;
argnum = 3;
goto check_lst_and_done;
}
elem = scm_call_2 (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 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 proc, 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 proc */
SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* 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
libguile/srfi-1.h
View file

@ -34,7 +34,6 @@ SCM_INTERNAL SCM scm_srfi1_delete_x (SCM x, SCM lst, SCM pred);
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_drop_right (SCM lst, SCM n);
SCM_INTERNAL SCM scm_srfi1_filter_map (SCM proc, SCM list1, SCM rest);
SCM_INTERNAL SCM scm_srfi1_find (SCM pred, SCM lst);
SCM_INTERNAL SCM scm_srfi1_find_tail (SCM pred, SCM lst);
SCM_INTERNAL SCM scm_srfi1_length_plus (SCM lst);

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

@ -511,6 +511,28 @@ has just one element then that's the return value."
;; OPTIMIZE-ME: Re-use cons cells of list1
(define map! map)
(define (filter-map proc list1 . rest)
"Apply PROC to to the elements of LIST1... and return a list of the
results as per SRFI-1 `map', except that any #f results are omitted from
the list returned."
(if (null? rest)
(let lp ((l list1)
(rl '()))
(if (null? l)
(reverse! rl)
(let ((res (proc (car l))))
(if res
(lp (cdr l) (cons res rl))
(lp (cdr l) rl)))))
(let lp ((l (cons list1 rest))
(rl '()))
(if (any1 null? l)
(reverse! rl)
(let ((res (apply proc (map1 car l))))
(if res
(lp (map1 cdr l) (cons res rl))
(lp (map1 cdr l) rl)))))))
(define (pair-for-each f clist1 . rest)
(if (null? rest)
(let lp ((l clist1))