mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-14 15:40:19 +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"