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_break
, "break", 2, 0, 0,
102 "Return two values, the longest initial prefix of @var{lst}\n"
103 "whose elements all fail the predicate @var{pred}, and the\n"
104 "remainder of @var{lst}.\n"
106 "Note that the name @code{break} conflicts with the @code{break}\n"
107 "binding established by @code{while}. Applications wanting to\n"
108 "use @code{break} from within a @code{while} loop will need to\n"
109 "make a new define under a different name.")
110 #define FUNC_NAME s_scm_srfi1_break
112 scm_t_trampoline_1 pred_tramp
;
115 pred_tramp
= scm_trampoline_1 (pred
);
116 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
120 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
122 SCM elem
= SCM_CAR (lst
);
123 if (scm_is_true (pred_tramp (pred
, elem
)))
126 /* want this elem, tack it onto the end of ret */
127 *p
= scm_cons (elem
, SCM_EOL
);
130 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
133 return scm_values (scm_list_2 (ret
, lst
));
138 SCM_DEFINE (scm_srfi1_break_x
, "break!", 2, 0, 0,
140 "Return two values, the longest initial prefix of @var{lst}\n"
141 "whose elements all fail the predicate @var{pred}, and the\n"
142 "remainder of @var{lst}. @var{lst} may be modified to form the\n"
144 #define FUNC_NAME s_scm_srfi1_break_x
147 scm_t_trampoline_1 pred_tramp
;
149 pred_tramp
= scm_trampoline_1 (pred
);
150 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
153 for (upto
= lst
; scm_is_pair (upto
); upto
= SCM_CDR (upto
))
155 if (scm_is_true (pred_tramp (pred
, SCM_CAR (upto
))))
158 /* want this element */
159 p
= SCM_CDRLOC (upto
);
161 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
165 return scm_values (scm_list_2 (lst
, upto
));
170 SCM_DEFINE (scm_srfi1_concatenate
, "concatenate", 1, 0, 0,
172 "Construct a list by appending all lists in @var{lstlst}.\n"
174 "@code{concatenate} is the same as @code{(apply append\n"
175 "@var{lstlst})}. It exists because some Scheme implementations\n"
176 "have a limit on the number of arguments a function takes, which\n"
177 "the @code{apply} might exceed. In Guile there is no such\n"
179 #define FUNC_NAME s_scm_srfi1_concatenate
181 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
182 return scm_append (lstlst
);
187 SCM_DEFINE (scm_srfi1_concatenate_x
, "concatenate!", 1, 0, 0,
189 "Construct a list by appending all lists in @var{lstlst}. Those\n"
190 "lists may be modified to produce the result.\n"
192 "@code{concatenate!} is the same as @code{(apply append!\n"
193 "@var{lstlst})}. It exists because some Scheme implementations\n"
194 "have a limit on the number of arguments a function takes, which\n"
195 "the @code{apply} might exceed. In Guile there is no such\n"
197 #define FUNC_NAME s_scm_srfi1_concatenate
199 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
200 return scm_append_x (lstlst
);
205 SCM_DEFINE (scm_srfi1_count
, "count", 2, 0, 1,
206 (SCM pred
, SCM list1
, SCM rest
),
207 "Return a count of the number of times @var{pred} returns true\n"
208 "when called on elements from the given lists.\n"
210 "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
211 "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
212 "corresponding @var{list1} @dots{} @var{lstN}. The first call is\n"
213 "with the first element of each list, the second with the second\n"
214 "element from each, and so on.\n"
216 "Counting stops when the end of the shortest list is reached.\n"
217 "At least one list must be non-circular.")
218 #define FUNC_NAME s_scm_srfi1_count
223 SCM_VALIDATE_REST_ARGUMENT (rest
);
227 if (scm_is_null (rest
))
230 scm_t_trampoline_1 pred_tramp
;
231 pred_tramp
= scm_trampoline_1 (pred
);
232 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
234 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
235 count
+= scm_is_true (pred_tramp (pred
, SCM_CAR (list1
)));
237 /* check below that list1 is a proper list, and done */
242 else if (scm_is_pair (rest
) && scm_is_null (SCM_CDR (rest
)))
245 scm_t_trampoline_2 pred_tramp
;
248 pred_tramp
= scm_trampoline_2 (pred
);
249 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
251 list2
= SCM_CAR (rest
);
254 if (! scm_is_pair (list1
))
256 if (! scm_is_pair (list2
))
262 count
+= scm_is_true (pred_tramp
263 (pred
, SCM_CAR (list1
), SCM_CAR (list2
)));
264 list1
= SCM_CDR (list1
);
265 list2
= SCM_CDR (list2
);
270 /* three or more lists */
274 /* vec is the list arguments */
275 vec
= scm_vector (scm_cons (list1
, rest
));
276 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
278 /* args is the argument list to pass to pred, same length as vec,
279 re-used for each call */
280 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
284 /* first elem of each list in vec into args, and step those
285 vec entries onto their next element */
286 for (i
= 0, a
= args
, argnum
= 2;
288 i
++, a
= SCM_CDR (a
), argnum
++)
290 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
291 if (! scm_is_pair (lst
))
292 goto check_lst_and_done
;
293 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for pred */
294 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
297 count
+= scm_is_true (scm_apply (pred
, args
, SCM_EOL
));
302 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
303 return scm_from_long (count
);
308 SCM_DEFINE (scm_srfi1_delete
, "delete", 2, 1, 0,
309 (SCM x
, SCM lst
, SCM pred
),
310 "Return a list containing the elements of @var{lst} but with\n"
311 "those equal to @var{x} deleted. The returned elements will be\n"
312 "in the same order as they were in @var{lst}.\n"
314 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
315 "given. An equality call is made just once for each element,\n"
316 "but the order in which the calls are made on the elements is\n"
319 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
320 "given @var{x} is first. This means for instance elements\n"
321 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
323 "@var{lst} is not modified, but the returned list might share a\n"
324 "common tail with @var{lst}.")
325 #define FUNC_NAME s_scm_srfi1_delete
327 scm_t_trampoline_2 equal_p
;
328 SCM ret
, *p
, keeplst
;
330 if (SCM_UNBNDP (pred
))
331 return scm_delete (x
, lst
);
333 equal_p
= scm_trampoline_2 (pred
);
334 SCM_ASSERT (equal_p
, pred
, SCM_ARG3
, FUNC_NAME
);
336 /* ret is the return list being constructed. p is where to append to it,
337 initially &ret then SCM_CDRLOC of the last pair. lst progresses as
338 elements are considered.
340 Elements to be retained are not immediately copied, instead keeplst is
341 the last pair in lst which is to be retained but not yet copied. When
342 there's no more deletions, *p can be set to keeplst to share the
343 remainder of the original lst. (The entire original lst if there's no
344 deletions at all.) */
350 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
352 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
354 /* delete this element, so copy from keeplst (inclusive) to lst
355 (exclusive) onto ret */
356 while (! scm_is_eq (keeplst
, lst
))
358 SCM c
= scm_cons (SCM_CAR (keeplst
), SCM_EOL
);
361 keeplst
= SCM_CDR (keeplst
);
364 keeplst
= SCM_CDR (lst
);
368 /* final retained elements */
371 /* demand that lst was a proper list */
372 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
379 SCM_DEFINE (scm_srfi1_delete_x
, "delete!", 2, 1, 0,
380 (SCM x
, SCM lst
, SCM pred
),
381 "Return a list containing the elements of @var{lst} but with\n"
382 "those equal to @var{x} deleted. The returned elements will be\n"
383 "in the same order as they were in @var{lst}.\n"
385 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
386 "given. An equality call is made just once for each element,\n"
387 "but the order in which the calls are made on the elements is\n"
390 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
391 "given @var{x} is first. This means for instance elements\n"
392 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
394 "@var{lst} may be modified to construct the returned list.")
395 #define FUNC_NAME s_scm_srfi1_delete_x
397 scm_t_trampoline_2 equal_p
;
401 if (SCM_UNBNDP (pred
))
402 return scm_delete_x (x
, lst
);
404 equal_p
= scm_trampoline_2 (pred
);
405 SCM_ASSERT (equal_p
, pred
, SCM_ARG3
, FUNC_NAME
);
407 for (prev
= &lst
, walk
= lst
;
409 walk
= SCM_CDR (walk
))
411 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (walk
))))
412 *prev
= SCM_CDR (walk
);
414 prev
= SCM_CDRLOC (walk
);
417 /* demand the input was a proper list */
418 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk
), walk
, SCM_ARG2
, FUNC_NAME
,"list");
424 SCM_DEFINE (scm_srfi1_delete_duplicates
, "delete-duplicates", 1, 1, 0,
426 "Return a list containing the elements of @var{lst} but without\n"
429 "When elements are equal, only the first in @var{lst} is\n"
430 "retained. Equal elements can be anywhere in @var{lst}, they\n"
431 "don't have to be adjacent. The returned list will have the\n"
432 "retained elements in the same order as they were in @var{lst}.\n"
434 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
435 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
436 "being before @var{y} in @var{lst}. A call is made at most once\n"
437 "for each combination, but the sequence of the calls across the\n"
438 "elements is unspecified.\n"
440 "@var{lst} is not modified, but the return might share a common\n"
441 "tail with @var{lst}.\n"
443 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
444 "it must check each element against all those preceding it. For\n"
445 "long lists it is more efficient to sort and then compare only\n"
446 "adjacent elements.")
447 #define FUNC_NAME s_scm_srfi1_delete_duplicates
449 scm_t_trampoline_2 equal_p
;
450 SCM ret
, *p
, keeplst
, item
, l
;
452 /* ret is the new list constructed. p is where to append, initially &ret
453 then SCM_CDRLOC of the last pair. lst is advanced as each element is
456 Elements retained are not immediately appended to ret, instead keeplst
457 is the last pair in lst which is to be kept but is not yet copied.
458 Initially this is the first pair of lst, since the first element is
461 *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
462 the elements retained, making the equality search loop easy.
464 If an item must be deleted, elements from keeplst (inclusive) to lst
465 (exclusive) must be copied and appended to ret. When there's no more
466 deletions, *p is left set to keeplst, so ret shares structure with the
467 original lst. (ret will be the entire original lst if there are no
470 /* skip to end if an empty list (or something invalid) */
472 if (scm_is_pair (lst
))
474 if (SCM_UNBNDP (pred
))
475 equal_p
= equal_trampoline
;
478 equal_p
= scm_trampoline_2 (pred
);
479 SCM_ASSERT (equal_p
, pred
, SCM_ARG2
, FUNC_NAME
);
485 /* loop over lst elements starting from second */
489 if (! scm_is_pair (lst
))
491 item
= SCM_CAR (lst
);
493 /* loop searching ret upto lst */
494 for (l
= ret
; ! scm_is_eq (l
, lst
); l
= SCM_CDR (l
))
496 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
498 /* duplicate, don't want this element, so copy keeplst
499 (inclusive) to lst (exclusive) onto ret */
500 while (! scm_is_eq (keeplst
, lst
))
502 SCM c
= scm_cons (SCM_CAR (keeplst
), SCM_EOL
);
505 keeplst
= SCM_CDR (keeplst
);
508 keeplst
= SCM_CDR (lst
); /* elem after the one deleted */
516 /* demand that lst was a proper list */
517 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
524 SCM_DEFINE (scm_srfi1_delete_duplicates_x
, "delete-duplicates!", 1, 1, 0,
526 "Return a list containing the elements of @var{lst} but without\n"
529 "When elements are equal, only the first in @var{lst} is\n"
530 "retained. Equal elements can be anywhere in @var{lst}, they\n"
531 "don't have to be adjacent. The returned list will have the\n"
532 "retained elements in the same order as they were in @var{lst}.\n"
534 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
535 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
536 "being before @var{y} in @var{lst}. A call is made at most once\n"
537 "for each combination, but the sequence of the calls across the\n"
538 "elements is unspecified.\n"
540 "@var{lst} may be modified to construct the returned list.\n"
542 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
543 "it must check each element against all those preceding it. For\n"
544 "long lists it is more efficient to sort and then compare only\n"
545 "adjacent elements.")
546 #define FUNC_NAME s_scm_srfi1_delete_duplicates_x
548 scm_t_trampoline_2 equal_p
;
549 SCM ret
, endret
, item
, l
;
551 /* ret is the return list, constructed from the pairs in lst. endret is
552 the last pair of ret, initially the first pair. lst is advanced as
553 elements are considered. */
555 /* skip to end if an empty list (or something invalid) */
557 if (scm_is_pair (lst
))
559 if (SCM_UNBNDP (pred
))
560 equal_p
= equal_trampoline
;
563 equal_p
= scm_trampoline_2 (pred
);
564 SCM_ASSERT (equal_p
, pred
, SCM_ARG2
, FUNC_NAME
);
569 /* loop over lst elements starting from second */
573 if (! scm_is_pair (lst
))
575 item
= SCM_CAR (lst
);
577 /* is item equal to any element from ret to endret (inclusive)? */
581 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
582 break; /* equal, forget this element */
584 if (scm_is_eq (l
, endret
))
586 /* not equal to any, so append this pair */
587 SCM_SETCDR (endret
, lst
);
595 /* terminate, in case last element was deleted */
596 SCM_SETCDR (endret
, SCM_EOL
);
599 /* demand that lst was a proper list */
600 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
607 SCM_DEFINE (scm_srfi1_drop_right
, "drop-right", 2, 0, 0,
609 "Return a new list containing all except the last @var{n}\n"
610 "elements of @var{lst}.")
611 #define FUNC_NAME s_scm_srfi1_drop_right
613 SCM tail
= scm_list_tail (lst
, n
);
616 while (scm_is_pair (tail
))
618 *rend
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
619 rend
= SCM_CDRLOC (*rend
);
622 tail
= SCM_CDR (tail
);
624 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
630 SCM_DEFINE (scm_srfi1_drop_right_x
, "drop-right!", 2, 0, 0,
632 "Return the a list containing the @var{n} last elements of\n"
633 "@var{lst}. @var{lst} may be modified to build the return.")
634 #define FUNC_NAME s_scm_srfi1_drop_right_x
638 if (scm_is_eq (n
, SCM_INUM0
))
641 tail
= scm_list_tail (lst
, n
);
644 /* p and tail work along the list, p being the cdrloc of the cell n steps
646 for ( ; scm_is_pair (tail
); tail
= SCM_CDR (tail
))
649 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
657 SCM_DEFINE (scm_srfi1_drop_while
, "drop-while", 2, 0, 0,
659 "Drop the longest initial prefix of @var{lst} whose elements all\n"
660 "satisfy the predicate @var{pred}.")
661 #define FUNC_NAME s_scm_srfi1_drop_while
663 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (pred
);
664 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
666 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
667 if (scm_is_false (pred_tramp (pred
, SCM_CAR (lst
))))
670 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
677 SCM_DEFINE (scm_srfi1_filter_map
, "filter-map", 2, 0, 1,
678 (SCM proc
, SCM list1
, SCM rest
),
679 "Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
680 "return a list of the results as per SRFI-1 @code{map}, except\n"
681 "that any @code{#f} results are omitted from the list returned.")
682 #define FUNC_NAME s_scm_srfi1_filter_map
684 SCM ret
, *loc
, elem
, newcell
, lst
;
687 SCM_VALIDATE_REST_ARGUMENT (rest
);
692 if (SCM_NULLP (rest
))
695 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
696 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
698 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
700 elem
= proc_tramp (proc
, SCM_CAR (list1
));
701 if (scm_is_true (elem
))
703 newcell
= scm_cons (elem
, SCM_EOL
);
705 loc
= SCM_CDRLOC (newcell
);
709 /* check below that list1 is a proper list, and done */
714 else if (SCM_NULLP (SCM_CDR (rest
)))
717 scm_t_trampoline_2 proc_tramp
= scm_trampoline_2 (proc
);
718 SCM list2
= SCM_CAR (rest
);
719 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
723 if (! scm_is_pair (list1
))
725 if (! scm_is_pair (list2
))
729 goto check_lst_and_done
;
731 elem
= proc_tramp (proc
, SCM_CAR (list1
), SCM_CAR (list2
));
732 if (scm_is_true (elem
))
734 newcell
= scm_cons (elem
, SCM_EOL
);
736 loc
= SCM_CDRLOC (newcell
);
738 list1
= SCM_CDR (list1
);
739 list2
= SCM_CDR (list2
);
744 /* three or more lists */
748 /* vec is the list arguments */
749 vec
= scm_vector (scm_cons (list1
, rest
));
750 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
752 /* args is the argument list to pass to proc, same length as vec,
753 re-used for each call */
754 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
758 /* first elem of each list in vec into args, and step those
759 vec entries onto their next element */
760 for (i
= 0, a
= args
, argnum
= 2;
762 i
++, a
= SCM_CDR (a
), argnum
++)
764 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
765 if (! scm_is_pair (lst
))
766 goto check_lst_and_done
;
767 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for proc */
768 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
771 elem
= scm_apply (proc
, args
, SCM_EOL
);
772 if (scm_is_true (elem
))
774 newcell
= scm_cons (elem
, SCM_EOL
);
776 loc
= SCM_CDRLOC (newcell
);
782 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
788 SCM_DEFINE (scm_srfi1_find
, "find", 2, 0, 0,
790 "Return the first element of @var{lst} which satisfies the\n"
791 "predicate @var{pred}, or return @code{#f} if no such element is\n"
793 #define FUNC_NAME s_scm_srfi1_find
795 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (pred
);
796 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
798 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
800 SCM elem
= SCM_CAR (lst
);
801 if (scm_is_true (pred_tramp (pred
, elem
)))
804 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
811 SCM_DEFINE (scm_srfi1_find_tail
, "find-tail", 2, 0, 0,
813 "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
814 "predicate @var{pred}, or return @code{#f} if no such element is\n"
816 #define FUNC_NAME s_scm_srfi1_find_tail
818 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (pred
);
819 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
821 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
822 if (scm_is_true (pred_tramp (pred
, SCM_CAR (lst
))))
824 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
831 SCM_DEFINE (scm_srfi1_length_plus
, "length+", 1, 0, 0,
833 "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
835 #define FUNC_NAME s_scm_srfi1_length_plus
837 long len
= scm_ilength (lst
);
838 return (len
>= 0 ? SCM_I_MAKINUM (len
) : SCM_BOOL_F
);
843 /* This routine differs from the core list-copy in allowing improper lists.
844 Maybe the core could allow them similarly. */
846 SCM_DEFINE (scm_srfi1_list_copy
, "list-copy", 1, 0, 0,
848 "Return a copy of the given list @var{lst}.\n"
850 "@var{lst} can be a proper or improper list. And if @var{lst}\n"
851 "is not a pair then it's treated as the final tail of an\n"
852 "improper list and simply returned.")
853 #define FUNC_NAME s_scm_srfi1_list_copy
863 while (scm_is_pair (from_here
))
866 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
868 fill_here
= SCM_CDRLOC (c
);
869 from_here
= SCM_CDR (from_here
);
876 SCM_DEFINE (scm_srfi1_lset_adjoin
, "lset-adjoin", 2, 0, 1,
877 (SCM equal
, SCM lst
, SCM rest
),
878 "Add to @var{list} any of the given @var{elem}s not already in\n"
879 "the list. @var{elem}s are @code{cons}ed onto the start of\n"
880 "@var{list} (so the return shares a common tail with\n"
881 "@var{list}), but the order they're added is unspecified.\n"
883 "The given @var{=} procedure is used for comparing elements,\n"
884 "called as @code{(@var{=} listelem elem)}, ie.@: the second\n"
885 "argument is one of the given @var{elem} parameters.\n"
888 "(lset-adjoin eqv? '(1 2 3) 4 1 5) @result{} (5 4 1 2 3)\n"
890 #define FUNC_NAME s_scm_srfi1_lset_adjoin
892 scm_t_trampoline_2 equal_tramp
;
895 equal_tramp
= scm_trampoline_2 (equal
);
896 SCM_ASSERT (equal_tramp
, equal
, SCM_ARG1
, FUNC_NAME
);
897 SCM_VALIDATE_REST_ARGUMENT (rest
);
899 /* It's not clear if duplicates among the `rest' elements are meant to be
900 cast out. The spec says `=' is called as (= list-elem rest-elem),
901 suggesting perhaps not, but the reference implementation shows the
902 "list" at each stage as including those "rest" elements already added.
903 The latter corresponds to what's described for lset-union, so that's
906 for ( ; scm_is_pair (rest
); rest
= SCM_CDR (rest
))
908 elem
= SCM_CAR (rest
);
910 for (l
= lst
; scm_is_pair (l
); l
= SCM_CDR (l
))
911 if (scm_is_true (equal_tramp (equal
, SCM_CAR (l
), elem
)))
912 goto next_elem
; /* elem already in lst, don't add */
914 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(l
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
916 /* elem is not equal to anything already in lst, add it */
917 lst
= scm_cons (elem
, lst
);
928 /* Typechecking for multi-argument MAP and FOR-EACH.
930 Verify that each element of the vector ARGV, except for the first,
931 is a list and return minimum length. Attribute errors to WHO,
932 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
934 check_map_args (SCM argv
,
943 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
945 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
948 if (!(scm_is_null (elt
) || scm_is_pair (elt
)))
952 scm_apply_generic (gf
, scm_cons (proc
, args
));
954 scm_wrong_type_arg (who
, i
+ 2, elt
);
957 elt_len
= srfi1_ilength (elt
);
959 goto check_map_error
;
961 if (len
< 0 || (elt_len
>= 0 && elt_len
< len
))
966 goto check_map_error
;
968 scm_remember_upto_here_1 (argv
);
973 SCM_GPROC (s_srfi1_map
, "map", 2, 0, 1, scm_srfi1_map
, g_srfi1_map
);
975 /* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
976 sequentially, starting with the first element(s). This is used in
977 the Scheme procedure `map-in-order', which guarantees sequential
978 behaviour, is implemented using scm_map. If the behaviour changes,
979 we need to update `map-in-order'.
983 scm_srfi1_map (SCM proc
, SCM arg1
, SCM args
)
984 #define FUNC_NAME s_srfi1_map
990 len
= srfi1_ilength (arg1
);
991 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
993 scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_srfi1_map
);
994 SCM_VALIDATE_REST_ARGUMENT (args
);
995 if (scm_is_null (args
))
997 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
998 SCM_GASSERT2 (call
, g_srfi1_map
, proc
, arg1
, SCM_ARG1
, s_srfi1_map
);
999 SCM_GASSERT2 (len
>= 0, g_srfi1_map
, proc
, arg1
, SCM_ARG2
, s_srfi1_map
);
1000 while (SCM_NIMP (arg1
))
1002 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
1003 pres
= SCM_CDRLOC (*pres
);
1004 arg1
= SCM_CDR (arg1
);
1008 if (scm_is_null (SCM_CDR (args
)))
1010 SCM arg2
= SCM_CAR (args
);
1011 int len2
= srfi1_ilength (arg2
);
1012 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
1013 SCM_GASSERTn (call
, g_srfi1_map
,
1014 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_map
);
1015 if (len
< 0 || (len2
>= 0 && len2
< len
))
1017 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
1018 && len
>= 0 && len2
>= -1,
1020 scm_cons2 (proc
, arg1
, args
),
1021 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
1025 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
1026 pres
= SCM_CDRLOC (*pres
);
1027 arg1
= SCM_CDR (arg1
);
1028 arg2
= SCM_CDR (arg2
);
1033 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
1034 len
= check_map_args (args
, len
, g_srfi1_map
, proc
, arg1
, s_srfi1_map
);
1038 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
1040 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
1041 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
1042 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
1044 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
1045 pres
= SCM_CDRLOC (*pres
);
1052 SCM_REGISTER_PROC (s_srfi1_map_in_order
, "map-in-order", 2, 0, 1, scm_srfi1_map
);
1054 SCM_GPROC (s_srfi1_for_each
, "for-each", 2, 0, 1, scm_srfi1_for_each
, g_srfi1_for_each
);
1057 scm_srfi1_for_each (SCM proc
, SCM arg1
, SCM args
)
1058 #define FUNC_NAME s_srfi1_for_each
1061 len
= srfi1_ilength (arg1
);
1062 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
1063 g_srfi1_for_each
, scm_cons2 (proc
, arg1
, args
),
1064 SCM_ARG2
, s_srfi1_for_each
);
1065 SCM_VALIDATE_REST_ARGUMENT (args
);
1066 if (scm_is_null (args
))
1068 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
1069 SCM_GASSERT2 (call
, g_srfi1_for_each
, proc
, arg1
,
1070 SCM_ARG1
, s_srfi1_for_each
);
1071 SCM_GASSERT2 (len
>= 0, g_srfi1_for_each
, proc
, arg1
,
1072 SCM_ARG2
, s_srfi1_map
);
1073 while (SCM_NIMP (arg1
))
1075 call (proc
, SCM_CAR (arg1
));
1076 arg1
= SCM_CDR (arg1
);
1078 return SCM_UNSPECIFIED
;
1080 if (scm_is_null (SCM_CDR (args
)))
1082 SCM arg2
= SCM_CAR (args
);
1083 int len2
= srfi1_ilength (arg2
);
1084 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
1085 SCM_GASSERTn (call
, g_srfi1_for_each
,
1086 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_for_each
);
1087 if (len
< 0 || (len2
>= 0 && len2
< len
))
1089 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
1090 && len
>= 0 && len2
>= -1,
1092 scm_cons2 (proc
, arg1
, args
),
1093 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
1097 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
1098 arg1
= SCM_CDR (arg1
);
1099 arg2
= SCM_CDR (arg2
);
1102 return SCM_UNSPECIFIED
;
1104 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
1105 len
= check_map_args (args
, len
, g_srfi1_for_each
, proc
, arg1
,
1110 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
1112 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
1113 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
1114 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
1116 scm_apply (proc
, arg1
, SCM_EOL
);
1119 return SCM_UNSPECIFIED
;
1124 SCM_DEFINE (scm_srfi1_member
, "member", 2, 1, 0,
1125 (SCM x
, SCM lst
, SCM pred
),
1126 "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
1127 "to @var{x}. If @var{x} does not appear in @var{lst}, return\n"
1130 "Equality is determined by @code{equal?}, or by the equality\n"
1131 "predicate @var{=} if given. @var{=} is called @code{(= @var{x}\n"
1132 "elem)}, ie.@: with the given @var{x} first, so for example to\n"
1133 "find the first element greater than 5,\n"
1136 "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
1139 "This version of @code{member} extends the core @code{member} by\n"
1140 "accepting an equality predicate.")
1141 #define FUNC_NAME s_scm_srfi1_member
1143 scm_t_trampoline_2 equal_p
;
1144 SCM_VALIDATE_LIST (2, lst
);
1145 if (SCM_UNBNDP (pred
))
1146 equal_p
= equal_trampoline
;
1149 equal_p
= scm_trampoline_2 (pred
);
1150 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
1152 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
1154 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
1161 SCM_DEFINE (scm_srfi1_assoc
, "assoc", 2, 1, 0,
1162 (SCM key
, SCM alist
, SCM pred
),
1163 "Behaves like @code{assq} but uses third argument @var{pred?}\n"
1164 "for key comparison. If @var{pred?} is not supplied,\n"
1165 "@code{equal?} is used. (Extended from R5RS.)\n")
1166 #define FUNC_NAME s_scm_srfi1_assoc
1169 scm_t_trampoline_2 equal_p
;
1170 if (SCM_UNBNDP (pred
))
1171 equal_p
= equal_trampoline
;
1174 equal_p
= scm_trampoline_2 (pred
);
1175 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
1177 for(; scm_is_pair (ls
); ls
= SCM_CDR (ls
))
1179 SCM tmp
= SCM_CAR (ls
);
1180 SCM_ASSERT_TYPE (scm_is_pair (tmp
), alist
, SCM_ARG2
, FUNC_NAME
,
1181 "association list");
1182 if (scm_is_true (equal_p (pred
, SCM_CAR (tmp
), key
)))
1185 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls
), alist
, SCM_ARG2
, FUNC_NAME
,
1186 "association list");
1191 SCM_DEFINE (scm_srfi1_partition
, "partition", 2, 0, 0,
1192 (SCM pred
, SCM list
),
1193 "Partition the elements of @var{list} with predicate @var{pred}.\n"
1194 "Return two values: the list of elements satifying @var{pred} and\n"
1195 "the list of elements @emph{not} satisfying @var{pred}. The order\n"
1196 "of the output lists follows the order of @var{list}. @var{list}\n"
1197 "is not mutated. One of the output lists may share memory with @var{list}.\n")
1198 #define FUNC_NAME s_scm_srfi1_partition
1200 /* In this implementation, the output lists don't share memory with
1201 list, because it's probably not worth the effort. */
1202 scm_t_trampoline_1 call
= scm_trampoline_1(pred
);
1203 SCM kept
= scm_cons(SCM_EOL
, SCM_EOL
);
1204 SCM kept_tail
= kept
;
1205 SCM dropped
= scm_cons(SCM_EOL
, SCM_EOL
);
1206 SCM dropped_tail
= dropped
;
1208 SCM_ASSERT(call
, pred
, 2, FUNC_NAME
);
1210 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR(list
)) {
1211 SCM elt
= SCM_CAR(list
);
1212 SCM new_tail
= scm_cons(SCM_CAR(list
), SCM_EOL
);
1213 if (scm_is_true (call (pred
, elt
))) {
1214 SCM_SETCDR(kept_tail
, new_tail
);
1215 kept_tail
= new_tail
;
1218 SCM_SETCDR(dropped_tail
, new_tail
);
1219 dropped_tail
= new_tail
;
1222 /* re-use the initial conses for the values list */
1223 SCM_SETCAR(kept
, SCM_CDR(kept
));
1224 SCM_SETCDR(kept
, dropped
);
1225 SCM_SETCAR(dropped
, SCM_CDR(dropped
));
1226 SCM_SETCDR(dropped
, SCM_EOL
);
1227 return scm_values(kept
);
1232 SCM_DEFINE (scm_srfi1_partition_x
, "partition!", 2, 0, 0,
1233 (SCM pred
, SCM lst
),
1234 "Split @var{lst} into those elements which do and don't satisfy\n"
1235 "the predicate @var{pred}.\n"
1237 "The return is two values (@pxref{Multiple Values}), the first\n"
1238 "being a list of all elements from @var{lst} which satisfy\n"
1239 "@var{pred}, the second a list of those which do not.\n"
1241 "The elements in the result lists are in the same order as in\n"
1242 "@var{lst} but the order in which the calls @code{(@var{pred}\n"
1243 "elem)} are made on the list elements is unspecified.\n"
1245 "@var{lst} may be modified to construct the return lists.")
1246 #define FUNC_NAME s_scm_srfi1_partition_x
1248 SCM tlst
, flst
, *tp
, *fp
;
1249 scm_t_trampoline_1 pred_tramp
;
1251 pred_tramp
= scm_trampoline_1 (pred
);
1252 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1254 /* tlst and flst are the lists of true and false elements. tp and fp are
1255 where to store to append to them, initially &tlst and &flst, then
1256 SCM_CDRLOC of the last pair in the respective lists. */
1263 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1265 if (scm_is_true (pred_tramp (pred
, SCM_CAR (lst
))))
1268 tp
= SCM_CDRLOC (lst
);
1273 fp
= SCM_CDRLOC (lst
);
1277 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1279 /* terminate whichever didn't get the last element(s) */
1283 return scm_values (scm_list_2 (tlst
, flst
));
1288 SCM_DEFINE (scm_srfi1_reduce
, "reduce", 3, 0, 0,
1289 (SCM proc
, SCM def
, SCM lst
),
1290 "@code{reduce} is a variant of @code{fold}, where the first call\n"
1291 "to @var{proc} is on two elements from @var{lst}, rather than\n"
1292 "one element and a given initial value.\n"
1294 "If @var{lst} is empty, @code{reduce} returns @var{def} (this is\n"
1295 "the only use for @var{def}). If @var{lst} has just one element\n"
1296 "then that's the return value. Otherwise @var{proc} is called\n"
1297 "on the elements of @var{lst}.\n"
1299 "Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
1300 "@var{previous})}, where @var{elem} is from @var{lst} (the\n"
1301 "second and subsequent elements of @var{lst}), and\n"
1302 "@var{previous} is the return from the previous call to\n"
1303 "@var{proc}. The first element of @var{lst} is the\n"
1304 "@var{previous} for the first call to @var{proc}.\n"
1306 "For example, the following adds a list of numbers, the calls\n"
1307 "made to @code{+} are shown. (Of course @code{+} accepts\n"
1308 "multiple arguments and can add a list directly, with\n"
1312 "(reduce + 0 '(5 6 7)) @result{} 18\n"
1314 "(+ 6 5) @result{} 11\n"
1315 "(+ 7 11) @result{} 18\n"
1318 "@code{reduce} can be used instead of @code{fold} where the\n"
1319 "@var{init} value is an ``identity'', meaning a value which\n"
1320 "under @var{proc} doesn't change the result, in this case 0 is\n"
1321 "an identity since @code{(+ 5 0)} is just 5. @code{reduce}\n"
1322 "avoids that unnecessary call.")
1323 #define FUNC_NAME s_scm_srfi1_reduce
1325 scm_t_trampoline_2 proc_tramp
= scm_trampoline_2 (proc
);
1328 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
1330 ret
= def
; /* if lst is empty */
1331 if (scm_is_pair (lst
))
1333 ret
= SCM_CAR (lst
); /* if lst has one element */
1335 for (lst
= SCM_CDR (lst
); scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1336 ret
= proc_tramp (proc
, SCM_CAR (lst
), ret
);
1339 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG3
, FUNC_NAME
, "list");
1345 SCM_DEFINE (scm_srfi1_reduce_right
, "reduce-right", 3, 0, 0,
1346 (SCM proc
, SCM def
, SCM lst
),
1347 "@code{reduce-right} is a variant of @code{fold-right}, where\n"
1348 "the first call to @var{proc} is on two elements from @var{lst},\n"
1349 "rather than one element and a given initial value.\n"
1351 "If @var{lst} is empty, @code{reduce-right} returns @var{def}\n"
1352 "(this is the only use for @var{def}). If @var{lst} has just\n"
1353 "one element then that's the return value. Otherwise @var{proc}\n"
1354 "is called on the elements of @var{lst}.\n"
1356 "Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
1357 "@var{previous})}, where @var{elem} is from @var{lst} (the\n"
1358 "second last and then working back to the first element of\n"
1359 "@var{lst}), and @var{previous} is the return from the previous\n"
1360 "call to @var{proc}. The last element of @var{lst} is the\n"
1361 "@var{previous} for the first call to @var{proc}.\n"
1363 "For example, the following adds a list of numbers, the calls\n"
1364 "made to @code{+} are shown. (Of course @code{+} accepts\n"
1365 "multiple arguments and can add a list directly, with\n"
1369 "(reduce-right + 0 '(5 6 7)) @result{} 18\n"
1371 "(+ 6 7) @result{} 13\n"
1372 "(+ 5 13) @result{} 18\n"
1375 "@code{reduce-right} can be used instead of @code{fold-right}\n"
1376 "where the @var{init} value is an ``identity'', meaning a value\n"
1377 "which under @var{proc} doesn't change the result, in this case\n"
1378 "0 is an identity since @code{(+ 7 0)} is just 5.\n"
1379 "@code{reduce-right} avoids that unnecessary call.\n"
1381 "@code{reduce} should be preferred over @code{reduce-right} if\n"
1382 "the order of processing doesn't matter, or can be arranged\n"
1383 "either way, since @code{reduce} is a little more efficient.")
1384 #define FUNC_NAME s_scm_srfi1_reduce_right
1386 /* To work backwards across a list requires either repeatedly traversing
1387 to get each previous element, or using some memory for a reversed or
1388 random-access form. Repeated traversal might not be too terrible, but
1389 is of course quadratic complexity and hence to be avoided in case LST
1390 is long. A vector is preferred over a reversed list since it's more
1391 compact and is less work for the gc to collect. */
1393 scm_t_trampoline_2 proc_tramp
= scm_trampoline_2 (proc
);
1397 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
1399 if (SCM_NULL_OR_NIL_P (lst
))
1402 vec
= scm_vector (lst
);
1403 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
1405 ret
= SCM_SIMPLE_VECTOR_REF (vec
, len
-1);
1406 for (i
= len
-2; i
>= 0; i
--)
1407 ret
= proc_tramp (proc
, SCM_SIMPLE_VECTOR_REF (vec
, i
), ret
);
1414 SCM_DEFINE (scm_srfi1_remove
, "remove", 2, 0, 0,
1415 (SCM pred
, SCM list
),
1416 "Return a list containing all elements from @var{lst} which do\n"
1417 "not satisfy the predicate @var{pred}. The elements in the\n"
1418 "result list have the same order as in @var{lst}. The order in\n"
1419 "which @var{pred} is applied to the list elements is not\n"
1421 #define FUNC_NAME s_scm_srfi1_remove
1423 scm_t_trampoline_1 call
= scm_trampoline_1 (pred
);
1427 SCM_ASSERT (call
, pred
, 1, FUNC_NAME
);
1428 SCM_VALIDATE_LIST (2, list
);
1430 for (prev
= &res
, walk
= list
;
1432 walk
= SCM_CDR (walk
))
1434 if (scm_is_false (call (pred
, SCM_CAR (walk
))))
1436 *prev
= scm_cons (SCM_CAR (walk
), SCM_EOL
);
1437 prev
= SCM_CDRLOC (*prev
);
1446 SCM_DEFINE (scm_srfi1_remove_x
, "remove!", 2, 0, 0,
1447 (SCM pred
, SCM list
),
1448 "Return a list containing all elements from @var{list} which do\n"
1449 "not satisfy the predicate @var{pred}. The elements in the\n"
1450 "result list have the same order as in @var{list}. The order in\n"
1451 "which @var{pred} is applied to the list elements is not\n"
1452 "specified. @var{list} may be modified to build the return\n"
1454 #define FUNC_NAME s_scm_srfi1_remove_x
1456 scm_t_trampoline_1 call
= scm_trampoline_1 (pred
);
1459 SCM_ASSERT (call
, pred
, 1, FUNC_NAME
);
1460 SCM_VALIDATE_LIST (2, list
);
1462 for (prev
= &list
, walk
= list
;
1464 walk
= SCM_CDR (walk
))
1466 if (scm_is_false (call (pred
, SCM_CAR (walk
))))
1467 prev
= SCM_CDRLOC (walk
);
1469 *prev
= SCM_CDR (walk
);
1477 SCM_DEFINE (scm_srfi1_span
, "span", 2, 0, 0,
1478 (SCM pred
, SCM lst
),
1479 "Return two values, the longest initial prefix of @var{lst}\n"
1480 "whose elements all satisfy the predicate @var{pred}, and the\n"
1481 "remainder of @var{lst}.")
1482 #define FUNC_NAME s_scm_srfi1_span
1484 scm_t_trampoline_1 pred_tramp
;
1487 pred_tramp
= scm_trampoline_1 (pred
);
1488 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1492 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1494 SCM elem
= SCM_CAR (lst
);
1495 if (scm_is_false (pred_tramp (pred
, elem
)))
1498 /* want this elem, tack it onto the end of ret */
1499 *p
= scm_cons (elem
, SCM_EOL
);
1500 p
= SCM_CDRLOC (*p
);
1502 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1505 return scm_values (scm_list_2 (ret
, lst
));
1510 SCM_DEFINE (scm_srfi1_span_x
, "span!", 2, 0, 0,
1511 (SCM pred
, SCM lst
),
1512 "Return two values, the longest initial prefix of @var{lst}\n"
1513 "whose elements all satisfy the predicate @var{pred}, and the\n"
1514 "remainder of @var{lst}. @var{lst} may be modified to form the\n"
1516 #define FUNC_NAME s_scm_srfi1_span_x
1519 scm_t_trampoline_1 pred_tramp
;
1521 pred_tramp
= scm_trampoline_1 (pred
);
1522 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1525 for (upto
= lst
; scm_is_pair (upto
); upto
= SCM_CDR (upto
))
1527 if (scm_is_false (pred_tramp (pred
, SCM_CAR (upto
))))
1530 /* want this element */
1531 p
= SCM_CDRLOC (upto
);
1533 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1537 return scm_values (scm_list_2 (lst
, upto
));
1542 SCM_DEFINE (scm_srfi1_split_at
, "split-at", 2, 0, 0,
1544 "Return two values (multiple values), being a list of the\n"
1545 "elements before index @var{n} in @var{lst}, and a list of those\n"
1547 #define FUNC_NAME s_scm_srfi1_split_at
1550 /* pre is a list of elements before the i split point, loc is the CDRLOC
1551 of the last cell, ie. where to store to append to it */
1555 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1557 SCM_VALIDATE_CONS (SCM_ARG1
, lst
);
1559 *loc
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
1560 loc
= SCM_CDRLOC (*loc
);
1563 return scm_values (scm_list_2 (pre
, lst
));
1568 SCM_DEFINE (scm_srfi1_split_at_x
, "split-at!", 2, 0, 0,
1570 "Return two values (multiple values), being a list of the\n"
1571 "elements before index @var{n} in @var{lst}, and a list of those\n"
1572 "after. @var{lst} is modified to form those values.")
1573 #define FUNC_NAME s_scm_srfi1_split_at
1579 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1581 SCM_VALIDATE_CONS (SCM_ARG1
, upto
);
1583 loc
= SCM_CDRLOC (upto
);
1584 upto
= SCM_CDR (upto
);
1588 return scm_values (scm_list_2 (lst
, upto
));
1593 SCM_DEFINE (scm_srfi1_take_x
, "take!", 2, 0, 0,
1595 "Return a list containing the first @var{n} elements of\n"
1597 #define FUNC_NAME s_scm_srfi1_take_x
1602 SCM_VALIDATE_INUM_MIN_COPY (SCM_ARG2
, n
, 0, nn
);
1607 pos
= scm_list_tail (lst
, SCM_I_MAKINUM (nn
- 1));
1609 /* Must have at least one cell left, mustn't have reached the end of an
1610 n-1 element list. SCM_VALIDATE_CONS here gives the same error as
1611 scm_list_tail does on say an n-2 element list, though perhaps a range
1612 error would make more sense (for both). */
1613 SCM_VALIDATE_CONS (SCM_ARG1
, pos
);
1615 SCM_SETCDR (pos
, SCM_EOL
);
1621 SCM_DEFINE (scm_srfi1_take_right
, "take-right", 2, 0, 0,
1623 "Return the a list containing the @var{n} last elements of\n"
1625 #define FUNC_NAME s_scm_srfi1_take_right
1627 SCM tail
= scm_list_tail (lst
, n
);
1628 while (scm_is_pair (tail
))
1630 lst
= SCM_CDR (lst
);
1631 tail
= SCM_CDR (tail
);
1633 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
1639 SCM_DEFINE (scm_srfi1_take_while
, "take-while", 2, 0, 0,
1640 (SCM pred
, SCM lst
),
1641 "Return a new list which is the longest initial prefix of\n"
1642 "@var{lst} whose elements all satisfy the predicate @var{pred}.")
1643 #define FUNC_NAME s_scm_srfi1_take_while
1645 scm_t_trampoline_1 pred_tramp
;
1648 pred_tramp
= scm_trampoline_1 (pred
);
1649 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1653 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1655 SCM elem
= SCM_CAR (lst
);
1656 if (scm_is_false (pred_tramp (pred
, elem
)))
1659 /* want this elem, tack it onto the end of ret */
1660 *p
= scm_cons (elem
, SCM_EOL
);
1661 p
= SCM_CDRLOC (*p
);
1663 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1671 SCM_DEFINE (scm_srfi1_take_while_x
, "take-while!", 2, 0, 0,
1672 (SCM pred
, SCM lst
),
1673 "Return the longest initial prefix of @var{lst} whose elements\n"
1674 "all satisfy the predicate @var{pred}. @var{lst} may be\n"
1675 "modified to form the return.")
1676 #define FUNC_NAME s_scm_srfi1_take_while_x
1679 scm_t_trampoline_1 pred_tramp
;
1681 pred_tramp
= scm_trampoline_1 (pred
);
1682 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1685 for (upto
= lst
; scm_is_pair (upto
); upto
= SCM_CDR (upto
))
1687 if (scm_is_false (pred_tramp (pred
, SCM_CAR (upto
))))
1690 /* want this element */
1691 p
= SCM_CDRLOC (upto
);
1693 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1703 scm_init_srfi_1 (void)
1705 SCM the_root_module
= scm_lookup_closure_module (SCM_BOOL_F
);
1706 #ifndef SCM_MAGIC_SNARFER
1707 #include "srfi/srfi-1.x"
1709 scm_c_extend_primitive_generic
1710 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "map")),
1711 SCM_VARIABLE_REF (scm_c_lookup ("map")));
1712 scm_c_extend_primitive_generic
1713 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "for-each")),
1714 SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
1717 /* End of srfi-1.c. */