summaryrefslogtreecommitdiff
path: root/srfi/srfi-1.c
diff options
context:
space:
mode:
authorKevin Ryde <user42@zip.com.au>2005-03-17 23:15:19 +0000
committerKevin Ryde <user42@zip.com.au>2005-03-17 23:15:19 +0000
commitc16359466bcc3f2ebf6d750c069f787f629fc625 (patch)
tree36da009c7b8717c6a65a582d99c221d57a0ca859 /srfi/srfi-1.c
parent8ff3ca467c45642f73b998c97f13a340d018d9bd (diff)
downloadguile-c16359466bcc3f2ebf6d750c069f787f629fc625.tar.gz
(filter-map): Rewrite in C.
Diffstat (limited to 'srfi/srfi-1.c')
-rw-r--r--srfi/srfi-1.c112
1 files changed, 112 insertions, 0 deletions
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index 8bf077b43..256c9633e 100644
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -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"