1 /* srfi-1.c --- SRFI-1 procedures for Guile
3 * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003 Free Software
6 * This library is free software; you can redistribute it and/or
7 * modify it under the terms of the GNU Lesser General Public
8 * License as published by the Free Software Foundation; either
9 * version 2.1 of the License, or (at your option) any later version.
11 * This library is distributed in the hope that it will be useful,
12 * but 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
22 #include <libguile/lang.h>
26 /* The intent of this file is to gradually replace those Scheme
27 * procedures in srfi-1.scm which extends core primitive procedures,
28 * so that using srfi-1 won't have performance penalties.
30 * Please feel free to contribute any new replacements!
34 srfi1_ilength (SCM sx
)
41 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
42 if (!scm_is_pair (hare
)) return -2;
45 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
46 if (!scm_is_pair (hare
)) return -2;
49 /* For every two steps the hare takes, the tortoise takes one. */
50 tortoise
= SCM_CDR(tortoise
);
52 while (! scm_is_eq (hare
, tortoise
));
54 /* If the tortoise ever catches the hare, then the list must contain
60 equal_trampoline (SCM proc
, SCM arg1
, SCM arg2
)
62 return scm_equal_p (arg1
, arg2
);
66 SCM_DEFINE (scm_srfi1_alist_copy
, "alist-copy", 1, 0, 0,
68 "Return a copy of @var{alist}, copying both the pairs comprising\n"
69 "the list and those making the associations.")
70 #define FUNC_NAME s_scm_srfi1_alist_copy
74 /* ret is the list to return. p is where to append to it, initially &ret
75 then SCM_CDRLOC of the last pair. */
79 for ( ; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
81 elem
= SCM_CAR (alist
);
83 /* each element of alist must be a pair */
84 SCM_ASSERT_TYPE (scm_is_pair (elem
), alist
, SCM_ARG1
, FUNC_NAME
,
87 c
= scm_cons (scm_cons (SCM_CAR (elem
), SCM_CDR (elem
)), SCM_EOL
);
92 /* alist must be a proper list */
93 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (alist
), alist
, SCM_ARG1
, FUNC_NAME
,
100 SCM_DEFINE (scm_srfi1_concatenate
, "concatenate", 1, 0, 0,
102 "Construct a list by appending all lists in @var{lstlst}.\n"
104 "@code{concatenate} is the same as @code{(apply append\n"
105 "@var{lstlst})}. It exists because some Scheme implementations\n"
106 "have a limit on the number of arguments a function takes, which\n"
107 "the @code{apply} might exceed. In Guile there is no such\n"
109 #define FUNC_NAME s_scm_srfi1_concatenate
111 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
112 return scm_append (lstlst
);
117 SCM_DEFINE (scm_srfi1_concatenate_x
, "concatenate!", 1, 0, 0,
119 "Construct a list by appending all lists in @var{lstlst}. Those\n"
120 "lists may be modified to produce the result.\n"
122 "@code{concatenate!} is the same as @code{(apply append!\n"
123 "@var{lstlst})}. It exists because some Scheme implementations\n"
124 "have a limit on the number of arguments a function takes, which\n"
125 "the @code{apply} might exceed. In Guile there is no such\n"
127 #define FUNC_NAME s_scm_srfi1_concatenate
129 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
130 return scm_append_x (lstlst
);
135 SCM_DEFINE (scm_srfi1_count
, "count", 2, 0, 1,
136 (SCM pred
, SCM list1
, SCM rest
),
137 "Return a count of the number of times @var{pred} returns true\n"
138 "when called on elements from the given lists.\n"
140 "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
141 "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
142 "corresponding @var{list1} @dots{} @var{lstN}. The first call is\n"
143 "with the first element of each list, the second with the second\n"
144 "element from each, and so on.\n"
146 "Counting stops when the end of the shortest list is reached.\n"
147 "At least one list must be non-circular.")
148 #define FUNC_NAME s_scm_srfi1_count
153 SCM_VALIDATE_REST_ARGUMENT (rest
);
157 if (scm_is_null (rest
))
160 scm_t_trampoline_1 pred_tramp
;
161 pred_tramp
= scm_trampoline_1 (pred
);
162 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
164 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
165 count
+= scm_is_true (pred_tramp (pred
, SCM_CAR (list1
)));
167 /* check below that list1 is a proper list, and done */
172 else if (scm_is_pair (rest
) && scm_is_null (SCM_CDR (rest
)))
175 scm_t_trampoline_2 pred_tramp
;
178 pred_tramp
= scm_trampoline_2 (pred
);
179 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
181 list2
= SCM_CAR (rest
);
184 if (! scm_is_pair (list1
))
186 if (! scm_is_pair (list2
))
192 count
+= scm_is_true (pred_tramp
193 (pred
, SCM_CAR (list1
), SCM_CAR (list2
)));
194 list1
= SCM_CDR (list1
);
195 list2
= SCM_CDR (list2
);
200 /* three or more lists */
204 /* vec is the list arguments */
205 vec
= scm_vector (scm_cons (list1
, rest
));
206 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
208 /* args is the argument list to pass to pred, same length as vec,
209 re-used for each call */
210 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
214 /* first elem of each list in vec into args, and step those
215 vec entries onto their next element */
216 for (i
= 0, a
= args
, argnum
= 2;
218 i
++, a
= SCM_CDR (a
), argnum
++)
220 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
221 if (! scm_is_pair (lst
))
222 goto check_lst_and_done
;
223 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for pred */
224 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
227 count
+= scm_is_true (scm_apply (pred
, args
, SCM_EOL
));
232 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
233 return scm_from_long (count
);
238 SCM_DEFINE (scm_srfi1_delete
, "delete", 2, 1, 0,
239 (SCM x
, SCM lst
, SCM pred
),
240 "Return a list containing the elements of @var{lst} but with\n"
241 "those equal to @var{x} deleted. The returned elements will be\n"
242 "in the same order as they were in @var{lst}.\n"
244 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
245 "given. An equality call is made just once for each element,\n"
246 "but the order in which the calls are made on the elements is\n"
249 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
250 "given @var{x} is first. This means for instance elements\n"
251 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
253 "@var{lst} is not modified, but the returned list might share a\n"
254 "common tail with @var{lst}.")
255 #define FUNC_NAME s_scm_srfi1_delete
257 scm_t_trampoline_2 equal_p
;
258 SCM ret
, *p
, keeplst
;
260 if (SCM_UNBNDP (pred
))
261 return scm_delete (x
, lst
);
263 equal_p
= scm_trampoline_2 (pred
);
264 SCM_ASSERT (equal_p
, pred
, SCM_ARG3
, FUNC_NAME
);
266 /* ret is the return list being constructed. p is where to append to it,
267 initially &ret then SCM_CDRLOC of the last pair. lst progresses as
268 elements are considered.
270 Elements to be retained are not immediately copied, instead keeplst is
271 the last pair in lst which is to be retained but not yet copied. When
272 there's no more deletions, *p can be set to keeplst to share the
273 remainder of the original lst. (The entire original lst if there's no
274 deletions at all.) */
280 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
282 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
284 /* delete this element, so copy from keeplst (inclusive) to lst
285 (exclusive) onto ret */
286 while (! scm_is_eq (keeplst
, lst
))
288 SCM c
= scm_cons (SCM_CAR (keeplst
), SCM_EOL
);
291 keeplst
= SCM_CDR (keeplst
);
294 keeplst
= SCM_CDR (lst
);
298 /* final retained elements */
301 /* demand that lst was a proper list */
302 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
309 SCM_DEFINE (scm_srfi1_delete_x
, "delete!", 2, 1, 0,
310 (SCM x
, SCM lst
, SCM pred
),
311 "Return a list containing the elements of @var{lst} but with\n"
312 "those equal to @var{x} deleted. The returned elements will be\n"
313 "in the same order as they were in @var{lst}.\n"
315 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
316 "given. An equality call is made just once for each element,\n"
317 "but the order in which the calls are made on the elements is\n"
320 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
321 "given @var{x} is first. This means for instance elements\n"
322 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
324 "@var{lst} may be modified to construct the returned list.")
325 #define FUNC_NAME s_scm_srfi1_delete_x
327 scm_t_trampoline_2 equal_p
;
331 if (SCM_UNBNDP (pred
))
332 return scm_delete_x (x
, lst
);
334 equal_p
= scm_trampoline_2 (pred
);
335 SCM_ASSERT (equal_p
, pred
, SCM_ARG3
, FUNC_NAME
);
337 for (prev
= &lst
, walk
= lst
;
339 walk
= SCM_CDR (walk
))
341 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (walk
))))
342 *prev
= SCM_CDR (walk
);
344 prev
= SCM_CDRLOC (walk
);
347 /* demand the input was a proper list */
348 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk
), walk
, SCM_ARG2
, FUNC_NAME
,"list");
354 SCM_DEFINE (scm_srfi1_delete_duplicates
, "delete-duplicates", 1, 1, 0,
356 "Return a list containing the elements of @var{lst} but without\n"
359 "When elements are equal, only the first in @var{lst} is\n"
360 "retained. Equal elements can be anywhere in @var{lst}, they\n"
361 "don't have to be adjacent. The returned list will have the\n"
362 "retained elements in the same order as they were in @var{lst}.\n"
364 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
365 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
366 "being before @var{y} in @var{lst}. A call is made at most once\n"
367 "for each combination, but the sequence of the calls across the\n"
368 "elements is unspecified.\n"
370 "@var{lst} is not modified, but the return might share a common\n"
371 "tail with @var{lst}.\n"
373 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
374 "it must check each element against all those preceding it. For\n"
375 "long lists it is more efficient to sort and then compare only\n"
376 "adjacent elements.")
377 #define FUNC_NAME s_scm_srfi1_delete_duplicates
379 scm_t_trampoline_2 equal_p
;
380 SCM ret
, *p
, keeplst
, item
, l
;
382 /* ret is the new list constructed. p is where to append, initially &ret
383 then SCM_CDRLOC of the last pair. lst is advanced as each element is
386 Elements retained are not immediately appended to ret, instead keeplst
387 is the last pair in lst which is to be kept but is not yet copied.
388 Initially this is the first pair of lst, since the first element is
391 *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
392 the elements retained, making the equality search loop easy.
394 If an item must be deleted, elements from keeplst (inclusive) to lst
395 (exclusive) must be copied and appended to ret. When there's no more
396 deletions, *p is left set to keeplst, so ret shares structure with the
397 original lst. (ret will be the entire original lst if there are no
400 /* skip to end if an empty list (or something invalid) */
402 if (scm_is_pair (lst
))
404 if (SCM_UNBNDP (pred
))
405 equal_p
= equal_trampoline
;
408 equal_p
= scm_trampoline_2 (pred
);
409 SCM_ASSERT (equal_p
, pred
, SCM_ARG2
, FUNC_NAME
);
415 /* loop over lst elements starting from second */
419 if (! scm_is_pair (lst
))
421 item
= SCM_CAR (lst
);
423 /* loop searching ret upto lst */
424 for (l
= ret
; ! scm_is_eq (l
, lst
); l
= SCM_CDR (l
))
426 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
428 /* duplicate, don't want this element, so copy keeplst
429 (inclusive) to lst (exclusive) onto ret */
430 while (! scm_is_eq (keeplst
, lst
))
432 SCM c
= scm_cons (SCM_CAR (keeplst
), SCM_EOL
);
435 keeplst
= SCM_CDR (keeplst
);
438 keeplst
= SCM_CDR (lst
); /* elem after the one deleted */
446 /* demand that lst was a proper list */
447 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
454 SCM_DEFINE (scm_srfi1_delete_duplicates_x
, "delete-duplicates!", 1, 1, 0,
456 "Return a list containing the elements of @var{lst} but without\n"
459 "When elements are equal, only the first in @var{lst} is\n"
460 "retained. Equal elements can be anywhere in @var{lst}, they\n"
461 "don't have to be adjacent. The returned list will have the\n"
462 "retained elements in the same order as they were in @var{lst}.\n"
464 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
465 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
466 "being before @var{y} in @var{lst}. A call is made at most once\n"
467 "for each combination, but the sequence of the calls across the\n"
468 "elements is unspecified.\n"
470 "@var{lst} may be modified to construct the returned list.\n"
472 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
473 "it must check each element against all those preceding it. For\n"
474 "long lists it is more efficient to sort and then compare only\n"
475 "adjacent elements.")
476 #define FUNC_NAME s_scm_srfi1_delete_duplicates_x
478 scm_t_trampoline_2 equal_p
;
479 SCM ret
, endret
, item
, l
;
481 /* ret is the return list, constructed from the pairs in lst. endret is
482 the last pair of ret, initially the first pair. lst is advanced as
483 elements are considered. */
485 /* skip to end if an empty list (or something invalid) */
487 if (scm_is_pair (lst
))
489 if (SCM_UNBNDP (pred
))
490 equal_p
= equal_trampoline
;
493 equal_p
= scm_trampoline_2 (pred
);
494 SCM_ASSERT (equal_p
, pred
, SCM_ARG2
, FUNC_NAME
);
499 /* loop over lst elements starting from second */
503 if (! scm_is_pair (lst
))
505 item
= SCM_CAR (lst
);
507 /* is item equal to any element from ret to endret (inclusive)? */
511 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
512 break; /* equal, forget this element */
514 if (scm_is_eq (l
, endret
))
516 /* not equal to any, so append this pair */
517 SCM_SETCDR (endret
, lst
);
525 /* terminate, in case last element was deleted */
526 SCM_SETCDR (endret
, SCM_EOL
);
529 /* demand that lst was a proper list */
530 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
537 SCM_DEFINE (scm_srfi1_drop_right
, "drop-right", 2, 0, 0,
539 "Return a new list containing all except the last @var{n}\n"
540 "elements of @var{lst}.")
541 #define FUNC_NAME s_scm_srfi1_drop_right
543 SCM tail
= scm_list_tail (lst
, n
);
546 while (scm_is_pair (tail
))
548 *rend
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
549 rend
= SCM_CDRLOC (*rend
);
552 tail
= SCM_CDR (tail
);
554 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
560 SCM_DEFINE (scm_srfi1_drop_right_x
, "drop-right!", 2, 0, 0,
562 "Return the a list containing the @var{n} last elements of\n"
563 "@var{lst}. @var{lst} may be modified to build the return.")
564 #define FUNC_NAME s_scm_srfi1_drop_right_x
568 if (scm_is_eq (n
, SCM_INUM0
))
571 tail
= scm_list_tail (lst
, n
);
574 /* p and tail work along the list, p being the cdrloc of the cell n steps
576 for ( ; scm_is_pair (tail
); tail
= SCM_CDR (tail
))
579 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
587 SCM_DEFINE (scm_srfi1_drop_while
, "drop-while", 2, 0, 0,
589 "Drop the longest initial prefix of @var{lst} whose elements all\n"
590 "satisfy the predicate @var{pred}.")
591 #define FUNC_NAME s_scm_srfi1_drop_while
593 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (pred
);
594 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
596 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
597 if (scm_is_false (pred_tramp (pred
, SCM_CAR (lst
))))
600 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
607 SCM_DEFINE (scm_srfi1_filter_map
, "filter-map", 2, 0, 1,
608 (SCM proc
, SCM list1
, SCM rest
),
609 "Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
610 "return a list of the results as per SRFI-1 @code{map}, except\n"
611 "that any @code{#f} results are omitted from the list returned.")
612 #define FUNC_NAME s_scm_srfi1_filter_map
614 SCM ret
, *loc
, elem
, newcell
, lst
;
617 SCM_VALIDATE_REST_ARGUMENT (rest
);
622 if (SCM_NULLP (rest
))
625 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
626 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
628 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
630 elem
= proc_tramp (proc
, SCM_CAR (list1
));
631 if (scm_is_true (elem
))
633 newcell
= scm_cons (elem
, SCM_EOL
);
635 loc
= SCM_CDRLOC (newcell
);
639 /* check below that list1 is a proper list, and done */
644 else if (SCM_NULLP (SCM_CDR (rest
)))
647 scm_t_trampoline_2 proc_tramp
= scm_trampoline_2 (proc
);
648 SCM list2
= SCM_CAR (rest
);
649 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
653 if (! scm_is_pair (list1
))
655 if (! scm_is_pair (list2
))
659 goto check_lst_and_done
;
661 elem
= proc_tramp (proc
, SCM_CAR (list1
), SCM_CAR (list2
));
662 if (scm_is_true (elem
))
664 newcell
= scm_cons (elem
, SCM_EOL
);
666 loc
= SCM_CDRLOC (newcell
);
668 list1
= SCM_CDR (list1
);
669 list2
= SCM_CDR (list2
);
674 /* three or more lists */
678 /* vec is the list arguments */
679 vec
= scm_vector (scm_cons (list1
, rest
));
680 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
682 /* args is the argument list to pass to proc, same length as vec,
683 re-used for each call */
684 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
688 /* first elem of each list in vec into args, and step those
689 vec entries onto their next element */
690 for (i
= 0, a
= args
, argnum
= 2;
692 i
++, a
= SCM_CDR (a
), argnum
++)
694 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
695 if (! scm_is_pair (lst
))
696 goto check_lst_and_done
;
697 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for proc */
698 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
701 elem
= scm_apply (proc
, args
, SCM_EOL
);
702 if (scm_is_true (elem
))
704 newcell
= scm_cons (elem
, SCM_EOL
);
706 loc
= SCM_CDRLOC (newcell
);
712 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
718 SCM_DEFINE (scm_srfi1_find
, "find", 2, 0, 0,
720 "Return the first element of @var{lst} which satisfies the\n"
721 "predicate @var{pred}, or return @code{#f} if no such element is\n"
723 #define FUNC_NAME s_scm_srfi1_find
725 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (pred
);
726 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
728 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
730 SCM elem
= SCM_CAR (lst
);
731 if (scm_is_true (pred_tramp (pred
, elem
)))
734 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
741 SCM_DEFINE (scm_srfi1_find_tail
, "find-tail", 2, 0, 0,
743 "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
744 "predicate @var{pred}, or return @code{#f} if no such element is\n"
746 #define FUNC_NAME s_scm_srfi1_find_tail
748 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (pred
);
749 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
751 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
752 if (scm_is_true (pred_tramp (pred
, SCM_CAR (lst
))))
754 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
761 SCM_DEFINE (scm_srfi1_length_plus
, "length+", 1, 0, 0,
763 "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
765 #define FUNC_NAME s_scm_srfi1_length_plus
767 long len
= scm_ilength (lst
);
768 return (len
>= 0 ? SCM_I_MAKINUM (len
) : SCM_BOOL_F
);
773 /* This routine differs from the core list-copy in allowing improper lists.
774 Maybe the core could allow them similarly. */
776 SCM_DEFINE (scm_srfi1_list_copy
, "list-copy", 1, 0, 0,
778 "Return a copy of the given list @var{lst}.\n"
780 "@var{lst} can be a proper or improper list. And if @var{lst}\n"
781 "is not a pair then it's treated as the final tail of an\n"
782 "improper list and simply returned.")
783 #define FUNC_NAME s_scm_srfi1_list_copy
793 while (scm_is_pair (from_here
))
796 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
798 fill_here
= SCM_CDRLOC (c
);
799 from_here
= SCM_CDR (from_here
);
806 SCM_DEFINE (scm_srfi1_lset_adjoin
, "lset-adjoin", 2, 0, 1,
807 (SCM equal
, SCM lst
, SCM rest
),
808 "Add to @var{list} any of the given @var{elem}s not already in\n"
809 "the list. @var{elem}s are @code{cons}ed onto the start of\n"
810 "@var{list} (so the return shares a common tail with\n"
811 "@var{list}), but the order they're added is unspecified.\n"
813 "The given @var{=} procedure is used for comparing elements,\n"
814 "called as @code{(@var{=} listelem elem)}, ie.@: the second\n"
815 "argument is one of the given @var{elem} parameters.\n"
818 "(lset-adjoin eqv? '(1 2 3) 4 1 5) @result{} (5 4 1 2 3)\n"
820 #define FUNC_NAME s_scm_srfi1_lset_adjoin
822 scm_t_trampoline_2 equal_tramp
;
825 equal_tramp
= scm_trampoline_2 (equal
);
826 SCM_ASSERT (equal_tramp
, equal
, SCM_ARG1
, FUNC_NAME
);
827 SCM_VALIDATE_REST_ARGUMENT (rest
);
829 /* It's not clear if duplicates among the `rest' elements are meant to be
830 cast out. The spec says `=' is called as (= list-elem rest-elem),
831 suggesting perhaps not, but the reference implementation shows the
832 "list" at each stage as including those "rest" elements already added.
833 The latter corresponds to what's described for lset-union, so that's
836 for ( ; scm_is_pair (rest
); rest
= SCM_CDR (rest
))
838 elem
= SCM_CAR (rest
);
840 for (l
= lst
; scm_is_pair (l
); l
= SCM_CDR (l
))
841 if (scm_is_true (equal_tramp (equal
, SCM_CAR (l
), elem
)))
842 goto next_elem
; /* elem already in lst, don't add */
844 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(l
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
846 /* elem is not equal to anything already in lst, add it */
847 lst
= scm_cons (elem
, lst
);
858 /* Typechecking for multi-argument MAP and FOR-EACH.
860 Verify that each element of the vector ARGV, except for the first,
861 is a list and return minimum length. Attribute errors to WHO,
862 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
864 check_map_args (SCM argv
,
873 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
875 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
878 if (!(scm_is_null (elt
) || scm_is_pair (elt
)))
882 scm_apply_generic (gf
, scm_cons (proc
, args
));
884 scm_wrong_type_arg (who
, i
+ 2, elt
);
887 elt_len
= srfi1_ilength (elt
);
889 goto check_map_error
;
891 if (len
< 0 || (elt_len
>= 0 && elt_len
< len
))
896 goto check_map_error
;
898 scm_remember_upto_here_1 (argv
);
903 SCM_GPROC (s_srfi1_map
, "map", 2, 0, 1, scm_srfi1_map
, g_srfi1_map
);
905 /* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
906 sequentially, starting with the first element(s). This is used in
907 the Scheme procedure `map-in-order', which guarantees sequential
908 behaviour, is implemented using scm_map. If the behaviour changes,
909 we need to update `map-in-order'.
913 scm_srfi1_map (SCM proc
, SCM arg1
, SCM args
)
914 #define FUNC_NAME s_srfi1_map
920 len
= srfi1_ilength (arg1
);
921 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
923 scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_srfi1_map
);
924 SCM_VALIDATE_REST_ARGUMENT (args
);
925 if (scm_is_null (args
))
927 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
928 SCM_GASSERT2 (call
, g_srfi1_map
, proc
, arg1
, SCM_ARG1
, s_srfi1_map
);
929 SCM_GASSERT2 (len
>= 0, g_srfi1_map
, proc
, arg1
, SCM_ARG2
, s_srfi1_map
);
930 while (SCM_NIMP (arg1
))
932 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
933 pres
= SCM_CDRLOC (*pres
);
934 arg1
= SCM_CDR (arg1
);
938 if (scm_is_null (SCM_CDR (args
)))
940 SCM arg2
= SCM_CAR (args
);
941 int len2
= srfi1_ilength (arg2
);
942 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
943 SCM_GASSERTn (call
, g_srfi1_map
,
944 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_map
);
945 if (len
< 0 || (len2
>= 0 && len2
< len
))
947 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
948 && len
>= 0 && len2
>= -1,
950 scm_cons2 (proc
, arg1
, args
),
951 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
955 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
956 pres
= SCM_CDRLOC (*pres
);
957 arg1
= SCM_CDR (arg1
);
958 arg2
= SCM_CDR (arg2
);
963 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
964 len
= check_map_args (args
, len
, g_srfi1_map
, proc
, arg1
, s_srfi1_map
);
968 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
970 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
971 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
972 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
974 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
975 pres
= SCM_CDRLOC (*pres
);
982 SCM_REGISTER_PROC (s_srfi1_map_in_order
, "map-in-order", 2, 0, 1, scm_srfi1_map
);
984 SCM_GPROC (s_srfi1_for_each
, "for-each", 2, 0, 1, scm_srfi1_for_each
, g_srfi1_for_each
);
987 scm_srfi1_for_each (SCM proc
, SCM arg1
, SCM args
)
988 #define FUNC_NAME s_srfi1_for_each
991 len
= srfi1_ilength (arg1
);
992 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
993 g_srfi1_for_each
, scm_cons2 (proc
, arg1
, args
),
994 SCM_ARG2
, s_srfi1_for_each
);
995 SCM_VALIDATE_REST_ARGUMENT (args
);
996 if (scm_is_null (args
))
998 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
999 SCM_GASSERT2 (call
, g_srfi1_for_each
, proc
, arg1
,
1000 SCM_ARG1
, s_srfi1_for_each
);
1001 SCM_GASSERT2 (len
>= 0, g_srfi1_for_each
, proc
, arg1
,
1002 SCM_ARG2
, s_srfi1_map
);
1003 while (SCM_NIMP (arg1
))
1005 call (proc
, SCM_CAR (arg1
));
1006 arg1
= SCM_CDR (arg1
);
1008 return SCM_UNSPECIFIED
;
1010 if (scm_is_null (SCM_CDR (args
)))
1012 SCM arg2
= SCM_CAR (args
);
1013 int len2
= srfi1_ilength (arg2
);
1014 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
1015 SCM_GASSERTn (call
, g_srfi1_for_each
,
1016 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_for_each
);
1017 if (len
< 0 || (len2
>= 0 && len2
< len
))
1019 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
1020 && len
>= 0 && len2
>= -1,
1022 scm_cons2 (proc
, arg1
, args
),
1023 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
1027 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
1028 arg1
= SCM_CDR (arg1
);
1029 arg2
= SCM_CDR (arg2
);
1032 return SCM_UNSPECIFIED
;
1034 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
1035 len
= check_map_args (args
, len
, g_srfi1_for_each
, proc
, arg1
,
1040 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
1042 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
1043 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
1044 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
1046 scm_apply (proc
, arg1
, SCM_EOL
);
1049 return SCM_UNSPECIFIED
;
1054 SCM_DEFINE (scm_srfi1_member
, "member", 2, 1, 0,
1055 (SCM x
, SCM lst
, SCM pred
),
1056 "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
1057 "to @var{x}. If @var{x} does not appear in @var{lst}, return\n"
1060 "Equality is determined by @code{equal?}, or by the equality\n"
1061 "predicate @var{=} if given. @var{=} is called @code{(= @var{x}\n"
1062 "elem)}, ie.@: with the given @var{x} first, so for example to\n"
1063 "find the first element greater than 5,\n"
1066 "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
1069 "This version of @code{member} extends the core @code{member} by\n"
1070 "accepting an equality predicate.")
1071 #define FUNC_NAME s_scm_srfi1_member
1073 scm_t_trampoline_2 equal_p
;
1074 SCM_VALIDATE_LIST (2, lst
);
1075 if (SCM_UNBNDP (pred
))
1076 equal_p
= equal_trampoline
;
1079 equal_p
= scm_trampoline_2 (pred
);
1080 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
1082 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
1084 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
1091 SCM_DEFINE (scm_srfi1_assoc
, "assoc", 2, 1, 0,
1092 (SCM key
, SCM alist
, SCM pred
),
1093 "Behaves like @code{assq} but uses third argument @var{pred?}\n"
1094 "for key comparison. If @var{pred?} is not supplied,\n"
1095 "@code{equal?} is used. (Extended from R5RS.)\n")
1096 #define FUNC_NAME s_scm_srfi1_assoc
1099 scm_t_trampoline_2 equal_p
;
1100 if (SCM_UNBNDP (pred
))
1101 equal_p
= equal_trampoline
;
1104 equal_p
= scm_trampoline_2 (pred
);
1105 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
1107 for(; scm_is_pair (ls
); ls
= SCM_CDR (ls
))
1109 SCM tmp
= SCM_CAR (ls
);
1110 SCM_ASSERT_TYPE (scm_is_pair (tmp
), alist
, SCM_ARG2
, FUNC_NAME
,
1111 "association list");
1112 if (scm_is_true (equal_p (pred
, SCM_CAR (tmp
), key
)))
1115 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls
), alist
, SCM_ARG2
, FUNC_NAME
,
1116 "association list");
1121 SCM_DEFINE (scm_srfi1_partition
, "partition", 2, 0, 0,
1122 (SCM pred
, SCM list
),
1123 "Partition the elements of @var{list} with predicate @var{pred}.\n"
1124 "Return two values: the list of elements satifying @var{pred} and\n"
1125 "the list of elements @emph{not} satisfying @var{pred}. The order\n"
1126 "of the output lists follows the order of @var{list}. @var{list}\n"
1127 "is not mutated. One of the output lists may share memory with @var{list}.\n")
1128 #define FUNC_NAME s_scm_srfi1_partition
1130 /* In this implementation, the output lists don't share memory with
1131 list, because it's probably not worth the effort. */
1132 scm_t_trampoline_1 call
= scm_trampoline_1(pred
);
1133 SCM kept
= scm_cons(SCM_EOL
, SCM_EOL
);
1134 SCM kept_tail
= kept
;
1135 SCM dropped
= scm_cons(SCM_EOL
, SCM_EOL
);
1136 SCM dropped_tail
= dropped
;
1138 SCM_ASSERT(call
, pred
, 2, FUNC_NAME
);
1140 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR(list
)) {
1141 SCM elt
= SCM_CAR(list
);
1142 SCM new_tail
= scm_cons(SCM_CAR(list
), SCM_EOL
);
1143 if (scm_is_true (call (pred
, elt
))) {
1144 SCM_SETCDR(kept_tail
, new_tail
);
1145 kept_tail
= new_tail
;
1148 SCM_SETCDR(dropped_tail
, new_tail
);
1149 dropped_tail
= new_tail
;
1152 /* re-use the initial conses for the values list */
1153 SCM_SETCAR(kept
, SCM_CDR(kept
));
1154 SCM_SETCDR(kept
, dropped
);
1155 SCM_SETCAR(dropped
, SCM_CDR(dropped
));
1156 SCM_SETCDR(dropped
, SCM_EOL
);
1157 return scm_values(kept
);
1162 SCM_DEFINE (scm_srfi1_partition_x
, "partition!", 2, 0, 0,
1163 (SCM pred
, SCM lst
),
1164 "Split @var{lst} into those elements which do and don't satisfy\n"
1165 "the predicate @var{pred}.\n"
1167 "The return is two values (@pxref{Multiple Values}), the first\n"
1168 "being a list of all elements from @var{lst} which satisfy\n"
1169 "@var{pred}, the second a list of those which do not.\n"
1171 "The elements in the result lists are in the same order as in\n"
1172 "@var{lst} but the order in which the calls @code{(@var{pred}\n"
1173 "elem)} are made on the list elements is unspecified.\n"
1175 "@var{lst} may be modified to construct the return lists.")
1176 #define FUNC_NAME s_scm_srfi1_partition_x
1178 SCM tlst
, flst
, *tp
, *fp
;
1179 scm_t_trampoline_1 pred_tramp
;
1181 pred_tramp
= scm_trampoline_1 (pred
);
1182 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1184 /* tlst and flst are the lists of true and false elements. tp and fp are
1185 where to store to append to them, initially &tlst and &flst, then
1186 SCM_CDRLOC of the last pair in the respective lists. */
1193 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1195 if (scm_is_true (pred_tramp (pred
, SCM_CAR (lst
))))
1198 tp
= SCM_CDRLOC (lst
);
1203 fp
= SCM_CDRLOC (lst
);
1207 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1209 /* terminate whichever didn't get the last element(s) */
1213 return scm_values (scm_list_2 (tlst
, flst
));
1218 SCM_DEFINE (scm_srfi1_reduce
, "reduce", 3, 0, 0,
1219 (SCM proc
, SCM def
, SCM lst
),
1220 "@code{reduce} is a variant of @code{fold}, where the first call\n"
1221 "to @var{proc} is on two elements from @var{lst}, rather than\n"
1222 "one element and a given initial value.\n"
1224 "If @var{lst} is empty, @code{reduce} returns @var{def} (this is\n"
1225 "the only use for @var{def}). If @var{lst} has just one element\n"
1226 "then that's the return value. Otherwise @var{proc} is called\n"
1227 "on the elements of @var{lst}.\n"
1229 "Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
1230 "@var{previous})}, where @var{elem} is from @var{lst} (the\n"
1231 "second and subsequent elements of @var{lst}), and\n"
1232 "@var{previous} is the return from the previous call to\n"
1233 "@var{proc}. The first element of @var{lst} is the\n"
1234 "@var{previous} for the first call to @var{proc}.\n"
1236 "For example, the following adds a list of numbers, the calls\n"
1237 "made to @code{+} are shown. (Of course @code{+} accepts\n"
1238 "multiple arguments and can add a list directly, with\n"
1242 "(reduce + 0 '(5 6 7)) @result{} 18\n"
1244 "(+ 6 5) @result{} 11\n"
1245 "(+ 7 11) @result{} 18\n"
1248 "@code{reduce} can be used instead of @code{fold} where the\n"
1249 "@var{init} value is an ``identity'', meaning a value which\n"
1250 "under @var{proc} doesn't change the result, in this case 0 is\n"
1251 "an identity since @code{(+ 5 0)} is just 5. @code{reduce}\n"
1252 "avoids that unnecessary call.")
1253 #define FUNC_NAME s_scm_srfi1_reduce
1255 scm_t_trampoline_2 proc_tramp
= scm_trampoline_2 (proc
);
1258 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
1260 ret
= def
; /* if lst is empty */
1261 if (scm_is_pair (lst
))
1263 ret
= SCM_CAR (lst
); /* if lst has one element */
1265 for (lst
= SCM_CDR (lst
); scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1266 ret
= proc_tramp (proc
, SCM_CAR (lst
), ret
);
1269 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG3
, FUNC_NAME
, "list");
1275 SCM_DEFINE (scm_srfi1_reduce_right
, "reduce-right", 3, 0, 0,
1276 (SCM proc
, SCM def
, SCM lst
),
1277 "@code{reduce-right} is a variant of @code{fold-right}, where\n"
1278 "the first call to @var{proc} is on two elements from @var{lst},\n"
1279 "rather than one element and a given initial value.\n"
1281 "If @var{lst} is empty, @code{reduce-right} returns @var{def}\n"
1282 "(this is the only use for @var{def}). If @var{lst} has just\n"
1283 "one element then that's the return value. Otherwise @var{proc}\n"
1284 "is called on the elements of @var{lst}.\n"
1286 "Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
1287 "@var{previous})}, where @var{elem} is from @var{lst} (the\n"
1288 "second last and then working back to the first element of\n"
1289 "@var{lst}), and @var{previous} is the return from the previous\n"
1290 "call to @var{proc}. The last element of @var{lst} is the\n"
1291 "@var{previous} for the first call to @var{proc}.\n"
1293 "For example, the following adds a list of numbers, the calls\n"
1294 "made to @code{+} are shown. (Of course @code{+} accepts\n"
1295 "multiple arguments and can add a list directly, with\n"
1299 "(reduce-right + 0 '(5 6 7)) @result{} 18\n"
1301 "(+ 6 7) @result{} 13\n"
1302 "(+ 5 13) @result{} 18\n"
1305 "@code{reduce-right} can be used instead of @code{fold-right}\n"
1306 "where the @var{init} value is an ``identity'', meaning a value\n"
1307 "which under @var{proc} doesn't change the result, in this case\n"
1308 "0 is an identity since @code{(+ 7 0)} is just 5.\n"
1309 "@code{reduce-right} avoids that unnecessary call.\n"
1311 "@code{reduce} should be preferred over @code{reduce-right} if\n"
1312 "the order of processing doesn't matter, or can be arranged\n"
1313 "either way, since @code{reduce} is a little more efficient.")
1314 #define FUNC_NAME s_scm_srfi1_reduce_right
1316 /* To work backwards across a list requires either repeatedly traversing
1317 to get each previous element, or using some memory for a reversed or
1318 random-access form. Repeated traversal might not be too terrible, but
1319 is of course quadratic complexity and hence to be avoided in case LST
1320 is long. A vector is preferred over a reversed list since it's more
1321 compact and is less work for the gc to collect. */
1323 scm_t_trampoline_2 proc_tramp
= scm_trampoline_2 (proc
);
1327 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
1329 if (SCM_NULL_OR_NIL_P (lst
))
1332 vec
= scm_vector (lst
);
1333 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
1335 ret
= SCM_SIMPLE_VECTOR_REF (vec
, len
-1);
1336 for (i
= len
-2; i
>= 0; i
--)
1337 ret
= proc_tramp (proc
, SCM_SIMPLE_VECTOR_REF (vec
, i
), ret
);
1344 SCM_DEFINE (scm_srfi1_remove
, "remove", 2, 0, 0,
1345 (SCM pred
, SCM list
),
1346 "Return a list containing all elements from @var{lst} which do\n"
1347 "not satisfy the predicate @var{pred}. The elements in the\n"
1348 "result list have the same order as in @var{lst}. The order in\n"
1349 "which @var{pred} is applied to the list elements is not\n"
1351 #define FUNC_NAME s_scm_srfi1_remove
1353 scm_t_trampoline_1 call
= scm_trampoline_1 (pred
);
1357 SCM_ASSERT (call
, pred
, 1, FUNC_NAME
);
1358 SCM_VALIDATE_LIST (2, list
);
1360 for (prev
= &res
, walk
= list
;
1362 walk
= SCM_CDR (walk
))
1364 if (scm_is_false (call (pred
, SCM_CAR (walk
))))
1366 *prev
= scm_cons (SCM_CAR (walk
), SCM_EOL
);
1367 prev
= SCM_CDRLOC (*prev
);
1376 SCM_DEFINE (scm_srfi1_remove_x
, "remove!", 2, 0, 0,
1377 (SCM pred
, SCM list
),
1378 "Return a list containing all elements from @var{list} which do\n"
1379 "not satisfy the predicate @var{pred}. The elements in the\n"
1380 "result list have the same order as in @var{list}. The order in\n"
1381 "which @var{pred} is applied to the list elements is not\n"
1382 "specified. @var{list} may be modified to build the return\n"
1384 #define FUNC_NAME s_scm_srfi1_remove_x
1386 scm_t_trampoline_1 call
= scm_trampoline_1 (pred
);
1389 SCM_ASSERT (call
, pred
, 1, FUNC_NAME
);
1390 SCM_VALIDATE_LIST (2, list
);
1392 for (prev
= &list
, walk
= list
;
1394 walk
= SCM_CDR (walk
))
1396 if (scm_is_false (call (pred
, SCM_CAR (walk
))))
1397 prev
= SCM_CDRLOC (walk
);
1399 *prev
= SCM_CDR (walk
);
1407 SCM_DEFINE (scm_srfi1_span
, "span", 2, 0, 0,
1408 (SCM pred
, SCM lst
),
1409 "Return two values, the longest initial prefix of @var{lst}\n"
1410 "whose elements all satisfy the predicate @var{pred}, and the\n"
1411 "remainder of @var{lst}.")
1412 #define FUNC_NAME s_scm_srfi1_span
1414 scm_t_trampoline_1 pred_tramp
;
1417 pred_tramp
= scm_trampoline_1 (pred
);
1418 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1422 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1424 SCM elem
= SCM_CAR (lst
);
1425 if (scm_is_false (pred_tramp (pred
, elem
)))
1428 /* want this elem, tack it onto the end of ret */
1429 *p
= scm_cons (elem
, SCM_EOL
);
1430 p
= SCM_CDRLOC (*p
);
1432 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1435 return scm_values (scm_list_2 (ret
, lst
));
1440 SCM_DEFINE (scm_srfi1_span_x
, "span!", 2, 0, 0,
1441 (SCM pred
, SCM lst
),
1442 "Return two values, the longest initial prefix of @var{lst}\n"
1443 "whose elements all satisfy the predicate @var{pred}, and the\n"
1444 "remainder of @var{lst}. @var{lst} may be modified to form the\n"
1446 #define FUNC_NAME s_scm_srfi1_span_x
1449 scm_t_trampoline_1 pred_tramp
;
1451 pred_tramp
= scm_trampoline_1 (pred
);
1452 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1455 for (upto
= lst
; scm_is_pair (upto
); upto
= SCM_CDR (upto
))
1457 if (scm_is_false (pred_tramp (pred
, SCM_CAR (upto
))))
1460 /* want this element */
1461 p
= SCM_CDRLOC (upto
);
1463 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1467 return scm_values (scm_list_2 (lst
, upto
));
1472 SCM_DEFINE (scm_srfi1_split_at
, "split-at", 2, 0, 0,
1474 "Return two values (multiple values), being a list of the\n"
1475 "elements before index @var{n} in @var{lst}, and a list of those\n"
1477 #define FUNC_NAME s_scm_srfi1_split_at
1480 /* pre is a list of elements before the i split point, loc is the CDRLOC
1481 of the last cell, ie. where to store to append to it */
1485 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1487 SCM_VALIDATE_CONS (SCM_ARG1
, lst
);
1489 *loc
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
1490 loc
= SCM_CDRLOC (*loc
);
1493 return scm_values (scm_list_2 (pre
, lst
));
1498 SCM_DEFINE (scm_srfi1_split_at_x
, "split-at!", 2, 0, 0,
1500 "Return two values (multiple values), being a list of the\n"
1501 "elements before index @var{n} in @var{lst}, and a list of those\n"
1502 "after. @var{lst} is modified to form those values.")
1503 #define FUNC_NAME s_scm_srfi1_split_at
1509 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1511 SCM_VALIDATE_CONS (SCM_ARG1
, upto
);
1513 loc
= SCM_CDRLOC (upto
);
1514 upto
= SCM_CDR (upto
);
1518 return scm_values (scm_list_2 (lst
, upto
));
1523 SCM_DEFINE (scm_srfi1_take_x
, "take!", 2, 0, 0,
1525 "Return a list containing the first @var{n} elements of\n"
1527 #define FUNC_NAME s_scm_srfi1_take_x
1532 SCM_VALIDATE_INUM_MIN_COPY (SCM_ARG2
, n
, 0, nn
);
1537 pos
= scm_list_tail (lst
, SCM_I_MAKINUM (nn
- 1));
1539 /* Must have at least one cell left, mustn't have reached the end of an
1540 n-1 element list. SCM_VALIDATE_CONS here gives the same error as
1541 scm_list_tail does on say an n-2 element list, though perhaps a range
1542 error would make more sense (for both). */
1543 SCM_VALIDATE_CONS (SCM_ARG1
, pos
);
1545 SCM_SETCDR (pos
, SCM_EOL
);
1551 SCM_DEFINE (scm_srfi1_take_right
, "take-right", 2, 0, 0,
1553 "Return the a list containing the @var{n} last elements of\n"
1555 #define FUNC_NAME s_scm_srfi1_take_right
1557 SCM tail
= scm_list_tail (lst
, n
);
1558 while (scm_is_pair (tail
))
1560 lst
= SCM_CDR (lst
);
1561 tail
= SCM_CDR (tail
);
1563 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
1569 SCM_DEFINE (scm_srfi1_take_while
, "take-while", 2, 0, 0,
1570 (SCM pred
, SCM lst
),
1571 "Return a new list which is the longest initial prefix of\n"
1572 "@var{lst} whose elements all satisfy the predicate @var{pred}.")
1573 #define FUNC_NAME s_scm_srfi1_take_while
1575 scm_t_trampoline_1 pred_tramp
;
1578 pred_tramp
= scm_trampoline_1 (pred
);
1579 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1583 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1585 SCM elem
= SCM_CAR (lst
);
1586 if (scm_is_false (pred_tramp (pred
, elem
)))
1589 /* want this elem, tack it onto the end of ret */
1590 *p
= scm_cons (elem
, SCM_EOL
);
1591 p
= SCM_CDRLOC (*p
);
1593 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1601 SCM_DEFINE (scm_srfi1_take_while_x
, "take-while!", 2, 0, 0,
1602 (SCM pred
, SCM lst
),
1603 "Return the longest initial prefix of @var{lst} whose elements\n"
1604 "all satisfy the predicate @var{pred}. @var{lst} may be\n"
1605 "modified to form the return.")
1606 #define FUNC_NAME s_scm_srfi1_take_while_x
1609 scm_t_trampoline_1 pred_tramp
;
1611 pred_tramp
= scm_trampoline_1 (pred
);
1612 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1615 for (upto
= lst
; scm_is_pair (upto
); upto
= SCM_CDR (upto
))
1617 if (scm_is_false (pred_tramp (pred
, SCM_CAR (upto
))))
1620 /* want this element */
1621 p
= SCM_CDRLOC (upto
);
1623 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1633 scm_init_srfi_1 (void)
1635 SCM the_root_module
= scm_lookup_closure_module (SCM_BOOL_F
);
1636 #ifndef SCM_MAGIC_SNARFER
1637 #include "srfi/srfi-1.x"
1639 scm_c_extend_primitive_generic
1640 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "map")),
1641 SCM_VARIABLE_REF (scm_c_lookup ("map")));
1642 scm_c_extend_primitive_generic
1643 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "for-each")),
1644 SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
1647 /* End of srfi-1.c. */