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_eighth
, "eighth", 1, 0, 0,
679 "Return the eighth element of @var{lst}.")
680 #define FUNC_NAME s_scm_srfi1_eighth
682 return scm_list_ref (lst
, SCM_I_MAKINUM (7));
687 SCM_DEFINE (scm_srfi1_fifth
, "fifth", 1, 0, 0,
689 "Return the fifth element of @var{lst}.")
690 #define FUNC_NAME s_scm_srfi1_fifth
692 return scm_list_ref (lst
, SCM_I_MAKINUM (4));
697 SCM_DEFINE (scm_srfi1_filter_map
, "filter-map", 2, 0, 1,
698 (SCM proc
, SCM list1
, SCM rest
),
699 "Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
700 "return a list of the results as per SRFI-1 @code{map}, except\n"
701 "that any @code{#f} results are omitted from the list returned.")
702 #define FUNC_NAME s_scm_srfi1_filter_map
704 SCM ret
, *loc
, elem
, newcell
, lst
;
707 SCM_VALIDATE_REST_ARGUMENT (rest
);
712 if (SCM_NULLP (rest
))
715 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
716 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
718 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
720 elem
= proc_tramp (proc
, SCM_CAR (list1
));
721 if (scm_is_true (elem
))
723 newcell
= scm_cons (elem
, SCM_EOL
);
725 loc
= SCM_CDRLOC (newcell
);
729 /* check below that list1 is a proper list, and done */
734 else if (SCM_NULLP (SCM_CDR (rest
)))
737 scm_t_trampoline_2 proc_tramp
= scm_trampoline_2 (proc
);
738 SCM list2
= SCM_CAR (rest
);
739 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
743 if (! scm_is_pair (list1
))
745 if (! scm_is_pair (list2
))
749 goto check_lst_and_done
;
751 elem
= proc_tramp (proc
, SCM_CAR (list1
), SCM_CAR (list2
));
752 if (scm_is_true (elem
))
754 newcell
= scm_cons (elem
, SCM_EOL
);
756 loc
= SCM_CDRLOC (newcell
);
758 list1
= SCM_CDR (list1
);
759 list2
= SCM_CDR (list2
);
764 /* three or more lists */
768 /* vec is the list arguments */
769 vec
= scm_vector (scm_cons (list1
, rest
));
770 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
772 /* args is the argument list to pass to proc, same length as vec,
773 re-used for each call */
774 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
778 /* first elem of each list in vec into args, and step those
779 vec entries onto their next element */
780 for (i
= 0, a
= args
, argnum
= 2;
782 i
++, a
= SCM_CDR (a
), argnum
++)
784 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
785 if (! scm_is_pair (lst
))
786 goto check_lst_and_done
;
787 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for proc */
788 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
791 elem
= scm_apply (proc
, args
, SCM_EOL
);
792 if (scm_is_true (elem
))
794 newcell
= scm_cons (elem
, SCM_EOL
);
796 loc
= SCM_CDRLOC (newcell
);
802 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
808 SCM_DEFINE (scm_srfi1_find
, "find", 2, 0, 0,
810 "Return the first element of @var{lst} which satisfies the\n"
811 "predicate @var{pred}, or return @code{#f} if no such element is\n"
813 #define FUNC_NAME s_scm_srfi1_find
815 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (pred
);
816 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
818 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
820 SCM elem
= SCM_CAR (lst
);
821 if (scm_is_true (pred_tramp (pred
, elem
)))
824 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
831 SCM_DEFINE (scm_srfi1_find_tail
, "find-tail", 2, 0, 0,
833 "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
834 "predicate @var{pred}, or return @code{#f} if no such element is\n"
836 #define FUNC_NAME s_scm_srfi1_find_tail
838 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (pred
);
839 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
841 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
842 if (scm_is_true (pred_tramp (pred
, SCM_CAR (lst
))))
844 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
851 SCM_DEFINE (scm_srfi1_length_plus
, "length+", 1, 0, 0,
853 "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
855 #define FUNC_NAME s_scm_srfi1_length_plus
857 long len
= scm_ilength (lst
);
858 return (len
>= 0 ? SCM_I_MAKINUM (len
) : SCM_BOOL_F
);
863 /* This routine differs from the core list-copy in allowing improper lists.
864 Maybe the core could allow them similarly. */
866 SCM_DEFINE (scm_srfi1_list_copy
, "list-copy", 1, 0, 0,
868 "Return a copy of the given list @var{lst}.\n"
870 "@var{lst} can be a proper or improper list. And if @var{lst}\n"
871 "is not a pair then it's treated as the final tail of an\n"
872 "improper list and simply returned.")
873 #define FUNC_NAME s_scm_srfi1_list_copy
883 while (scm_is_pair (from_here
))
886 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
888 fill_here
= SCM_CDRLOC (c
);
889 from_here
= SCM_CDR (from_here
);
896 SCM_DEFINE (scm_srfi1_lset_adjoin
, "lset-adjoin", 2, 0, 1,
897 (SCM equal
, SCM lst
, SCM rest
),
898 "Add to @var{list} any of the given @var{elem}s not already in\n"
899 "the list. @var{elem}s are @code{cons}ed onto the start of\n"
900 "@var{list} (so the return shares a common tail with\n"
901 "@var{list}), but the order they're added is unspecified.\n"
903 "The given @var{=} procedure is used for comparing elements,\n"
904 "called as @code{(@var{=} listelem elem)}, ie.@: the second\n"
905 "argument is one of the given @var{elem} parameters.\n"
908 "(lset-adjoin eqv? '(1 2 3) 4 1 5) @result{} (5 4 1 2 3)\n"
910 #define FUNC_NAME s_scm_srfi1_lset_adjoin
912 scm_t_trampoline_2 equal_tramp
;
915 equal_tramp
= scm_trampoline_2 (equal
);
916 SCM_ASSERT (equal_tramp
, equal
, SCM_ARG1
, FUNC_NAME
);
917 SCM_VALIDATE_REST_ARGUMENT (rest
);
919 /* It's not clear if duplicates among the `rest' elements are meant to be
920 cast out. The spec says `=' is called as (= list-elem rest-elem),
921 suggesting perhaps not, but the reference implementation shows the
922 "list" at each stage as including those "rest" elements already added.
923 The latter corresponds to what's described for lset-union, so that's
926 for ( ; scm_is_pair (rest
); rest
= SCM_CDR (rest
))
928 elem
= SCM_CAR (rest
);
930 for (l
= lst
; scm_is_pair (l
); l
= SCM_CDR (l
))
931 if (scm_is_true (equal_tramp (equal
, SCM_CAR (l
), elem
)))
932 goto next_elem
; /* elem already in lst, don't add */
934 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(l
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
936 /* elem is not equal to anything already in lst, add it */
937 lst
= scm_cons (elem
, lst
);
948 /* Typechecking for multi-argument MAP and FOR-EACH.
950 Verify that each element of the vector ARGV, except for the first,
951 is a list and return minimum length. Attribute errors to WHO,
952 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
954 check_map_args (SCM argv
,
963 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
965 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
968 if (!(scm_is_null (elt
) || scm_is_pair (elt
)))
972 scm_apply_generic (gf
, scm_cons (proc
, args
));
974 scm_wrong_type_arg (who
, i
+ 2, elt
);
977 elt_len
= srfi1_ilength (elt
);
979 goto check_map_error
;
981 if (len
< 0 || (elt_len
>= 0 && elt_len
< len
))
986 goto check_map_error
;
988 scm_remember_upto_here_1 (argv
);
993 SCM_GPROC (s_srfi1_map
, "map", 2, 0, 1, scm_srfi1_map
, g_srfi1_map
);
995 /* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
996 sequentially, starting with the first element(s). This is used in
997 the Scheme procedure `map-in-order', which guarantees sequential
998 behaviour, is implemented using scm_map. If the behaviour changes,
999 we need to update `map-in-order'.
1003 scm_srfi1_map (SCM proc
, SCM arg1
, SCM args
)
1004 #define FUNC_NAME s_srfi1_map
1010 len
= srfi1_ilength (arg1
);
1011 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
1013 scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_srfi1_map
);
1014 SCM_VALIDATE_REST_ARGUMENT (args
);
1015 if (scm_is_null (args
))
1017 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
1018 SCM_GASSERT2 (call
, g_srfi1_map
, proc
, arg1
, SCM_ARG1
, s_srfi1_map
);
1019 SCM_GASSERT2 (len
>= 0, g_srfi1_map
, proc
, arg1
, SCM_ARG2
, s_srfi1_map
);
1020 while (SCM_NIMP (arg1
))
1022 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
1023 pres
= SCM_CDRLOC (*pres
);
1024 arg1
= SCM_CDR (arg1
);
1028 if (scm_is_null (SCM_CDR (args
)))
1030 SCM arg2
= SCM_CAR (args
);
1031 int len2
= srfi1_ilength (arg2
);
1032 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
1033 SCM_GASSERTn (call
, g_srfi1_map
,
1034 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_map
);
1035 if (len
< 0 || (len2
>= 0 && len2
< len
))
1037 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
1038 && len
>= 0 && len2
>= -1,
1040 scm_cons2 (proc
, arg1
, args
),
1041 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
1045 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
1046 pres
= SCM_CDRLOC (*pres
);
1047 arg1
= SCM_CDR (arg1
);
1048 arg2
= SCM_CDR (arg2
);
1053 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
1054 len
= check_map_args (args
, len
, g_srfi1_map
, proc
, arg1
, s_srfi1_map
);
1058 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
1060 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
1061 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
1062 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
1064 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
1065 pres
= SCM_CDRLOC (*pres
);
1072 SCM_REGISTER_PROC (s_srfi1_map_in_order
, "map-in-order", 2, 0, 1, scm_srfi1_map
);
1074 SCM_GPROC (s_srfi1_for_each
, "for-each", 2, 0, 1, scm_srfi1_for_each
, g_srfi1_for_each
);
1077 scm_srfi1_for_each (SCM proc
, SCM arg1
, SCM args
)
1078 #define FUNC_NAME s_srfi1_for_each
1081 len
= srfi1_ilength (arg1
);
1082 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
1083 g_srfi1_for_each
, scm_cons2 (proc
, arg1
, args
),
1084 SCM_ARG2
, s_srfi1_for_each
);
1085 SCM_VALIDATE_REST_ARGUMENT (args
);
1086 if (scm_is_null (args
))
1088 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
1089 SCM_GASSERT2 (call
, g_srfi1_for_each
, proc
, arg1
,
1090 SCM_ARG1
, s_srfi1_for_each
);
1091 SCM_GASSERT2 (len
>= 0, g_srfi1_for_each
, proc
, arg1
,
1092 SCM_ARG2
, s_srfi1_map
);
1093 while (SCM_NIMP (arg1
))
1095 call (proc
, SCM_CAR (arg1
));
1096 arg1
= SCM_CDR (arg1
);
1098 return SCM_UNSPECIFIED
;
1100 if (scm_is_null (SCM_CDR (args
)))
1102 SCM arg2
= SCM_CAR (args
);
1103 int len2
= srfi1_ilength (arg2
);
1104 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
1105 SCM_GASSERTn (call
, g_srfi1_for_each
,
1106 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_for_each
);
1107 if (len
< 0 || (len2
>= 0 && len2
< len
))
1109 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
1110 && len
>= 0 && len2
>= -1,
1112 scm_cons2 (proc
, arg1
, args
),
1113 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
1117 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
1118 arg1
= SCM_CDR (arg1
);
1119 arg2
= SCM_CDR (arg2
);
1122 return SCM_UNSPECIFIED
;
1124 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
1125 len
= check_map_args (args
, len
, g_srfi1_for_each
, proc
, arg1
,
1130 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
1132 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
1133 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
1134 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
1136 scm_apply (proc
, arg1
, SCM_EOL
);
1139 return SCM_UNSPECIFIED
;
1144 SCM_DEFINE (scm_srfi1_member
, "member", 2, 1, 0,
1145 (SCM x
, SCM lst
, SCM pred
),
1146 "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
1147 "to @var{x}. If @var{x} does not appear in @var{lst}, return\n"
1150 "Equality is determined by @code{equal?}, or by the equality\n"
1151 "predicate @var{=} if given. @var{=} is called @code{(= @var{x}\n"
1152 "elem)}, ie.@: with the given @var{x} first, so for example to\n"
1153 "find the first element greater than 5,\n"
1156 "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
1159 "This version of @code{member} extends the core @code{member} by\n"
1160 "accepting an equality predicate.")
1161 #define FUNC_NAME s_scm_srfi1_member
1163 scm_t_trampoline_2 equal_p
;
1164 SCM_VALIDATE_LIST (2, lst
);
1165 if (SCM_UNBNDP (pred
))
1166 equal_p
= equal_trampoline
;
1169 equal_p
= scm_trampoline_2 (pred
);
1170 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
1172 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
1174 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
1181 SCM_DEFINE (scm_srfi1_assoc
, "assoc", 2, 1, 0,
1182 (SCM key
, SCM alist
, SCM pred
),
1183 "Behaves like @code{assq} but uses third argument @var{pred?}\n"
1184 "for key comparison. If @var{pred?} is not supplied,\n"
1185 "@code{equal?} is used. (Extended from R5RS.)\n")
1186 #define FUNC_NAME s_scm_srfi1_assoc
1189 scm_t_trampoline_2 equal_p
;
1190 if (SCM_UNBNDP (pred
))
1191 equal_p
= equal_trampoline
;
1194 equal_p
= scm_trampoline_2 (pred
);
1195 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
1197 for(; scm_is_pair (ls
); ls
= SCM_CDR (ls
))
1199 SCM tmp
= SCM_CAR (ls
);
1200 SCM_ASSERT_TYPE (scm_is_pair (tmp
), alist
, SCM_ARG2
, FUNC_NAME
,
1201 "association list");
1202 if (scm_is_true (equal_p (pred
, SCM_CAR (tmp
), key
)))
1205 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls
), alist
, SCM_ARG2
, FUNC_NAME
,
1206 "association list");
1212 SCM_DEFINE (scm_srfi1_ninth
, "ninth", 1, 0, 0,
1214 "Return the ninth element of @var{lst}.")
1215 #define FUNC_NAME s_scm_srfi1_ninth
1217 return scm_list_ref (lst
, SCM_I_MAKINUM (8));
1222 SCM_DEFINE (scm_srfi1_partition
, "partition", 2, 0, 0,
1223 (SCM pred
, SCM list
),
1224 "Partition the elements of @var{list} with predicate @var{pred}.\n"
1225 "Return two values: the list of elements satifying @var{pred} and\n"
1226 "the list of elements @emph{not} satisfying @var{pred}. The order\n"
1227 "of the output lists follows the order of @var{list}. @var{list}\n"
1228 "is not mutated. One of the output lists may share memory with @var{list}.\n")
1229 #define FUNC_NAME s_scm_srfi1_partition
1231 /* In this implementation, the output lists don't share memory with
1232 list, because it's probably not worth the effort. */
1233 scm_t_trampoline_1 call
= scm_trampoline_1(pred
);
1234 SCM kept
= scm_cons(SCM_EOL
, SCM_EOL
);
1235 SCM kept_tail
= kept
;
1236 SCM dropped
= scm_cons(SCM_EOL
, SCM_EOL
);
1237 SCM dropped_tail
= dropped
;
1239 SCM_ASSERT(call
, pred
, 2, FUNC_NAME
);
1241 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR(list
)) {
1242 SCM elt
= SCM_CAR(list
);
1243 SCM new_tail
= scm_cons(SCM_CAR(list
), SCM_EOL
);
1244 if (scm_is_true (call (pred
, elt
))) {
1245 SCM_SETCDR(kept_tail
, new_tail
);
1246 kept_tail
= new_tail
;
1249 SCM_SETCDR(dropped_tail
, new_tail
);
1250 dropped_tail
= new_tail
;
1253 /* re-use the initial conses for the values list */
1254 SCM_SETCAR(kept
, SCM_CDR(kept
));
1255 SCM_SETCDR(kept
, dropped
);
1256 SCM_SETCAR(dropped
, SCM_CDR(dropped
));
1257 SCM_SETCDR(dropped
, SCM_EOL
);
1258 return scm_values(kept
);
1263 SCM_DEFINE (scm_srfi1_partition_x
, "partition!", 2, 0, 0,
1264 (SCM pred
, SCM lst
),
1265 "Split @var{lst} into those elements which do and don't satisfy\n"
1266 "the predicate @var{pred}.\n"
1268 "The return is two values (@pxref{Multiple Values}), the first\n"
1269 "being a list of all elements from @var{lst} which satisfy\n"
1270 "@var{pred}, the second a list of those which do not.\n"
1272 "The elements in the result lists are in the same order as in\n"
1273 "@var{lst} but the order in which the calls @code{(@var{pred}\n"
1274 "elem)} are made on the list elements is unspecified.\n"
1276 "@var{lst} may be modified to construct the return lists.")
1277 #define FUNC_NAME s_scm_srfi1_partition_x
1279 SCM tlst
, flst
, *tp
, *fp
;
1280 scm_t_trampoline_1 pred_tramp
;
1282 pred_tramp
= scm_trampoline_1 (pred
);
1283 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1285 /* tlst and flst are the lists of true and false elements. tp and fp are
1286 where to store to append to them, initially &tlst and &flst, then
1287 SCM_CDRLOC of the last pair in the respective lists. */
1294 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1296 if (scm_is_true (pred_tramp (pred
, SCM_CAR (lst
))))
1299 tp
= SCM_CDRLOC (lst
);
1304 fp
= SCM_CDRLOC (lst
);
1308 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1310 /* terminate whichever didn't get the last element(s) */
1314 return scm_values (scm_list_2 (tlst
, flst
));
1319 SCM_DEFINE (scm_srfi1_reduce
, "reduce", 3, 0, 0,
1320 (SCM proc
, SCM def
, SCM lst
),
1321 "@code{reduce} is a variant of @code{fold}, where the first call\n"
1322 "to @var{proc} is on two elements from @var{lst}, rather than\n"
1323 "one element and a given initial value.\n"
1325 "If @var{lst} is empty, @code{reduce} returns @var{def} (this is\n"
1326 "the only use for @var{def}). If @var{lst} has just one element\n"
1327 "then that's the return value. Otherwise @var{proc} is called\n"
1328 "on the elements of @var{lst}.\n"
1330 "Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
1331 "@var{previous})}, where @var{elem} is from @var{lst} (the\n"
1332 "second and subsequent elements of @var{lst}), and\n"
1333 "@var{previous} is the return from the previous call to\n"
1334 "@var{proc}. The first element of @var{lst} is the\n"
1335 "@var{previous} for the first call to @var{proc}.\n"
1337 "For example, the following adds a list of numbers, the calls\n"
1338 "made to @code{+} are shown. (Of course @code{+} accepts\n"
1339 "multiple arguments and can add a list directly, with\n"
1343 "(reduce + 0 '(5 6 7)) @result{} 18\n"
1345 "(+ 6 5) @result{} 11\n"
1346 "(+ 7 11) @result{} 18\n"
1349 "@code{reduce} can be used instead of @code{fold} where the\n"
1350 "@var{init} value is an ``identity'', meaning a value which\n"
1351 "under @var{proc} doesn't change the result, in this case 0 is\n"
1352 "an identity since @code{(+ 5 0)} is just 5. @code{reduce}\n"
1353 "avoids that unnecessary call.")
1354 #define FUNC_NAME s_scm_srfi1_reduce
1356 scm_t_trampoline_2 proc_tramp
= scm_trampoline_2 (proc
);
1359 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
1361 ret
= def
; /* if lst is empty */
1362 if (scm_is_pair (lst
))
1364 ret
= SCM_CAR (lst
); /* if lst has one element */
1366 for (lst
= SCM_CDR (lst
); scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1367 ret
= proc_tramp (proc
, SCM_CAR (lst
), ret
);
1370 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG3
, FUNC_NAME
, "list");
1376 SCM_DEFINE (scm_srfi1_reduce_right
, "reduce-right", 3, 0, 0,
1377 (SCM proc
, SCM def
, SCM lst
),
1378 "@code{reduce-right} is a variant of @code{fold-right}, where\n"
1379 "the first call to @var{proc} is on two elements from @var{lst},\n"
1380 "rather than one element and a given initial value.\n"
1382 "If @var{lst} is empty, @code{reduce-right} returns @var{def}\n"
1383 "(this is the only use for @var{def}). If @var{lst} has just\n"
1384 "one element then that's the return value. Otherwise @var{proc}\n"
1385 "is called on the elements of @var{lst}.\n"
1387 "Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
1388 "@var{previous})}, where @var{elem} is from @var{lst} (the\n"
1389 "second last and then working back to the first element of\n"
1390 "@var{lst}), and @var{previous} is the return from the previous\n"
1391 "call to @var{proc}. The last element of @var{lst} is the\n"
1392 "@var{previous} for the first call to @var{proc}.\n"
1394 "For example, the following adds a list of numbers, the calls\n"
1395 "made to @code{+} are shown. (Of course @code{+} accepts\n"
1396 "multiple arguments and can add a list directly, with\n"
1400 "(reduce-right + 0 '(5 6 7)) @result{} 18\n"
1402 "(+ 6 7) @result{} 13\n"
1403 "(+ 5 13) @result{} 18\n"
1406 "@code{reduce-right} can be used instead of @code{fold-right}\n"
1407 "where the @var{init} value is an ``identity'', meaning a value\n"
1408 "which under @var{proc} doesn't change the result, in this case\n"
1409 "0 is an identity since @code{(+ 7 0)} is just 5.\n"
1410 "@code{reduce-right} avoids that unnecessary call.\n"
1412 "@code{reduce} should be preferred over @code{reduce-right} if\n"
1413 "the order of processing doesn't matter, or can be arranged\n"
1414 "either way, since @code{reduce} is a little more efficient.")
1415 #define FUNC_NAME s_scm_srfi1_reduce_right
1417 /* To work backwards across a list requires either repeatedly traversing
1418 to get each previous element, or using some memory for a reversed or
1419 random-access form. Repeated traversal might not be too terrible, but
1420 is of course quadratic complexity and hence to be avoided in case LST
1421 is long. A vector is preferred over a reversed list since it's more
1422 compact and is less work for the gc to collect. */
1424 scm_t_trampoline_2 proc_tramp
= scm_trampoline_2 (proc
);
1428 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
1430 if (SCM_NULL_OR_NIL_P (lst
))
1433 vec
= scm_vector (lst
);
1434 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
1436 ret
= SCM_SIMPLE_VECTOR_REF (vec
, len
-1);
1437 for (i
= len
-2; i
>= 0; i
--)
1438 ret
= proc_tramp (proc
, SCM_SIMPLE_VECTOR_REF (vec
, i
), ret
);
1445 SCM_DEFINE (scm_srfi1_remove
, "remove", 2, 0, 0,
1446 (SCM pred
, SCM list
),
1447 "Return a list containing all elements from @var{lst} which do\n"
1448 "not satisfy the predicate @var{pred}. The elements in the\n"
1449 "result list have the same order as in @var{lst}. The order in\n"
1450 "which @var{pred} is applied to the list elements is not\n"
1452 #define FUNC_NAME s_scm_srfi1_remove
1454 scm_t_trampoline_1 call
= scm_trampoline_1 (pred
);
1458 SCM_ASSERT (call
, pred
, 1, FUNC_NAME
);
1459 SCM_VALIDATE_LIST (2, list
);
1461 for (prev
= &res
, walk
= list
;
1463 walk
= SCM_CDR (walk
))
1465 if (scm_is_false (call (pred
, SCM_CAR (walk
))))
1467 *prev
= scm_cons (SCM_CAR (walk
), SCM_EOL
);
1468 prev
= SCM_CDRLOC (*prev
);
1477 SCM_DEFINE (scm_srfi1_remove_x
, "remove!", 2, 0, 0,
1478 (SCM pred
, SCM list
),
1479 "Return a list containing all elements from @var{list} which do\n"
1480 "not satisfy the predicate @var{pred}. The elements in the\n"
1481 "result list have the same order as in @var{list}. The order in\n"
1482 "which @var{pred} is applied to the list elements is not\n"
1483 "specified. @var{list} may be modified to build the return\n"
1485 #define FUNC_NAME s_scm_srfi1_remove_x
1487 scm_t_trampoline_1 call
= scm_trampoline_1 (pred
);
1490 SCM_ASSERT (call
, pred
, 1, FUNC_NAME
);
1491 SCM_VALIDATE_LIST (2, list
);
1493 for (prev
= &list
, walk
= list
;
1495 walk
= SCM_CDR (walk
))
1497 if (scm_is_false (call (pred
, SCM_CAR (walk
))))
1498 prev
= SCM_CDRLOC (walk
);
1500 *prev
= SCM_CDR (walk
);
1508 SCM_DEFINE (scm_srfi1_seventh
, "seventh", 1, 0, 0,
1510 "Return the seventh element of @var{lst}.")
1511 #define FUNC_NAME s_scm_srfi1_seventh
1513 return scm_list_ref (lst
, SCM_I_MAKINUM (6));
1518 SCM_DEFINE (scm_srfi1_sixth
, "sixth", 1, 0, 0,
1520 "Return the sixth element of @var{lst}.")
1521 #define FUNC_NAME s_scm_srfi1_sixth
1523 return scm_list_ref (lst
, SCM_I_MAKINUM (5));
1528 SCM_DEFINE (scm_srfi1_span
, "span", 2, 0, 0,
1529 (SCM pred
, SCM lst
),
1530 "Return two values, the longest initial prefix of @var{lst}\n"
1531 "whose elements all satisfy the predicate @var{pred}, and the\n"
1532 "remainder of @var{lst}.")
1533 #define FUNC_NAME s_scm_srfi1_span
1535 scm_t_trampoline_1 pred_tramp
;
1538 pred_tramp
= scm_trampoline_1 (pred
);
1539 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1543 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1545 SCM elem
= SCM_CAR (lst
);
1546 if (scm_is_false (pred_tramp (pred
, elem
)))
1549 /* want this elem, tack it onto the end of ret */
1550 *p
= scm_cons (elem
, SCM_EOL
);
1551 p
= SCM_CDRLOC (*p
);
1553 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1556 return scm_values (scm_list_2 (ret
, lst
));
1561 SCM_DEFINE (scm_srfi1_span_x
, "span!", 2, 0, 0,
1562 (SCM pred
, SCM lst
),
1563 "Return two values, the longest initial prefix of @var{lst}\n"
1564 "whose elements all satisfy the predicate @var{pred}, and the\n"
1565 "remainder of @var{lst}. @var{lst} may be modified to form the\n"
1567 #define FUNC_NAME s_scm_srfi1_span_x
1570 scm_t_trampoline_1 pred_tramp
;
1572 pred_tramp
= scm_trampoline_1 (pred
);
1573 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1576 for (upto
= lst
; scm_is_pair (upto
); upto
= SCM_CDR (upto
))
1578 if (scm_is_false (pred_tramp (pred
, SCM_CAR (upto
))))
1581 /* want this element */
1582 p
= SCM_CDRLOC (upto
);
1584 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1588 return scm_values (scm_list_2 (lst
, upto
));
1593 SCM_DEFINE (scm_srfi1_split_at
, "split-at", 2, 0, 0,
1595 "Return two values (multiple values), being a list of the\n"
1596 "elements before index @var{n} in @var{lst}, and a list of those\n"
1598 #define FUNC_NAME s_scm_srfi1_split_at
1601 /* pre is a list of elements before the i split point, loc is the CDRLOC
1602 of the last cell, ie. where to store to append to it */
1606 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1608 SCM_VALIDATE_CONS (SCM_ARG1
, lst
);
1610 *loc
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
1611 loc
= SCM_CDRLOC (*loc
);
1614 return scm_values (scm_list_2 (pre
, lst
));
1619 SCM_DEFINE (scm_srfi1_split_at_x
, "split-at!", 2, 0, 0,
1621 "Return two values (multiple values), being a list of the\n"
1622 "elements before index @var{n} in @var{lst}, and a list of those\n"
1623 "after. @var{lst} is modified to form those values.")
1624 #define FUNC_NAME s_scm_srfi1_split_at
1630 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1632 SCM_VALIDATE_CONS (SCM_ARG1
, upto
);
1634 loc
= SCM_CDRLOC (upto
);
1635 upto
= SCM_CDR (upto
);
1639 return scm_values (scm_list_2 (lst
, upto
));
1644 SCM_DEFINE (scm_srfi1_take_x
, "take!", 2, 0, 0,
1646 "Return a list containing the first @var{n} elements of\n"
1648 #define FUNC_NAME s_scm_srfi1_take_x
1653 SCM_VALIDATE_INUM_MIN_COPY (SCM_ARG2
, n
, 0, nn
);
1658 pos
= scm_list_tail (lst
, SCM_I_MAKINUM (nn
- 1));
1660 /* Must have at least one cell left, mustn't have reached the end of an
1661 n-1 element list. SCM_VALIDATE_CONS here gives the same error as
1662 scm_list_tail does on say an n-2 element list, though perhaps a range
1663 error would make more sense (for both). */
1664 SCM_VALIDATE_CONS (SCM_ARG1
, pos
);
1666 SCM_SETCDR (pos
, SCM_EOL
);
1672 SCM_DEFINE (scm_srfi1_take_right
, "take-right", 2, 0, 0,
1674 "Return the a list containing the @var{n} last elements of\n"
1676 #define FUNC_NAME s_scm_srfi1_take_right
1678 SCM tail
= scm_list_tail (lst
, n
);
1679 while (scm_is_pair (tail
))
1681 lst
= SCM_CDR (lst
);
1682 tail
= SCM_CDR (tail
);
1684 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
1690 SCM_DEFINE (scm_srfi1_take_while
, "take-while", 2, 0, 0,
1691 (SCM pred
, SCM lst
),
1692 "Return a new list which is the longest initial prefix of\n"
1693 "@var{lst} whose elements all satisfy the predicate @var{pred}.")
1694 #define FUNC_NAME s_scm_srfi1_take_while
1696 scm_t_trampoline_1 pred_tramp
;
1699 pred_tramp
= scm_trampoline_1 (pred
);
1700 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1704 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1706 SCM elem
= SCM_CAR (lst
);
1707 if (scm_is_false (pred_tramp (pred
, elem
)))
1710 /* want this elem, tack it onto the end of ret */
1711 *p
= scm_cons (elem
, SCM_EOL
);
1712 p
= SCM_CDRLOC (*p
);
1714 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1722 SCM_DEFINE (scm_srfi1_take_while_x
, "take-while!", 2, 0, 0,
1723 (SCM pred
, SCM lst
),
1724 "Return the longest initial prefix of @var{lst} whose elements\n"
1725 "all satisfy the predicate @var{pred}. @var{lst} may be\n"
1726 "modified to form the return.")
1727 #define FUNC_NAME s_scm_srfi1_take_while_x
1730 scm_t_trampoline_1 pred_tramp
;
1732 pred_tramp
= scm_trampoline_1 (pred
);
1733 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1736 for (upto
= lst
; scm_is_pair (upto
); upto
= SCM_CDR (upto
))
1738 if (scm_is_false (pred_tramp (pred
, SCM_CAR (upto
))))
1741 /* want this element */
1742 p
= SCM_CDRLOC (upto
);
1744 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1753 SCM_DEFINE (scm_srfi1_tenth
, "tenth", 1, 0, 0,
1755 "Return the tenth element of @var{lst}.")
1756 #define FUNC_NAME s_scm_srfi1_tenth
1758 return scm_list_ref (lst
, SCM_I_MAKINUM (9));
1764 scm_init_srfi_1 (void)
1766 SCM the_root_module
= scm_lookup_closure_module (SCM_BOOL_F
);
1767 #ifndef SCM_MAGIC_SNARFER
1768 #include "srfi/srfi-1.x"
1770 scm_c_extend_primitive_generic
1771 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "map")),
1772 SCM_VARIABLE_REF (scm_c_lookup ("map")));
1773 scm_c_extend_primitive_generic
1774 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "for-each")),
1775 SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
1778 /* End of srfi-1.c. */