1 /* srfi-1.c --- SRFI-1 procedures for Guile
3 * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006, 2008, 2009, 2010
4 * Free Software Foundation, Inc.
6 * This library is free software; you can redistribute it and/or
7 * modify it under the terms of the GNU Lesser General Public License
8 * as published by the Free Software Foundation; either version 3 of
9 * the License, or (at your option) any later version.
11 * This library is distributed in the hope that it will be useful, but
12 * WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 * Lesser General Public License for more details.
16 * You should have received a copy of the GNU Lesser General Public
17 * License along with this library; if not, write to the Free Software
18 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
30 /* The intent of this file is to gradually replace those Scheme
31 * procedures in srfi-1.scm which extends core primitive procedures,
32 * so that using srfi-1 won't have performance penalties.
34 * Please feel free to contribute any new replacements!
38 srfi1_ilength (SCM sx
)
45 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
46 if (!scm_is_pair (hare
)) return -2;
49 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
50 if (!scm_is_pair (hare
)) return -2;
53 /* For every two steps the hare takes, the tortoise takes one. */
54 tortoise
= SCM_CDR(tortoise
);
56 while (! scm_is_eq (hare
, tortoise
));
58 /* If the tortoise ever catches the hare, then the list must contain
64 equal_trampoline (SCM proc
, SCM arg1
, SCM arg2
)
66 return scm_equal_p (arg1
, arg2
);
69 /* list_copy_part() copies the first COUNT cells of LST, puts the result at
70 *dst, and returns the SCM_CDRLOC of the last cell in that new list.
72 This function is designed to be careful about LST possibly having changed
73 in between the caller deciding what to copy, and the copy actually being
74 done here. The COUNT ensures we terminate if LST has become circular,
75 SCM_VALIDATE_CONS guards against a cdr in the list changed to some
80 list_copy_part (SCM lst
, int count
, SCM
*dst
)
81 #define FUNC_NAME "list_copy_part"
84 for ( ; count
> 0; count
--)
86 SCM_VALIDATE_CONS (SCM_ARGn
, lst
);
87 c
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
97 SCM_DEFINE (scm_srfi1_alist_copy
, "alist-copy", 1, 0, 0,
99 "Return a copy of @var{alist}, copying both the pairs comprising\n"
100 "the list and those making the associations.")
101 #define FUNC_NAME s_scm_srfi1_alist_copy
103 SCM ret
, *p
, elem
, c
;
105 /* ret is the list to return. p is where to append to it, initially &ret
106 then SCM_CDRLOC of the last pair. */
110 for ( ; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
112 elem
= SCM_CAR (alist
);
114 /* each element of alist must be a pair */
115 SCM_ASSERT_TYPE (scm_is_pair (elem
), alist
, SCM_ARG1
, FUNC_NAME
,
118 c
= scm_cons (scm_cons (SCM_CAR (elem
), SCM_CDR (elem
)), SCM_EOL
);
123 /* alist must be a proper list */
124 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (alist
), alist
, SCM_ARG1
, FUNC_NAME
,
132 SCM_DEFINE (scm_srfi1_append_reverse
, "append-reverse", 2, 0, 0,
133 (SCM revhead
, SCM tail
),
134 "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
135 "result. This is equivalent to @code{(append (reverse\n"
136 "@var{rev-head}) @var{tail})}, but its implementation is more\n"
140 "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
142 #define FUNC_NAME s_scm_srfi1_append_reverse
144 while (scm_is_pair (revhead
))
146 /* copy first element of revhead onto front of tail */
147 tail
= scm_cons (SCM_CAR (revhead
), tail
);
148 revhead
= SCM_CDR (revhead
);
150 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead
), revhead
, SCM_ARG1
, FUNC_NAME
,
157 SCM_DEFINE (scm_srfi1_append_reverse_x
, "append-reverse!", 2, 0, 0,
158 (SCM revhead
, SCM tail
),
159 "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
160 "result. This is equivalent to @code{(append! (reverse!\n"
161 "@var{rev-head}) @var{tail})}, but its implementation is more\n"
165 "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
168 "@var{rev-head} may be modified in order to produce the result.")
169 #define FUNC_NAME s_scm_srfi1_append_reverse_x
173 while (scm_is_pair (revhead
))
175 /* take the first cons cell from revhead */
177 revhead
= SCM_CDR (revhead
);
179 /* make it the new start of tail, appending the previous */
180 SCM_SETCDR (newtail
, tail
);
183 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead
), revhead
, SCM_ARG1
, FUNC_NAME
,
190 SCM_DEFINE (scm_srfi1_break
, "break", 2, 0, 0,
192 "Return two values, the longest initial prefix of @var{lst}\n"
193 "whose elements all fail the predicate @var{pred}, and the\n"
194 "remainder of @var{lst}.\n"
196 "Note that the name @code{break} conflicts with the @code{break}\n"
197 "binding established by @code{while}. Applications wanting to\n"
198 "use @code{break} from within a @code{while} loop will need to\n"
199 "make a new define under a different name.")
200 #define FUNC_NAME s_scm_srfi1_break
204 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
208 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
210 SCM elem
= SCM_CAR (lst
);
211 if (scm_is_true (scm_call_1 (pred
, elem
)))
214 /* want this elem, tack it onto the end of ret */
215 *p
= scm_cons (elem
, SCM_EOL
);
218 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
221 return scm_values (scm_list_2 (ret
, lst
));
226 SCM_DEFINE (scm_srfi1_break_x
, "break!", 2, 0, 0,
228 "Return two values, the longest initial prefix of @var{lst}\n"
229 "whose elements all fail the predicate @var{pred}, and the\n"
230 "remainder of @var{lst}. @var{lst} may be modified to form the\n"
232 #define FUNC_NAME s_scm_srfi1_break_x
236 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
239 for (upto
= lst
; scm_is_pair (upto
); upto
= SCM_CDR (upto
))
241 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (upto
))))
244 /* want this element */
245 p
= SCM_CDRLOC (upto
);
247 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
251 return scm_values (scm_list_2 (lst
, upto
));
256 SCM_DEFINE (scm_srfi1_car_plus_cdr
, "car+cdr", 1, 0, 0,
258 "Return two values, the @sc{car} and the @sc{cdr} of @var{pair}.")
259 #define FUNC_NAME s_scm_srfi1_car_plus_cdr
261 SCM_VALIDATE_CONS (SCM_ARG1
, pair
);
262 return scm_values (scm_list_2 (SCM_CAR (pair
), SCM_CDR (pair
)));
267 SCM_DEFINE (scm_srfi1_concatenate
, "concatenate", 1, 0, 0,
269 "Construct a list by appending all lists in @var{lstlst}.\n"
271 "@code{concatenate} is the same as @code{(apply append\n"
272 "@var{lstlst})}. It exists because some Scheme implementations\n"
273 "have a limit on the number of arguments a function takes, which\n"
274 "the @code{apply} might exceed. In Guile there is no such\n"
276 #define FUNC_NAME s_scm_srfi1_concatenate
278 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
279 return scm_append (lstlst
);
284 SCM_DEFINE (scm_srfi1_concatenate_x
, "concatenate!", 1, 0, 0,
286 "Construct a list by appending all lists in @var{lstlst}. Those\n"
287 "lists may be modified to produce the result.\n"
289 "@code{concatenate!} is the same as @code{(apply append!\n"
290 "@var{lstlst})}. It exists because some Scheme implementations\n"
291 "have a limit on the number of arguments a function takes, which\n"
292 "the @code{apply} might exceed. In Guile there is no such\n"
294 #define FUNC_NAME s_scm_srfi1_concatenate
296 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
297 return scm_append_x (lstlst
);
302 SCM_DEFINE (scm_srfi1_count
, "count", 2, 0, 1,
303 (SCM pred
, SCM list1
, SCM rest
),
304 "Return a count of the number of times @var{pred} returns true\n"
305 "when called on elements from the given lists.\n"
307 "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
308 "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
309 "corresponding @var{list1} @dots{} @var{lstN}. The first call is\n"
310 "with the first element of each list, the second with the second\n"
311 "element from each, and so on.\n"
313 "Counting stops when the end of the shortest list is reached.\n"
314 "At least one list must be non-circular.")
315 #define FUNC_NAME s_scm_srfi1_count
320 SCM_VALIDATE_REST_ARGUMENT (rest
);
324 if (scm_is_null (rest
))
327 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
329 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
330 count
+= scm_is_true (scm_call_1 (pred
, SCM_CAR (list1
)));
332 /* check below that list1 is a proper list, and done */
337 else if (scm_is_pair (rest
) && scm_is_null (SCM_CDR (rest
)))
342 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
344 list2
= SCM_CAR (rest
);
347 if (! scm_is_pair (list1
))
349 if (! scm_is_pair (list2
))
355 count
+= scm_is_true (scm_call_2
356 (pred
, SCM_CAR (list1
), SCM_CAR (list2
)));
357 list1
= SCM_CDR (list1
);
358 list2
= SCM_CDR (list2
);
363 /* three or more lists */
367 /* vec is the list arguments */
368 vec
= scm_vector (scm_cons (list1
, rest
));
369 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
371 /* args is the argument list to pass to pred, same length as vec,
372 re-used for each call */
373 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
377 /* first elem of each list in vec into args, and step those
378 vec entries onto their next element */
379 for (i
= 0, a
= args
, argnum
= 2;
381 i
++, a
= SCM_CDR (a
), argnum
++)
383 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
384 if (! scm_is_pair (lst
))
385 goto check_lst_and_done
;
386 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for pred */
387 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
390 count
+= scm_is_true (scm_apply (pred
, args
, SCM_EOL
));
395 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
396 return scm_from_long (count
);
401 SCM_DEFINE (scm_srfi1_delete
, "delete", 2, 1, 0,
402 (SCM x
, SCM lst
, SCM pred
),
403 "Return a list containing the elements of @var{lst} but with\n"
404 "those equal to @var{x} deleted. The returned elements will be\n"
405 "in the same order as they were in @var{lst}.\n"
407 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
408 "given. An equality call is made just once for each element,\n"
409 "but the order in which the calls are made on the elements is\n"
412 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
413 "given @var{x} is first. This means for instance elements\n"
414 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
416 "@var{lst} is not modified, but the returned list might share a\n"
417 "common tail with @var{lst}.")
418 #define FUNC_NAME s_scm_srfi1_delete
420 SCM ret
, *p
, keeplst
;
423 if (SCM_UNBNDP (pred
))
424 return scm_delete (x
, lst
);
426 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG3
, FUNC_NAME
);
428 /* ret is the return list being constructed. p is where to append to it,
429 initially &ret then SCM_CDRLOC of the last pair. lst progresses as
430 elements are considered.
432 Elements to be retained are not immediately copied, instead keeplst is
433 the last pair in lst which is to be retained but not yet copied, count
434 is how many from there are wanted. When there's no more deletions, *p
435 can be set to keeplst to share the remainder of the original lst. (The
436 entire original lst if there's no deletions at all.) */
442 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
444 if (scm_is_true (scm_call_2 (pred
, x
, SCM_CAR (lst
))))
446 /* delete this element, so copy those at keeplst */
447 p
= list_copy_part (keeplst
, count
, p
);
448 keeplst
= SCM_CDR (lst
);
453 /* keep this element */
458 /* final retained elements */
461 /* demand that lst was a proper list */
462 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
469 SCM_DEFINE (scm_srfi1_delete_x
, "delete!", 2, 1, 0,
470 (SCM x
, SCM lst
, SCM pred
),
471 "Return a list containing the elements of @var{lst} but with\n"
472 "those equal to @var{x} deleted. The returned elements will be\n"
473 "in the same order as they were in @var{lst}.\n"
475 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
476 "given. An equality call is made just once for each element,\n"
477 "but the order in which the calls are made on the elements is\n"
480 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
481 "given @var{x} is first. This means for instance elements\n"
482 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
484 "@var{lst} may be modified to construct the returned list.")
485 #define FUNC_NAME s_scm_srfi1_delete_x
490 if (SCM_UNBNDP (pred
))
491 return scm_delete_x (x
, lst
);
493 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG3
, FUNC_NAME
);
495 for (prev
= &lst
, walk
= lst
;
497 walk
= SCM_CDR (walk
))
499 if (scm_is_true (scm_call_2 (pred
, x
, SCM_CAR (walk
))))
500 *prev
= SCM_CDR (walk
);
502 prev
= SCM_CDRLOC (walk
);
505 /* demand the input was a proper list */
506 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk
), walk
, SCM_ARG2
, FUNC_NAME
,"list");
512 SCM_DEFINE (scm_srfi1_delete_duplicates
, "delete-duplicates", 1, 1, 0,
514 "Return a list containing the elements of @var{lst} but without\n"
517 "When elements are equal, only the first in @var{lst} is\n"
518 "retained. Equal elements can be anywhere in @var{lst}, they\n"
519 "don't have to be adjacent. The returned list will have the\n"
520 "retained elements in the same order as they were in @var{lst}.\n"
522 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
523 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
524 "being before @var{y} in @var{lst}. A call is made at most once\n"
525 "for each combination, but the sequence of the calls across the\n"
526 "elements is unspecified.\n"
528 "@var{lst} is not modified, but the return might share a common\n"
529 "tail with @var{lst}.\n"
531 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
532 "it must check each element against all those preceding it. For\n"
533 "long lists it is more efficient to sort and then compare only\n"
534 "adjacent elements.")
535 #define FUNC_NAME s_scm_srfi1_delete_duplicates
537 scm_t_trampoline_2 equal_p
;
538 SCM ret
, *p
, keeplst
, item
, l
;
541 /* ret is the new list constructed. p is where to append, initially &ret
542 then SCM_CDRLOC of the last pair. lst is advanced as each element is
545 Elements retained are not immediately appended to ret, instead keeplst
546 is the last pair in lst which is to be kept but is not yet copied.
547 Initially this is the first pair of lst, since the first element is
550 *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
551 the elements retained, making the equality search loop easy.
553 If an item must be deleted, elements from keeplst (inclusive) to lst
554 (exclusive) must be copied and appended to ret. When there's no more
555 deletions, *p is left set to keeplst, so ret shares structure with the
556 original lst. (ret will be the entire original lst if there are no
559 /* skip to end if an empty list (or something invalid) */
562 if (SCM_UNBNDP (pred
))
563 equal_p
= equal_trampoline
;
566 SCM_VALIDATE_PROC (SCM_ARG2
, pred
);
567 equal_p
= scm_call_2
;
574 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
576 item
= SCM_CAR (lst
);
578 /* look for item in "ret" list */
579 for (l
= ret
; scm_is_pair (l
); l
= SCM_CDR (l
))
581 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
583 /* "item" is a duplicate, so copy keeplst onto ret */
585 p
= list_copy_part (keeplst
, count
, p
);
587 keeplst
= SCM_CDR (lst
); /* elem after the one deleted */
593 /* look for item in "keeplst" list
594 be careful traversing, in case nasty code changed the cdrs */
595 for (i
= 0, l
= keeplst
;
596 i
< count
&& scm_is_pair (l
);
597 i
++, l
= SCM_CDR (l
))
598 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
601 /* keep this element */
607 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
609 /* share tail of keeplst items */
617 SCM_DEFINE (scm_srfi1_delete_duplicates_x
, "delete-duplicates!", 1, 1, 0,
619 "Return a list containing the elements of @var{lst} but without\n"
622 "When elements are equal, only the first in @var{lst} is\n"
623 "retained. Equal elements can be anywhere in @var{lst}, they\n"
624 "don't have to be adjacent. The returned list will have the\n"
625 "retained elements in the same order as they were in @var{lst}.\n"
627 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
628 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
629 "being before @var{y} in @var{lst}. A call is made at most once\n"
630 "for each combination, but the sequence of the calls across the\n"
631 "elements is unspecified.\n"
633 "@var{lst} may be modified to construct the returned list.\n"
635 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
636 "it must check each element against all those preceding it. For\n"
637 "long lists it is more efficient to sort and then compare only\n"
638 "adjacent elements.")
639 #define FUNC_NAME s_scm_srfi1_delete_duplicates_x
641 scm_t_trampoline_2 equal_p
;
642 SCM ret
, endret
, item
, l
;
644 /* ret is the return list, constructed from the pairs in lst. endret is
645 the last pair of ret, initially the first pair. lst is advanced as
646 elements are considered. */
648 /* skip to end if an empty list (or something invalid) */
650 if (scm_is_pair (lst
))
652 if (SCM_UNBNDP (pred
))
653 equal_p
= equal_trampoline
;
656 SCM_VALIDATE_PROC (SCM_ARG2
, pred
);
657 equal_p
= scm_call_2
;
662 /* loop over lst elements starting from second */
666 if (! scm_is_pair (lst
))
668 item
= SCM_CAR (lst
);
670 /* is item equal to any element from ret to endret (inclusive)? */
674 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
675 break; /* equal, forget this element */
677 if (scm_is_eq (l
, endret
))
679 /* not equal to any, so append this pair */
680 SCM_SETCDR (endret
, lst
);
688 /* terminate, in case last element was deleted */
689 SCM_SETCDR (endret
, SCM_EOL
);
692 /* demand that lst was a proper list */
693 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
700 SCM_DEFINE (scm_srfi1_drop_right
, "drop-right", 2, 0, 0,
702 "Return a new list containing all except the last @var{n}\n"
703 "elements of @var{lst}.")
704 #define FUNC_NAME s_scm_srfi1_drop_right
706 SCM tail
= scm_list_tail (lst
, n
);
709 while (scm_is_pair (tail
))
711 *rend
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
712 rend
= SCM_CDRLOC (*rend
);
715 tail
= SCM_CDR (tail
);
717 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
723 SCM_DEFINE (scm_srfi1_drop_right_x
, "drop-right!", 2, 0, 0,
725 "Return the a list containing the @var{n} last elements of\n"
726 "@var{lst}. @var{lst} may be modified to build the return.")
727 #define FUNC_NAME s_scm_srfi1_drop_right_x
731 if (scm_is_eq (n
, SCM_INUM0
))
734 tail
= scm_list_tail (lst
, n
);
737 /* p and tail work along the list, p being the cdrloc of the cell n steps
739 for ( ; scm_is_pair (tail
); tail
= SCM_CDR (tail
))
742 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
750 SCM_DEFINE (scm_srfi1_drop_while
, "drop-while", 2, 0, 0,
752 "Drop the longest initial prefix of @var{lst} whose elements all\n"
753 "satisfy the predicate @var{pred}.")
754 #define FUNC_NAME s_scm_srfi1_drop_while
756 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
758 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
759 if (scm_is_false (scm_call_1 (pred
, SCM_CAR (lst
))))
762 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
769 SCM_DEFINE (scm_srfi1_eighth
, "eighth", 1, 0, 0,
771 "Return the eighth element of @var{lst}.")
772 #define FUNC_NAME s_scm_srfi1_eighth
774 return scm_list_ref (lst
, SCM_I_MAKINUM (7));
779 SCM_DEFINE (scm_srfi1_fifth
, "fifth", 1, 0, 0,
781 "Return the fifth element of @var{lst}.")
782 #define FUNC_NAME s_scm_srfi1_fifth
784 return scm_list_ref (lst
, SCM_I_MAKINUM (4));
789 SCM_DEFINE (scm_srfi1_filter_map
, "filter-map", 2, 0, 1,
790 (SCM proc
, SCM list1
, SCM rest
),
791 "Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
792 "return a list of the results as per SRFI-1 @code{map}, except\n"
793 "that any @code{#f} results are omitted from the list returned.")
794 #define FUNC_NAME s_scm_srfi1_filter_map
796 SCM ret
, *loc
, elem
, newcell
, lst
;
799 SCM_VALIDATE_REST_ARGUMENT (rest
);
804 if (scm_is_null (rest
))
807 SCM_VALIDATE_PROC (SCM_ARG1
, proc
);
809 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
811 elem
= scm_call_1 (proc
, SCM_CAR (list1
));
812 if (scm_is_true (elem
))
814 newcell
= scm_cons (elem
, SCM_EOL
);
816 loc
= SCM_CDRLOC (newcell
);
820 /* check below that list1 is a proper list, and done */
825 else if (scm_is_null (SCM_CDR (rest
)))
828 SCM list2
= SCM_CAR (rest
);
829 SCM_VALIDATE_PROC (SCM_ARG1
, proc
);
833 if (! scm_is_pair (list1
))
835 if (! scm_is_pair (list2
))
839 goto check_lst_and_done
;
841 elem
= scm_call_2 (proc
, SCM_CAR (list1
), SCM_CAR (list2
));
842 if (scm_is_true (elem
))
844 newcell
= scm_cons (elem
, SCM_EOL
);
846 loc
= SCM_CDRLOC (newcell
);
848 list1
= SCM_CDR (list1
);
849 list2
= SCM_CDR (list2
);
854 /* three or more lists */
858 /* vec is the list arguments */
859 vec
= scm_vector (scm_cons (list1
, rest
));
860 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
862 /* args is the argument list to pass to proc, same length as vec,
863 re-used for each call */
864 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
868 /* first elem of each list in vec into args, and step those
869 vec entries onto their next element */
870 for (i
= 0, a
= args
, argnum
= 2;
872 i
++, a
= SCM_CDR (a
), argnum
++)
874 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
875 if (! scm_is_pair (lst
))
876 goto check_lst_and_done
;
877 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for proc */
878 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
881 elem
= scm_apply (proc
, args
, SCM_EOL
);
882 if (scm_is_true (elem
))
884 newcell
= scm_cons (elem
, SCM_EOL
);
886 loc
= SCM_CDRLOC (newcell
);
892 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
898 SCM_DEFINE (scm_srfi1_find
, "find", 2, 0, 0,
900 "Return the first element of @var{lst} which satisfies the\n"
901 "predicate @var{pred}, or return @code{#f} if no such element is\n"
903 #define FUNC_NAME s_scm_srfi1_find
905 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
907 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
909 SCM elem
= SCM_CAR (lst
);
910 if (scm_is_true (scm_call_1 (pred
, elem
)))
913 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
920 SCM_DEFINE (scm_srfi1_find_tail
, "find-tail", 2, 0, 0,
922 "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
923 "predicate @var{pred}, or return @code{#f} if no such element is\n"
925 #define FUNC_NAME s_scm_srfi1_find_tail
927 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
929 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
930 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (lst
))))
932 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
939 SCM_DEFINE (scm_srfi1_fold
, "fold", 3, 0, 1,
940 (SCM proc
, SCM init
, SCM list1
, SCM rest
),
941 "Apply @var{proc} to the elements of @var{lst1} @dots{}\n"
942 "@var{lstN} to build a result, and return that result.\n"
944 "Each @var{proc} call is @code{(@var{proc} @var{elem1} @dots{}\n"
945 "@var{elemN} @var{previous})}, where @var{elem1} is from\n"
946 "@var{lst1}, through @var{elemN} from @var{lstN}.\n"
947 "@var{previous} is the return from the previous call to\n"
948 "@var{proc}, or the given @var{init} for the first call. If any\n"
949 "list is empty, just @var{init} is returned.\n"
951 "@code{fold} works through the list elements from first to last.\n"
952 "The following shows a list reversal and the calls it makes,\n"
955 "(fold cons '() '(1 2 3))\n"
960 "@result{} (3 2 1)\n"
963 "If @var{lst1} through @var{lstN} have different lengths,\n"
964 "@code{fold} stops when the end of the shortest is reached.\n"
965 "Ie.@: elements past the length of the shortest are ignored in\n"
966 "the other @var{lst}s. At least one @var{lst} must be\n"
969 "The way @code{fold} builds a result from iterating is quite\n"
970 "general, it can do more than other iterations like say\n"
971 "@code{map} or @code{filter}. The following for example removes\n"
972 "adjacent duplicate elements from a list,\n"
975 "(define (delete-adjacent-duplicates lst)\n"
976 " (fold-right (lambda (elem ret)\n"
977 " (if (equal? elem (first ret))\n"
979 " (cons elem ret)))\n"
980 " (list (last lst))\n"
982 "(delete-adjacent-duplicates '(1 2 3 3 4 4 4 5))\n"
983 "@result{} (1 2 3 4 5)\n"
986 "Clearly the same sort of thing can be done with a\n"
987 "@code{for-each} and a variable in which to build the result,\n"
988 "but a self-contained @var{proc} can be re-used in multiple\n"
989 "contexts, where a @code{for-each} would have to be written out\n"
991 #define FUNC_NAME s_scm_srfi1_fold
995 SCM_VALIDATE_REST_ARGUMENT (rest
);
997 if (scm_is_null (rest
))
1000 SCM_VALIDATE_PROC (SCM_ARG1
, proc
);
1002 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
1003 init
= scm_call_2 (proc
, SCM_CAR (list1
), init
);
1005 /* check below that list1 is a proper list, and done */
1011 /* two or more lists */
1015 /* vec is the list arguments */
1016 vec
= scm_vector (scm_cons (list1
, rest
));
1017 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
1019 /* args is the argument list to pass to proc, same length as vec,
1020 re-used for each call */
1021 args
= scm_make_list (SCM_I_MAKINUM (len
+1), SCM_UNDEFINED
);
1025 /* first elem of each list in vec into args, and step those
1026 vec entries onto their next element */
1027 for (i
= 0, a
= args
, argnum
= 2;
1029 i
++, a
= SCM_CDR (a
), argnum
++)
1031 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
1032 if (! scm_is_pair (lst
))
1033 goto check_lst_and_done
;
1034 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for proc */
1035 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
1037 SCM_SETCAR (a
, init
);
1039 init
= scm_apply (proc
, args
, SCM_EOL
);
1044 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
1050 SCM_DEFINE (scm_srfi1_last
, "last", 1, 0, 0,
1052 "Like @code{cons}, but with interchanged arguments. Useful\n"
1053 "mostly when passed to higher-order procedures.")
1054 #define FUNC_NAME s_scm_srfi1_last
1056 SCM pair
= scm_last_pair (lst
);
1057 /* scm_last_pair returns SCM_EOL for an empty list */
1058 SCM_VALIDATE_CONS (SCM_ARG1
, pair
);
1059 return SCM_CAR (pair
);
1064 SCM_DEFINE (scm_srfi1_length_plus
, "length+", 1, 0, 0,
1066 "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
1068 #define FUNC_NAME s_scm_srfi1_length_plus
1070 long len
= scm_ilength (lst
);
1071 return (len
>= 0 ? SCM_I_MAKINUM (len
) : SCM_BOOL_F
);
1076 SCM_DEFINE (scm_srfi1_list_index
, "list-index", 2, 0, 1,
1077 (SCM pred
, SCM list1
, SCM rest
),
1078 "Return the index of the first set of elements, one from each of\n"
1079 "@var{lst1}@dots{}@var{lstN}, which satisfies @var{pred}.\n"
1081 "@var{pred} is called as @code{(@var{pred} elem1 @dots{}\n"
1082 "elemN)}. Searching stops when the end of the shortest\n"
1083 "@var{lst} is reached. The return index starts from 0 for the\n"
1084 "first set of elements. If no set of elements pass then the\n"
1085 "return is @code{#f}.\n"
1088 "(list-index odd? '(2 4 6 9)) @result{} 3\n"
1089 "(list-index = '(1 2 3) '(3 1 2)) @result{} #f\n"
1091 #define FUNC_NAME s_scm_srfi1_list_index
1096 SCM_VALIDATE_REST_ARGUMENT (rest
);
1098 if (scm_is_null (rest
))
1101 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
1103 for ( ; scm_is_pair (list1
); n
++, list1
= SCM_CDR (list1
))
1104 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (list1
))))
1105 return SCM_I_MAKINUM (n
);
1107 /* not found, check below that list1 is a proper list */
1112 else if (scm_is_pair (rest
) && scm_is_null (SCM_CDR (rest
)))
1115 SCM list2
= SCM_CAR (rest
);
1116 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
1120 if (! scm_is_pair (list1
))
1122 if (! scm_is_pair (list2
))
1128 if (scm_is_true (scm_call_2 (pred
,
1129 SCM_CAR (list1
), SCM_CAR (list2
))))
1130 return SCM_I_MAKINUM (n
);
1132 list1
= SCM_CDR (list1
);
1133 list2
= SCM_CDR (list2
);
1138 /* three or more lists */
1142 /* vec is the list arguments */
1143 vec
= scm_vector (scm_cons (list1
, rest
));
1144 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
1146 /* args is the argument list to pass to pred, same length as vec,
1147 re-used for each call */
1148 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
1152 /* first elem of each list in vec into args, and step those
1153 vec entries onto their next element */
1154 for (i
= 0, a
= args
, argnum
= 2;
1156 i
++, a
= SCM_CDR (a
), argnum
++)
1158 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
1159 if (! scm_is_pair (lst
))
1160 goto not_found_check_lst
;
1161 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for pred */
1162 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
1165 if (scm_is_true (scm_apply (pred
, args
, SCM_EOL
)))
1166 return SCM_I_MAKINUM (n
);
1170 not_found_check_lst
:
1171 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
1177 /* This routine differs from the core list-copy in allowing improper lists.
1178 Maybe the core could allow them similarly. */
1180 SCM_DEFINE (scm_srfi1_list_copy
, "list-copy", 1, 0, 0,
1182 "Return a copy of the given list @var{lst}.\n"
1184 "@var{lst} can be a proper or improper list. And if @var{lst}\n"
1185 "is not a pair then it's treated as the final tail of an\n"
1186 "improper list and simply returned.")
1187 #define FUNC_NAME s_scm_srfi1_list_copy
1194 fill_here
= &newlst
;
1197 while (scm_is_pair (from_here
))
1200 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
1202 fill_here
= SCM_CDRLOC (c
);
1203 from_here
= SCM_CDR (from_here
);
1210 SCM_DEFINE (scm_srfi1_list_tabulate
, "list-tabulate", 2, 0, 0,
1212 "Return an @var{n}-element list, where each list element is\n"
1213 "produced by applying the procedure @var{init-proc} to the\n"
1214 "corresponding list index. The order in which @var{init-proc}\n"
1215 "is applied to the indices is not specified.")
1216 #define FUNC_NAME s_scm_srfi1_list_tabulate
1220 nn
= scm_to_signed_integer (n
, 0, LONG_MAX
);
1221 SCM_VALIDATE_PROC (SCM_ARG2
, proc
);
1222 for (i
= nn
-1; i
>= 0; i
--)
1223 ret
= scm_cons (scm_call_1 (proc
, scm_from_long (i
)), ret
);
1229 SCM_DEFINE (scm_srfi1_lset_adjoin
, "lset-adjoin", 2, 0, 1,
1230 (SCM equal
, SCM lst
, SCM rest
),
1231 "Add to @var{list} any of the given @var{elem}s not already in\n"
1232 "the list. @var{elem}s are @code{cons}ed onto the start of\n"
1233 "@var{list} (so the return shares a common tail with\n"
1234 "@var{list}), but the order they're added is unspecified.\n"
1236 "The given @var{=} procedure is used for comparing elements,\n"
1237 "called as @code{(@var{=} listelem elem)}, ie.@: the second\n"
1238 "argument is one of the given @var{elem} parameters.\n"
1241 "(lset-adjoin eqv? '(1 2 3) 4 1 5) @result{} (5 4 1 2 3)\n"
1243 #define FUNC_NAME s_scm_srfi1_lset_adjoin
1247 SCM_VALIDATE_PROC (SCM_ARG1
, equal
);
1248 SCM_VALIDATE_REST_ARGUMENT (rest
);
1250 /* It's not clear if duplicates among the `rest' elements are meant to be
1251 cast out. The spec says `=' is called as (= list-elem rest-elem),
1252 suggesting perhaps not, but the reference implementation shows the
1253 "list" at each stage as including those "rest" elements already added.
1254 The latter corresponds to what's described for lset-union, so that's
1255 what's done here. */
1257 for ( ; scm_is_pair (rest
); rest
= SCM_CDR (rest
))
1259 elem
= SCM_CAR (rest
);
1261 for (l
= lst
; scm_is_pair (l
); l
= SCM_CDR (l
))
1262 if (scm_is_true (scm_call_2 (equal
, SCM_CAR (l
), elem
)))
1263 goto next_elem
; /* elem already in lst, don't add */
1265 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(l
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1267 /* elem is not equal to anything already in lst, add it */
1268 lst
= scm_cons (elem
, lst
);
1279 SCM_DEFINE (scm_srfi1_lset_difference_x
, "lset-difference!", 2, 0, 1,
1280 (SCM equal
, SCM lst
, SCM rest
),
1281 "Return @var{lst} with any elements in the lists in @var{rest}\n"
1282 "removed (ie.@: subtracted). For only one @var{lst} argument,\n"
1283 "just that list is returned.\n"
1285 "The given @var{equal} procedure is used for comparing elements,\n"
1286 "called as @code{(@var{equal} elem1 elemN)}. The first argument\n"
1287 "is from @var{lst} and the second from one of the subsequent\n"
1288 "lists. But exactly which calls are made and in what order is\n"
1292 "(lset-difference! eqv? (list 'x 'y)) @result{} (x y)\n"
1293 "(lset-difference! eqv? (list 1 2 3) '(3 1)) @result{} (2)\n"
1294 "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n"
1297 "@code{lset-difference!} may modify @var{lst} to form its\n"
1299 #define FUNC_NAME s_scm_srfi1_lset_difference_x
1301 SCM ret
, *pos
, elem
, r
, b
;
1304 SCM_VALIDATE_PROC (SCM_ARG1
, equal
);
1305 SCM_VALIDATE_REST_ARGUMENT (rest
);
1309 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1311 elem
= SCM_CAR (lst
);
1313 for (r
= rest
, argnum
= SCM_ARG3
;
1315 r
= SCM_CDR (r
), argnum
++)
1317 for (b
= SCM_CAR (r
); scm_is_pair (b
); b
= SCM_CDR (b
))
1318 if (scm_is_true (scm_call_2 (equal
, elem
, SCM_CAR (b
))))
1319 goto next_elem
; /* equal to elem, so drop that elem */
1321 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b
), b
, argnum
, FUNC_NAME
,"list");
1324 /* elem not equal to anything in later lists, so keep it */
1326 pos
= SCM_CDRLOC (lst
);
1331 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1339 /* Typechecking for multi-argument MAP and FOR-EACH.
1341 Verify that each element of the vector ARGV, except for the first,
1342 is a list and return minimum length. Attribute errors to WHO,
1343 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
1345 check_map_args (SCM argv
,
1355 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
1358 elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
1360 if (!(scm_is_null (elt
) || scm_is_pair (elt
)))
1361 goto check_map_error
;
1363 elt_len
= srfi1_ilength (elt
);
1365 goto check_map_error
;
1367 if (len
< 0 || (elt_len
>= 0 && elt_len
< len
))
1377 scm_apply_generic (gf
, scm_cons (proc
, args
));
1379 scm_wrong_type_arg (who
, i
+ 2, elt
);
1382 scm_remember_upto_here_1 (argv
);
1387 SCM_GPROC (s_srfi1_map
, "map", 2, 0, 1, scm_srfi1_map
, g_srfi1_map
);
1389 /* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
1390 sequentially, starting with the first element(s). This is used in
1391 the Scheme procedure `map-in-order', which guarantees sequential
1392 behaviour, is implemented using scm_map. If the behaviour changes,
1393 we need to update `map-in-order'.
1397 scm_srfi1_map (SCM proc
, SCM arg1
, SCM args
)
1398 #define FUNC_NAME s_srfi1_map
1404 len
= srfi1_ilength (arg1
);
1405 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
1407 scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_srfi1_map
);
1408 SCM_VALIDATE_REST_ARGUMENT (args
);
1409 if (scm_is_null (args
))
1411 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_srfi1_map
,
1412 proc
, arg1
, SCM_ARG1
, s_srfi1_map
);
1413 SCM_GASSERT2 (len
>= 0, g_srfi1_map
, proc
, arg1
, SCM_ARG2
, s_srfi1_map
);
1414 while (SCM_NIMP (arg1
))
1416 *pres
= scm_list_1 (scm_call_1 (proc
, SCM_CAR (arg1
)));
1417 pres
= SCM_CDRLOC (*pres
);
1418 arg1
= SCM_CDR (arg1
);
1422 if (scm_is_null (SCM_CDR (args
)))
1424 SCM arg2
= SCM_CAR (args
);
1425 int len2
= srfi1_ilength (arg2
);
1426 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_srfi1_map
,
1427 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_map
);
1428 if (len
< 0 || (len2
>= 0 && len2
< len
))
1430 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
1431 && len
>= 0 && len2
>= -1,
1433 scm_cons2 (proc
, arg1
, args
),
1434 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
1438 *pres
= scm_list_1 (scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
1439 pres
= SCM_CDRLOC (*pres
);
1440 arg1
= SCM_CDR (arg1
);
1441 arg2
= SCM_CDR (arg2
);
1446 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
1447 len
= check_map_args (args
, len
, g_srfi1_map
, proc
, arg1
, s_srfi1_map
);
1451 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
1453 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
1454 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
1455 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
1457 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
1458 pres
= SCM_CDRLOC (*pres
);
1465 SCM_REGISTER_PROC (s_srfi1_map_in_order
, "map-in-order", 2, 0, 1, scm_srfi1_map
);
1467 SCM_GPROC (s_srfi1_for_each
, "for-each", 2, 0, 1, scm_srfi1_for_each
, g_srfi1_for_each
);
1470 scm_srfi1_for_each (SCM proc
, SCM arg1
, SCM args
)
1471 #define FUNC_NAME s_srfi1_for_each
1474 len
= srfi1_ilength (arg1
);
1475 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
1476 g_srfi1_for_each
, scm_cons2 (proc
, arg1
, args
),
1477 SCM_ARG2
, s_srfi1_for_each
);
1478 SCM_VALIDATE_REST_ARGUMENT (args
);
1479 if (scm_is_null (args
))
1481 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_srfi1_for_each
,
1482 proc
, arg1
, SCM_ARG1
, s_srfi1_for_each
);
1483 SCM_GASSERT2 (len
>= 0, g_srfi1_for_each
, proc
, arg1
,
1484 SCM_ARG2
, s_srfi1_map
);
1485 while (SCM_NIMP (arg1
))
1487 scm_call_1 (proc
, SCM_CAR (arg1
));
1488 arg1
= SCM_CDR (arg1
);
1490 return SCM_UNSPECIFIED
;
1492 if (scm_is_null (SCM_CDR (args
)))
1494 SCM arg2
= SCM_CAR (args
);
1495 int len2
= srfi1_ilength (arg2
);
1496 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_srfi1_for_each
,
1497 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_for_each
);
1498 if (len
< 0 || (len2
>= 0 && len2
< len
))
1500 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
1501 && len
>= 0 && len2
>= -1,
1503 scm_cons2 (proc
, arg1
, args
),
1504 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
1508 scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
1509 arg1
= SCM_CDR (arg1
);
1510 arg2
= SCM_CDR (arg2
);
1513 return SCM_UNSPECIFIED
;
1515 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
1516 len
= check_map_args (args
, len
, g_srfi1_for_each
, proc
, arg1
,
1521 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
1523 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
1524 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
1525 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
1527 scm_apply (proc
, arg1
, SCM_EOL
);
1530 return SCM_UNSPECIFIED
;
1535 SCM_DEFINE (scm_srfi1_member
, "member", 2, 1, 0,
1536 (SCM x
, SCM lst
, SCM pred
),
1537 "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
1538 "to @var{x}. If @var{x} does not appear in @var{lst}, return\n"
1541 "Equality is determined by @code{equal?}, or by the equality\n"
1542 "predicate @var{=} if given. @var{=} is called @code{(= @var{x}\n"
1543 "elem)}, ie.@: with the given @var{x} first, so for example to\n"
1544 "find the first element greater than 5,\n"
1547 "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
1550 "This version of @code{member} extends the core @code{member} by\n"
1551 "accepting an equality predicate.")
1552 #define FUNC_NAME s_scm_srfi1_member
1554 scm_t_trampoline_2 equal_p
;
1555 SCM_VALIDATE_LIST (2, lst
);
1556 if (SCM_UNBNDP (pred
))
1557 equal_p
= equal_trampoline
;
1560 SCM_VALIDATE_PROC (SCM_ARG3
, pred
);
1561 equal_p
= scm_call_2
;
1563 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
1565 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
1572 SCM_DEFINE (scm_srfi1_assoc
, "assoc", 2, 1, 0,
1573 (SCM key
, SCM alist
, SCM pred
),
1574 "Behaves like @code{assq} but uses third argument @var{pred?}\n"
1575 "for key comparison. If @var{pred?} is not supplied,\n"
1576 "@code{equal?} is used. (Extended from R5RS.)\n")
1577 #define FUNC_NAME s_scm_srfi1_assoc
1580 scm_t_trampoline_2 equal_p
;
1581 if (SCM_UNBNDP (pred
))
1582 equal_p
= equal_trampoline
;
1585 SCM_VALIDATE_PROC (SCM_ARG3
, pred
);
1586 equal_p
= scm_call_2
;
1588 for(; scm_is_pair (ls
); ls
= SCM_CDR (ls
))
1590 SCM tmp
= SCM_CAR (ls
);
1591 SCM_ASSERT_TYPE (scm_is_pair (tmp
), alist
, SCM_ARG2
, FUNC_NAME
,
1592 "association list");
1593 if (scm_is_true (equal_p (pred
, key
, SCM_CAR (tmp
))))
1596 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls
), alist
, SCM_ARG2
, FUNC_NAME
,
1597 "association list");
1603 SCM_DEFINE (scm_srfi1_ninth
, "ninth", 1, 0, 0,
1605 "Return the ninth element of @var{lst}.")
1606 #define FUNC_NAME s_scm_srfi1_ninth
1608 return scm_list_ref (lst
, scm_from_int (8));
1613 SCM_DEFINE (scm_srfi1_not_pair_p
, "not-pair?", 1, 0, 0,
1615 "Return @code{#t} is @var{obj} is not a pair, @code{#f}\n"
1618 "This is shorthand notation @code{(not (pair? @var{obj}))} and\n"
1619 "is supposed to be used for end-of-list checking in contexts\n"
1620 "where dotted lists are allowed.")
1621 #define FUNC_NAME s_scm_srfi1_not_pair_p
1623 return scm_from_bool (! scm_is_pair (obj
));
1628 SCM_DEFINE (scm_srfi1_partition
, "partition", 2, 0, 0,
1629 (SCM pred
, SCM list
),
1630 "Partition the elements of @var{list} with predicate @var{pred}.\n"
1631 "Return two values: the list of elements satifying @var{pred} and\n"
1632 "the list of elements @emph{not} satisfying @var{pred}. The order\n"
1633 "of the output lists follows the order of @var{list}. @var{list}\n"
1634 "is not mutated. One of the output lists may share memory with @var{list}.\n")
1635 #define FUNC_NAME s_scm_srfi1_partition
1637 /* In this implementation, the output lists don't share memory with
1638 list, because it's probably not worth the effort. */
1639 SCM orig_list
= list
;
1640 SCM kept
= scm_cons(SCM_EOL
, SCM_EOL
);
1641 SCM kept_tail
= kept
;
1642 SCM dropped
= scm_cons(SCM_EOL
, SCM_EOL
);
1643 SCM dropped_tail
= dropped
;
1645 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
1647 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR(list
)) {
1650 /* Make sure LIST is not a dotted list. */
1651 SCM_ASSERT (scm_is_pair (list
), orig_list
, SCM_ARG2
, FUNC_NAME
);
1653 elt
= SCM_CAR (list
);
1654 new_tail
= scm_cons (SCM_CAR (list
), SCM_EOL
);
1656 if (scm_is_true (scm_call_1 (pred
, elt
))) {
1657 SCM_SETCDR(kept_tail
, new_tail
);
1658 kept_tail
= new_tail
;
1661 SCM_SETCDR(dropped_tail
, new_tail
);
1662 dropped_tail
= new_tail
;
1665 /* re-use the initial conses for the values list */
1666 SCM_SETCAR(kept
, SCM_CDR(kept
));
1667 SCM_SETCDR(kept
, dropped
);
1668 SCM_SETCAR(dropped
, SCM_CDR(dropped
));
1669 SCM_SETCDR(dropped
, SCM_EOL
);
1670 return scm_values(kept
);
1675 SCM_DEFINE (scm_srfi1_partition_x
, "partition!", 2, 0, 0,
1676 (SCM pred
, SCM lst
),
1677 "Split @var{lst} into those elements which do and don't satisfy\n"
1678 "the predicate @var{pred}.\n"
1680 "The return is two values (@pxref{Multiple Values}), the first\n"
1681 "being a list of all elements from @var{lst} which satisfy\n"
1682 "@var{pred}, the second a list of those which do not.\n"
1684 "The elements in the result lists are in the same order as in\n"
1685 "@var{lst} but the order in which the calls @code{(@var{pred}\n"
1686 "elem)} are made on the list elements is unspecified.\n"
1688 "@var{lst} may be modified to construct the return lists.")
1689 #define FUNC_NAME s_scm_srfi1_partition_x
1691 SCM tlst
, flst
, *tp
, *fp
;
1693 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
1695 /* tlst and flst are the lists of true and false elements. tp and fp are
1696 where to store to append to them, initially &tlst and &flst, then
1697 SCM_CDRLOC of the last pair in the respective lists. */
1704 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1706 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (lst
))))
1709 tp
= SCM_CDRLOC (lst
);
1714 fp
= SCM_CDRLOC (lst
);
1718 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1720 /* terminate whichever didn't get the last element(s) */
1724 return scm_values (scm_list_2 (tlst
, flst
));
1729 SCM_DEFINE (scm_srfi1_reduce
, "reduce", 3, 0, 0,
1730 (SCM proc
, SCM def
, SCM lst
),
1731 "@code{reduce} is a variant of @code{fold}, where the first call\n"
1732 "to @var{proc} is on two elements from @var{lst}, rather than\n"
1733 "one element and a given initial value.\n"
1735 "If @var{lst} is empty, @code{reduce} returns @var{def} (this is\n"
1736 "the only use for @var{def}). If @var{lst} has just one element\n"
1737 "then that's the return value. Otherwise @var{proc} is called\n"
1738 "on the elements of @var{lst}.\n"
1740 "Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
1741 "@var{previous})}, where @var{elem} is from @var{lst} (the\n"
1742 "second and subsequent elements of @var{lst}), and\n"
1743 "@var{previous} is the return from the previous call to\n"
1744 "@var{proc}. The first element of @var{lst} is the\n"
1745 "@var{previous} for the first call to @var{proc}.\n"
1747 "For example, the following adds a list of numbers, the calls\n"
1748 "made to @code{+} are shown. (Of course @code{+} accepts\n"
1749 "multiple arguments and can add a list directly, with\n"
1753 "(reduce + 0 '(5 6 7)) @result{} 18\n"
1755 "(+ 6 5) @result{} 11\n"
1756 "(+ 7 11) @result{} 18\n"
1759 "@code{reduce} can be used instead of @code{fold} where the\n"
1760 "@var{init} value is an ``identity'', meaning a value which\n"
1761 "under @var{proc} doesn't change the result, in this case 0 is\n"
1762 "an identity since @code{(+ 5 0)} is just 5. @code{reduce}\n"
1763 "avoids that unnecessary call.")
1764 #define FUNC_NAME s_scm_srfi1_reduce
1767 SCM_VALIDATE_PROC (SCM_ARG1
, proc
);
1768 ret
= def
; /* if lst is empty */
1769 if (scm_is_pair (lst
))
1771 ret
= SCM_CAR (lst
); /* if lst has one element */
1773 for (lst
= SCM_CDR (lst
); scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1774 ret
= scm_call_2 (proc
, SCM_CAR (lst
), ret
);
1777 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG3
, FUNC_NAME
, "list");
1783 SCM_DEFINE (scm_srfi1_reduce_right
, "reduce-right", 3, 0, 0,
1784 (SCM proc
, SCM def
, SCM lst
),
1785 "@code{reduce-right} is a variant of @code{fold-right}, where\n"
1786 "the first call to @var{proc} is on two elements from @var{lst},\n"
1787 "rather than one element and a given initial value.\n"
1789 "If @var{lst} is empty, @code{reduce-right} returns @var{def}\n"
1790 "(this is the only use for @var{def}). If @var{lst} has just\n"
1791 "one element then that's the return value. Otherwise @var{proc}\n"
1792 "is called on the elements of @var{lst}.\n"
1794 "Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
1795 "@var{previous})}, where @var{elem} is from @var{lst} (the\n"
1796 "second last and then working back to the first element of\n"
1797 "@var{lst}), and @var{previous} is the return from the previous\n"
1798 "call to @var{proc}. The last element of @var{lst} is the\n"
1799 "@var{previous} for the first call to @var{proc}.\n"
1801 "For example, the following adds a list of numbers, the calls\n"
1802 "made to @code{+} are shown. (Of course @code{+} accepts\n"
1803 "multiple arguments and can add a list directly, with\n"
1807 "(reduce-right + 0 '(5 6 7)) @result{} 18\n"
1809 "(+ 6 7) @result{} 13\n"
1810 "(+ 5 13) @result{} 18\n"
1813 "@code{reduce-right} can be used instead of @code{fold-right}\n"
1814 "where the @var{init} value is an ``identity'', meaning a value\n"
1815 "which under @var{proc} doesn't change the result, in this case\n"
1816 "0 is an identity since @code{(+ 7 0)} is just 5.\n"
1817 "@code{reduce-right} avoids that unnecessary call.\n"
1819 "@code{reduce} should be preferred over @code{reduce-right} if\n"
1820 "the order of processing doesn't matter, or can be arranged\n"
1821 "either way, since @code{reduce} is a little more efficient.")
1822 #define FUNC_NAME s_scm_srfi1_reduce_right
1824 /* To work backwards across a list requires either repeatedly traversing
1825 to get each previous element, or using some memory for a reversed or
1826 random-access form. Repeated traversal might not be too terrible, but
1827 is of course quadratic complexity and hence to be avoided in case LST
1828 is long. A vector is preferred over a reversed list since it's more
1829 compact and is less work for the gc to collect. */
1833 SCM_VALIDATE_PROC (SCM_ARG1
, proc
);
1834 if (SCM_NULL_OR_NIL_P (lst
))
1837 vec
= scm_vector (lst
);
1838 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
1840 ret
= SCM_SIMPLE_VECTOR_REF (vec
, len
-1);
1841 for (i
= len
-2; i
>= 0; i
--)
1842 ret
= scm_call_2 (proc
, SCM_SIMPLE_VECTOR_REF (vec
, i
), ret
);
1849 SCM_DEFINE (scm_srfi1_remove
, "remove", 2, 0, 0,
1850 (SCM pred
, SCM list
),
1851 "Return a list containing all elements from @var{lst} which do\n"
1852 "not satisfy the predicate @var{pred}. The elements in the\n"
1853 "result list have the same order as in @var{lst}. The order in\n"
1854 "which @var{pred} is applied to the list elements is not\n"
1856 #define FUNC_NAME s_scm_srfi1_remove
1861 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
1862 SCM_VALIDATE_LIST (2, list
);
1864 for (prev
= &res
, walk
= list
;
1866 walk
= SCM_CDR (walk
))
1868 if (scm_is_false (scm_call_1 (pred
, SCM_CAR (walk
))))
1870 *prev
= scm_cons (SCM_CAR (walk
), SCM_EOL
);
1871 prev
= SCM_CDRLOC (*prev
);
1880 SCM_DEFINE (scm_srfi1_remove_x
, "remove!", 2, 0, 0,
1881 (SCM pred
, SCM list
),
1882 "Return a list containing all elements from @var{list} which do\n"
1883 "not satisfy the predicate @var{pred}. The elements in the\n"
1884 "result list have the same order as in @var{list}. The order in\n"
1885 "which @var{pred} is applied to the list elements is not\n"
1886 "specified. @var{list} may be modified to build the return\n"
1888 #define FUNC_NAME s_scm_srfi1_remove_x
1892 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
1893 SCM_VALIDATE_LIST (2, list
);
1895 for (prev
= &list
, walk
= list
;
1897 walk
= SCM_CDR (walk
))
1899 if (scm_is_false (scm_call_1 (pred
, SCM_CAR (walk
))))
1900 prev
= SCM_CDRLOC (walk
);
1902 *prev
= SCM_CDR (walk
);
1910 SCM_DEFINE (scm_srfi1_seventh
, "seventh", 1, 0, 0,
1912 "Return the seventh element of @var{lst}.")
1913 #define FUNC_NAME s_scm_srfi1_seventh
1915 return scm_list_ref (lst
, scm_from_int (6));
1920 SCM_DEFINE (scm_srfi1_sixth
, "sixth", 1, 0, 0,
1922 "Return the sixth element of @var{lst}.")
1923 #define FUNC_NAME s_scm_srfi1_sixth
1925 return scm_list_ref (lst
, scm_from_int (5));
1930 SCM_DEFINE (scm_srfi1_span
, "span", 2, 0, 0,
1931 (SCM pred
, SCM lst
),
1932 "Return two values, the longest initial prefix of @var{lst}\n"
1933 "whose elements all satisfy the predicate @var{pred}, and the\n"
1934 "remainder of @var{lst}.")
1935 #define FUNC_NAME s_scm_srfi1_span
1939 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
1943 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1945 SCM elem
= SCM_CAR (lst
);
1946 if (scm_is_false (scm_call_1 (pred
, elem
)))
1949 /* want this elem, tack it onto the end of ret */
1950 *p
= scm_cons (elem
, SCM_EOL
);
1951 p
= SCM_CDRLOC (*p
);
1953 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1956 return scm_values (scm_list_2 (ret
, lst
));
1961 SCM_DEFINE (scm_srfi1_span_x
, "span!", 2, 0, 0,
1962 (SCM pred
, SCM lst
),
1963 "Return two values, the longest initial prefix of @var{lst}\n"
1964 "whose elements all satisfy the predicate @var{pred}, and the\n"
1965 "remainder of @var{lst}. @var{lst} may be modified to form the\n"
1967 #define FUNC_NAME s_scm_srfi1_span_x
1971 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
1974 for (upto
= lst
; scm_is_pair (upto
); upto
= SCM_CDR (upto
))
1976 if (scm_is_false (scm_call_1 (pred
, SCM_CAR (upto
))))
1979 /* want this element */
1980 p
= SCM_CDRLOC (upto
);
1982 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1986 return scm_values (scm_list_2 (lst
, upto
));
1991 SCM_DEFINE (scm_srfi1_split_at
, "split-at", 2, 0, 0,
1993 "Return two values (multiple values), being a list of the\n"
1994 "elements before index @var{n} in @var{lst}, and a list of those\n"
1996 #define FUNC_NAME s_scm_srfi1_split_at
1999 /* pre is a list of elements before the i split point, loc is the CDRLOC
2000 of the last cell, ie. where to store to append to it */
2004 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
2006 SCM_VALIDATE_CONS (SCM_ARG1
, lst
);
2008 *loc
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
2009 loc
= SCM_CDRLOC (*loc
);
2012 return scm_values (scm_list_2 (pre
, lst
));
2017 SCM_DEFINE (scm_srfi1_split_at_x
, "split-at!", 2, 0, 0,
2019 "Return two values (multiple values), being a list of the\n"
2020 "elements before index @var{n} in @var{lst}, and a list of those\n"
2021 "after. @var{lst} is modified to form those values.")
2022 #define FUNC_NAME s_scm_srfi1_split_at
2028 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
2030 SCM_VALIDATE_CONS (SCM_ARG1
, upto
);
2032 loc
= SCM_CDRLOC (upto
);
2033 upto
= SCM_CDR (upto
);
2037 return scm_values (scm_list_2 (lst
, upto
));
2042 SCM_DEFINE (scm_srfi1_take_x
, "take!", 2, 0, 0,
2044 "Return a list containing the first @var{n} elements of\n"
2046 #define FUNC_NAME s_scm_srfi1_take_x
2051 nn
= scm_to_signed_integer (n
, 0, LONG_MAX
);
2055 pos
= scm_list_tail (lst
, scm_from_long (nn
- 1));
2057 /* Must have at least one cell left, mustn't have reached the end of an
2058 n-1 element list. SCM_VALIDATE_CONS here gives the same error as
2059 scm_list_tail does on say an n-2 element list, though perhaps a range
2060 error would make more sense (for both). */
2061 SCM_VALIDATE_CONS (SCM_ARG1
, pos
);
2063 SCM_SETCDR (pos
, SCM_EOL
);
2069 SCM_DEFINE (scm_srfi1_take_right
, "take-right", 2, 0, 0,
2071 "Return the a list containing the @var{n} last elements of\n"
2073 #define FUNC_NAME s_scm_srfi1_take_right
2075 SCM tail
= scm_list_tail (lst
, n
);
2076 while (scm_is_pair (tail
))
2078 lst
= SCM_CDR (lst
);
2079 tail
= SCM_CDR (tail
);
2081 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
2087 SCM_DEFINE (scm_srfi1_take_while
, "take-while", 2, 0, 0,
2088 (SCM pred
, SCM lst
),
2089 "Return a new list which is the longest initial prefix of\n"
2090 "@var{lst} whose elements all satisfy the predicate @var{pred}.")
2091 #define FUNC_NAME s_scm_srfi1_take_while
2095 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
2099 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
2101 SCM elem
= SCM_CAR (lst
);
2102 if (scm_is_false (scm_call_1 (pred
, elem
)))
2105 /* want this elem, tack it onto the end of ret */
2106 *p
= scm_cons (elem
, SCM_EOL
);
2107 p
= SCM_CDRLOC (*p
);
2109 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
2117 SCM_DEFINE (scm_srfi1_take_while_x
, "take-while!", 2, 0, 0,
2118 (SCM pred
, SCM lst
),
2119 "Return the longest initial prefix of @var{lst} whose elements\n"
2120 "all satisfy the predicate @var{pred}. @var{lst} may be\n"
2121 "modified to form the return.")
2122 #define FUNC_NAME s_scm_srfi1_take_while_x
2126 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
2129 for (upto
= lst
; scm_is_pair (upto
); upto
= SCM_CDR (upto
))
2131 if (scm_is_false (scm_call_1 (pred
, SCM_CAR (upto
))))
2134 /* want this element */
2135 p
= SCM_CDRLOC (upto
);
2137 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
2146 SCM_DEFINE (scm_srfi1_tenth
, "tenth", 1, 0, 0,
2148 "Return the tenth element of @var{lst}.")
2149 #define FUNC_NAME s_scm_srfi1_tenth
2151 return scm_list_ref (lst
, scm_from_int (9));
2156 SCM_DEFINE (scm_srfi1_xcons
, "xcons", 2, 0, 0,
2158 "Like @code{cons}, but with interchanged arguments. Useful\n"
2159 "mostly when passed to higher-order procedures.")
2160 #define FUNC_NAME s_scm_srfi1_xcons
2162 return scm_cons (a
, d
);
2168 scm_init_srfi_1 (void)
2170 SCM the_root_module
= scm_lookup_closure_module (SCM_BOOL_F
);
2171 #ifndef SCM_MAGIC_SNARFER
2172 #include "srfi/srfi-1.x"
2174 scm_c_extend_primitive_generic
2175 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "map")),
2176 SCM_VARIABLE_REF (scm_c_lookup ("map")));
2177 scm_c_extend_primitive_generic
2178 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "for-each")),
2179 SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
2182 /* End of srfi-1.c. */