summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--srfi/srfi-1.c112
-rw-r--r--srfi/srfi-1.h1
-rw-r--r--srfi/srfi-1.scm19
3 files changed, 113 insertions, 19 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"
diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h
index b13927b6d..467e0251f 100644
--- a/srfi/srfi-1.h
+++ b/srfi/srfi-1.h
@@ -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);
diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm
index 3676f9b8f..4ddf12d99 100644
--- a/srfi/srfi-1.scm
+++ b/srfi/srfi-1.scm
@@ -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)