summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/srfi-1.c109
-rw-r--r--libguile/srfi-1.h1
-rw-r--r--module/srfi/srfi-1.scm22
3 files changed, 22 insertions, 110 deletions
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 2fb677a7a..6d5a1ab90 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -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"
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index ddc8d0a27..87aa98981 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -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);
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index d6cefcdbd..5bcc3611c 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -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))