1 /* srfi-1.c --- SRFI-1 procedures for Guile
3 * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003 Free Software
6 * This library is free software; you can redistribute it and/or
7 * modify it under the terms of the GNU Lesser General Public
8 * License as published by the Free Software Foundation; either
9 * version 2.1 of the License, or (at your option) any later version.
11 * This library is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 * Lesser General Public License for more details.
16 * You should have received a copy of the GNU Lesser General Public
17 * License along with this library; if not, write to the Free Software
18 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
22 #include <libguile/lang.h>
26 /* The intent of this file is to gradually replace those Scheme
27 * procedures in srfi-1.scm which extends core primitive procedures,
28 * so that using srfi-1 won't have performance penalties.
30 * Please feel free to contribute any new replacements!
34 srfi1_ilength (SCM sx
)
41 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
42 if (!scm_is_pair (hare
)) return -2;
45 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
46 if (!scm_is_pair (hare
)) return -2;
49 /* For every two steps the hare takes, the tortoise takes one. */
50 tortoise
= SCM_CDR(tortoise
);
52 while (! scm_is_eq (hare
, tortoise
));
54 /* If the tortoise ever catches the hare, then the list must contain
60 equal_trampoline (SCM proc
, SCM arg1
, SCM arg2
)
62 return scm_equal_p (arg1
, arg2
);
66 SCM_DEFINE (scm_srfi1_alist_copy
, "alist-copy", 1, 0, 0,
68 "Return a copy of @var{alist}, copying both the pairs comprising\n"
69 "the list and those making the associations.")
70 #define FUNC_NAME s_scm_srfi1_alist_copy
74 /* ret is the list to return. p is where to append to it, initially &ret
75 then SCM_CDRLOC of the last pair. */
79 for ( ; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
81 elem
= SCM_CAR (alist
);
83 /* each element of alist must be a pair */
84 SCM_ASSERT_TYPE (scm_is_pair (elem
), alist
, SCM_ARG1
, FUNC_NAME
,
87 c
= scm_cons (scm_cons (SCM_CAR (elem
), SCM_CDR (elem
)), SCM_EOL
);
92 /* alist must be a proper list */
93 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (alist
), alist
, SCM_ARG1
, FUNC_NAME
,
100 SCM_DEFINE (scm_srfi1_concatenate
, "concatenate", 1, 0, 0,
102 "Construct a list by appending all lists in @var{lstlst}.\n"
104 "@code{concatenate} is the same as @code{(apply append\n"
105 "@var{lstlst})}. It exists because some Scheme implementations\n"
106 "have a limit on the number of arguments a function takes, which\n"
107 "the @code{apply} might exceed. In Guile there is no such\n"
109 #define FUNC_NAME s_scm_srfi1_concatenate
111 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
112 return scm_append (lstlst
);
117 SCM_DEFINE (scm_srfi1_concatenate_x
, "concatenate!", 1, 0, 0,
119 "Construct a list by appending all lists in @var{lstlst}. Those\n"
120 "lists may be modified to produce the result.\n"
122 "@code{concatenate!} is the same as @code{(apply append!\n"
123 "@var{lstlst})}. It exists because some Scheme implementations\n"
124 "have a limit on the number of arguments a function takes, which\n"
125 "the @code{apply} might exceed. In Guile there is no such\n"
127 #define FUNC_NAME s_scm_srfi1_concatenate
129 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
130 return scm_append_x (lstlst
);
135 SCM_DEFINE (scm_srfi1_count
, "count", 2, 0, 1,
136 (SCM pred
, SCM list1
, SCM rest
),
137 "Return a count of the number of times @var{pred} returns true\n"
138 "when called on elements from the given lists.\n"
140 "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
141 "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
142 "corresponding @var{list1} @dots{} @var{lstN}. The first call is\n"
143 "with the first element of each list, the second with the second\n"
144 "element from each, and so on.\n"
146 "Counting stops when the end of the shortest list is reached.\n"
147 "At least one list must be non-circular.")
148 #define FUNC_NAME s_scm_srfi1_count
153 SCM_VALIDATE_REST_ARGUMENT (rest
);
157 if (scm_is_null (rest
))
160 scm_t_trampoline_1 pred_tramp
;
161 pred_tramp
= scm_trampoline_1 (pred
);
162 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
164 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
165 count
+= scm_is_true (pred_tramp (pred
, SCM_CAR (list1
)));
167 /* check below that list1 is a proper list, and done */
172 else if (scm_is_pair (rest
) && scm_is_null (SCM_CDR (rest
)))
175 scm_t_trampoline_2 pred_tramp
;
178 pred_tramp
= scm_trampoline_2 (pred
);
179 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
181 list2
= SCM_CAR (rest
);
184 if (! scm_is_pair (list1
))
186 if (! scm_is_pair (list2
))
192 count
+= scm_is_true (pred_tramp
193 (pred
, SCM_CAR (list1
), SCM_CAR (list2
)));
194 list1
= SCM_CDR (list1
);
195 list2
= SCM_CDR (list2
);
200 /* three or more lists */
204 /* vec is the list arguments */
205 vec
= scm_vector (scm_cons (list1
, rest
));
206 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
208 /* args is the argument list to pass to pred, same length as vec,
209 re-used for each call */
210 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
214 /* first elem of each list in vec into args, and step those
215 vec entries onto their next element */
216 for (i
= 0, a
= args
, argnum
= 2;
218 i
++, a
= SCM_CDR (a
), argnum
++)
220 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
221 if (! scm_is_pair (lst
))
222 goto check_lst_and_done
;
223 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for pred */
224 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
227 count
+= scm_is_true (scm_apply (pred
, args
, SCM_EOL
));
232 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
233 return scm_from_long (count
);
238 SCM_DEFINE (scm_srfi1_delete
, "delete", 2, 1, 0,
239 (SCM x
, SCM lst
, SCM pred
),
240 "Return a list containing the elements of @var{lst} but with\n"
241 "those equal to @var{x} deleted. The returned elements will be\n"
242 "in the same order as they were in @var{lst}.\n"
244 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
245 "given. An equality call is made just once for each element,\n"
246 "but the order in which the calls are made on the elements is\n"
249 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
250 "given @var{x} is first. This means for instance elements\n"
251 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
253 "@var{lst} is not modified, but the returned list might share a\n"
254 "common tail with @var{lst}.")
255 #define FUNC_NAME s_scm_srfi1_delete
257 scm_t_trampoline_2 equal_p
;
258 SCM ret
, *p
, keeplst
;
260 if (SCM_UNBNDP (pred
))
261 return scm_delete (x
, lst
);
263 equal_p
= scm_trampoline_2 (pred
);
264 SCM_ASSERT (equal_p
, pred
, SCM_ARG3
, FUNC_NAME
);
266 /* ret is the return list being constructed. p is where to append to it,
267 initially &ret then SCM_CDRLOC of the last pair. lst progresses as
268 elements are considered.
270 Elements to be retained are not immediately copied, instead keeplst is
271 the last pair in lst which is to be retained but not yet copied. When
272 there's no more deletions, *p can be set to keeplst to share the
273 remainder of the original lst. (The entire original lst if there's no
274 deletions at all.) */
280 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
282 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
284 /* delete this element, so copy from keeplst (inclusive) to lst
285 (exclusive) onto ret */
286 while (! scm_is_eq (keeplst
, lst
))
288 SCM c
= scm_cons (SCM_CAR (keeplst
), SCM_EOL
);
291 keeplst
= SCM_CDR (keeplst
);
294 keeplst
= SCM_CDR (lst
);
298 /* final retained elements */
301 /* demand that lst was a proper list */
302 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
309 SCM_DEFINE (scm_srfi1_delete_x
, "delete!", 2, 1, 0,
310 (SCM x
, SCM lst
, SCM pred
),
311 "Return a list containing the elements of @var{lst} but with\n"
312 "those equal to @var{x} deleted. The returned elements will be\n"
313 "in the same order as they were in @var{lst}.\n"
315 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
316 "given. An equality call is made just once for each element,\n"
317 "but the order in which the calls are made on the elements is\n"
320 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
321 "given @var{x} is first. This means for instance elements\n"
322 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
324 "@var{lst} may be modified to construct the returned list.")
325 #define FUNC_NAME s_scm_srfi1_delete_x
327 scm_t_trampoline_2 equal_p
;
331 if (SCM_UNBNDP (pred
))
332 return scm_delete_x (x
, lst
);
334 equal_p
= scm_trampoline_2 (pred
);
335 SCM_ASSERT (equal_p
, pred
, SCM_ARG3
, FUNC_NAME
);
337 for (prev
= &lst
, walk
= lst
;
339 walk
= SCM_CDR (walk
))
341 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (walk
))))
342 *prev
= SCM_CDR (walk
);
344 prev
= SCM_CDRLOC (walk
);
347 /* demand the input was a proper list */
348 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk
), walk
, SCM_ARG2
, FUNC_NAME
,"list");
354 SCM_DEFINE (scm_srfi1_delete_duplicates
, "delete-duplicates", 1, 1, 0,
356 "Return a list containing the elements of @var{lst} but without\n"
359 "When elements are equal, only the first in @var{lst} is\n"
360 "retained. Equal elements can be anywhere in @var{lst}, they\n"
361 "don't have to be adjacent. The returned list will have the\n"
362 "retained elements in the same order as they were in @var{lst}.\n"
364 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
365 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
366 "being before @var{y} in @var{lst}. A call is made at most once\n"
367 "for each combination, but the sequence of the calls across the\n"
368 "elements is unspecified.\n"
370 "@var{lst} is not modified, but the return might share a common\n"
371 "tail with @var{lst}.\n"
373 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
374 "it must check each element against all those preceding it. For\n"
375 "long lists it is more efficient to sort and then compare only\n"
376 "adjacent elements.")
377 #define FUNC_NAME s_scm_srfi1_delete_duplicates
379 scm_t_trampoline_2 equal_p
;
380 SCM ret
, *p
, keeplst
, item
, l
;
382 /* ret is the new list constructed. p is where to append, initially &ret
383 then SCM_CDRLOC of the last pair. lst is advanced as each element is
386 Elements retained are not immediately appended to ret, instead keeplst
387 is the last pair in lst which is to be kept but is not yet copied.
388 Initially this is the first pair of lst, since the first element is
391 *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
392 the elements retained, making the equality search loop easy.
394 If an item must be deleted, elements from keeplst (inclusive) to lst
395 (exclusive) must be copied and appended to ret. When there's no more
396 deletions, *p is left set to keeplst, so ret shares structure with the
397 original lst. (ret will be the entire original lst if there are no
400 /* skip to end if an empty list (or something invalid) */
402 if (scm_is_pair (lst
))
404 if (SCM_UNBNDP (pred
))
405 equal_p
= equal_trampoline
;
408 equal_p
= scm_trampoline_2 (pred
);
409 SCM_ASSERT (equal_p
, pred
, SCM_ARG2
, FUNC_NAME
);
415 /* loop over lst elements starting from second */
419 if (! scm_is_pair (lst
))
421 item
= SCM_CAR (lst
);
423 /* loop searching ret upto lst */
424 for (l
= ret
; ! scm_is_eq (l
, lst
); l
= SCM_CDR (l
))
426 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
428 /* duplicate, don't want this element, so copy keeplst
429 (inclusive) to lst (exclusive) onto ret */
430 while (! scm_is_eq (keeplst
, lst
))
432 SCM c
= scm_cons (SCM_CAR (keeplst
), SCM_EOL
);
435 keeplst
= SCM_CDR (keeplst
);
438 keeplst
= SCM_CDR (lst
); /* elem after the one deleted */
446 /* demand that lst was a proper list */
447 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
454 SCM_DEFINE (scm_srfi1_delete_duplicates_x
, "delete-duplicates!", 1, 1, 0,
456 "Return a list containing the elements of @var{lst} but without\n"
459 "When elements are equal, only the first in @var{lst} is\n"
460 "retained. Equal elements can be anywhere in @var{lst}, they\n"
461 "don't have to be adjacent. The returned list will have the\n"
462 "retained elements in the same order as they were in @var{lst}.\n"
464 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
465 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
466 "being before @var{y} in @var{lst}. A call is made at most once\n"
467 "for each combination, but the sequence of the calls across the\n"
468 "elements is unspecified.\n"
470 "@var{lst} may be modified to construct the returned list.\n"
472 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
473 "it must check each element against all those preceding it. For\n"
474 "long lists it is more efficient to sort and then compare only\n"
475 "adjacent elements.")
476 #define FUNC_NAME s_scm_srfi1_delete_duplicates_x
478 scm_t_trampoline_2 equal_p
;
479 SCM ret
, endret
, item
, l
;
481 /* ret is the return list, constructed from the pairs in lst. endret is
482 the last pair of ret, initially the first pair. lst is advanced as
483 elements are considered. */
485 /* skip to end if an empty list (or something invalid) */
487 if (scm_is_pair (lst
))
489 if (SCM_UNBNDP (pred
))
490 equal_p
= equal_trampoline
;
493 equal_p
= scm_trampoline_2 (pred
);
494 SCM_ASSERT (equal_p
, pred
, SCM_ARG2
, FUNC_NAME
);
499 /* loop over lst elements starting from second */
503 if (! scm_is_pair (lst
))
505 item
= SCM_CAR (lst
);
507 /* is item equal to any element from ret to endret (inclusive)? */
511 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
512 break; /* equal, forget this element */
514 if (scm_is_eq (l
, endret
))
516 /* not equal to any, so append this pair */
517 SCM_SETCDR (endret
, lst
);
525 /* terminate, in case last element was deleted */
526 SCM_SETCDR (endret
, SCM_EOL
);
529 /* demand that lst was a proper list */
530 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
537 SCM_DEFINE (scm_srfi1_drop_right
, "drop-right", 2, 0, 0,
539 "Return a new list containing all except the last @var{n}\n"
540 "elements of @var{lst}.")
541 #define FUNC_NAME s_scm_srfi1_drop_right
543 SCM tail
= scm_list_tail (lst
, n
);
546 while (scm_is_pair (tail
))
548 *rend
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
549 rend
= SCM_CDRLOC (*rend
);
552 tail
= SCM_CDR (tail
);
554 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
560 SCM_DEFINE (scm_srfi1_filter_map
, "filter-map", 2, 0, 1,
561 (SCM proc
, SCM list1
, SCM rest
),
562 "Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
563 "return a list of the results as per SRFI-1 @code{map}, except\n"
564 "that any @code{#f} results are omitted from the list returned.")
565 #define FUNC_NAME s_scm_srfi1_filter_map
567 SCM ret
, *loc
, elem
, newcell
, lst
;
570 SCM_VALIDATE_REST_ARGUMENT (rest
);
575 if (SCM_NULLP (rest
))
578 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
579 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
581 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
583 elem
= proc_tramp (proc
, SCM_CAR (list1
));
584 if (scm_is_true (elem
))
586 newcell
= scm_cons (elem
, SCM_EOL
);
588 loc
= SCM_CDRLOC (newcell
);
592 /* check below that list1 is a proper list, and done */
597 else if (SCM_NULLP (SCM_CDR (rest
)))
600 scm_t_trampoline_2 proc_tramp
= scm_trampoline_2 (proc
);
601 SCM list2
= SCM_CAR (rest
);
602 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
606 if (! scm_is_pair (list1
))
608 if (! scm_is_pair (list2
))
612 goto check_lst_and_done
;
614 elem
= proc_tramp (proc
, SCM_CAR (list1
), SCM_CAR (list2
));
615 if (scm_is_true (elem
))
617 newcell
= scm_cons (elem
, SCM_EOL
);
619 loc
= SCM_CDRLOC (newcell
);
621 list1
= SCM_CDR (list1
);
622 list2
= SCM_CDR (list2
);
627 /* three or more lists */
631 /* vec is the list arguments */
632 vec
= scm_vector (scm_cons (list1
, rest
));
633 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
635 /* args is the argument list to pass to proc, same length as vec,
636 re-used for each call */
637 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
641 /* first elem of each list in vec into args, and step those
642 vec entries onto their next element */
643 for (i
= 0, a
= args
, argnum
= 2;
645 i
++, a
= SCM_CDR (a
), argnum
++)
647 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
648 if (! scm_is_pair (lst
))
649 goto check_lst_and_done
;
650 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for proc */
651 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
654 elem
= scm_apply (proc
, args
, SCM_EOL
);
655 if (scm_is_true (elem
))
657 newcell
= scm_cons (elem
, SCM_EOL
);
659 loc
= SCM_CDRLOC (newcell
);
665 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
671 SCM_DEFINE (scm_srfi1_find
, "find", 2, 0, 0,
673 "Return the first element of @var{lst} which satisfies the\n"
674 "predicate @var{pred}, or return @code{#f} if no such element is\n"
676 #define FUNC_NAME s_scm_srfi1_find
678 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (pred
);
679 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
681 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
683 SCM elem
= SCM_CAR (lst
);
684 if (scm_is_true (pred_tramp (pred
, elem
)))
687 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
694 SCM_DEFINE (scm_srfi1_find_tail
, "find-tail", 2, 0, 0,
696 "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
697 "predicate @var{pred}, or return @code{#f} if no such element is\n"
699 #define FUNC_NAME s_scm_srfi1_find_tail
701 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (pred
);
702 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
704 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
705 if (scm_is_true (pred_tramp (pred
, SCM_CAR (lst
))))
707 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
714 SCM_DEFINE (scm_srfi1_length_plus
, "length+", 1, 0, 0,
716 "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
718 #define FUNC_NAME s_scm_srfi1_length_plus
720 long len
= scm_ilength (lst
);
721 return (len
>= 0 ? SCM_I_MAKINUM (len
) : SCM_BOOL_F
);
726 /* This routine differs from the core list-copy in allowing improper lists.
727 Maybe the core could allow them similarly. */
729 SCM_DEFINE (scm_srfi1_list_copy
, "list-copy", 1, 0, 0,
731 "Return a copy of the given list @var{lst}.\n"
733 "@var{lst} can be a proper or improper list. And if @var{lst}\n"
734 "is not a pair then it's treated as the final tail of an\n"
735 "improper list and simply returned.")
736 #define FUNC_NAME s_scm_srfi1_list_copy
746 while (scm_is_pair (from_here
))
749 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
751 fill_here
= SCM_CDRLOC (c
);
752 from_here
= SCM_CDR (from_here
);
759 /* Typechecking for multi-argument MAP and FOR-EACH.
761 Verify that each element of the vector ARGV, except for the first,
762 is a list and return minimum length. Attribute errors to WHO,
763 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
765 check_map_args (SCM argv
,
774 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
776 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
779 if (!(scm_is_null (elt
) || scm_is_pair (elt
)))
783 scm_apply_generic (gf
, scm_cons (proc
, args
));
785 scm_wrong_type_arg (who
, i
+ 2, elt
);
788 elt_len
= srfi1_ilength (elt
);
790 goto check_map_error
;
792 if (len
< 0 || (elt_len
>= 0 && elt_len
< len
))
797 goto check_map_error
;
799 scm_remember_upto_here_1 (argv
);
804 SCM_GPROC (s_srfi1_map
, "map", 2, 0, 1, scm_srfi1_map
, g_srfi1_map
);
806 /* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
807 sequentially, starting with the first element(s). This is used in
808 the Scheme procedure `map-in-order', which guarantees sequential
809 behaviour, is implemented using scm_map. If the behaviour changes,
810 we need to update `map-in-order'.
814 scm_srfi1_map (SCM proc
, SCM arg1
, SCM args
)
815 #define FUNC_NAME s_srfi1_map
821 len
= srfi1_ilength (arg1
);
822 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
824 scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_srfi1_map
);
825 SCM_VALIDATE_REST_ARGUMENT (args
);
826 if (scm_is_null (args
))
828 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
829 SCM_GASSERT2 (call
, g_srfi1_map
, proc
, arg1
, SCM_ARG1
, s_srfi1_map
);
830 SCM_GASSERT2 (len
>= 0, g_srfi1_map
, proc
, arg1
, SCM_ARG2
, s_srfi1_map
);
831 while (SCM_NIMP (arg1
))
833 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
834 pres
= SCM_CDRLOC (*pres
);
835 arg1
= SCM_CDR (arg1
);
839 if (scm_is_null (SCM_CDR (args
)))
841 SCM arg2
= SCM_CAR (args
);
842 int len2
= srfi1_ilength (arg2
);
843 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
844 SCM_GASSERTn (call
, g_srfi1_map
,
845 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_map
);
846 if (len
< 0 || (len2
>= 0 && len2
< len
))
848 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
849 && len
>= 0 && len2
>= -1,
851 scm_cons2 (proc
, arg1
, args
),
852 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
856 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
857 pres
= SCM_CDRLOC (*pres
);
858 arg1
= SCM_CDR (arg1
);
859 arg2
= SCM_CDR (arg2
);
864 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
865 len
= check_map_args (args
, len
, g_srfi1_map
, proc
, arg1
, s_srfi1_map
);
869 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
871 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
872 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
873 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
875 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
876 pres
= SCM_CDRLOC (*pres
);
883 SCM_REGISTER_PROC (s_srfi1_map_in_order
, "map-in-order", 2, 0, 1, scm_srfi1_map
);
885 SCM_GPROC (s_srfi1_for_each
, "for-each", 2, 0, 1, scm_srfi1_for_each
, g_srfi1_for_each
);
888 scm_srfi1_for_each (SCM proc
, SCM arg1
, SCM args
)
889 #define FUNC_NAME s_srfi1_for_each
892 len
= srfi1_ilength (arg1
);
893 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
894 g_srfi1_for_each
, scm_cons2 (proc
, arg1
, args
),
895 SCM_ARG2
, s_srfi1_for_each
);
896 SCM_VALIDATE_REST_ARGUMENT (args
);
897 if (scm_is_null (args
))
899 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
900 SCM_GASSERT2 (call
, g_srfi1_for_each
, proc
, arg1
,
901 SCM_ARG1
, s_srfi1_for_each
);
902 SCM_GASSERT2 (len
>= 0, g_srfi1_for_each
, proc
, arg1
,
903 SCM_ARG2
, s_srfi1_map
);
904 while (SCM_NIMP (arg1
))
906 call (proc
, SCM_CAR (arg1
));
907 arg1
= SCM_CDR (arg1
);
909 return SCM_UNSPECIFIED
;
911 if (scm_is_null (SCM_CDR (args
)))
913 SCM arg2
= SCM_CAR (args
);
914 int len2
= srfi1_ilength (arg2
);
915 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
916 SCM_GASSERTn (call
, g_srfi1_for_each
,
917 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_for_each
);
918 if (len
< 0 || (len2
>= 0 && len2
< len
))
920 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
921 && len
>= 0 && len2
>= -1,
923 scm_cons2 (proc
, arg1
, args
),
924 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
928 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
929 arg1
= SCM_CDR (arg1
);
930 arg2
= SCM_CDR (arg2
);
933 return SCM_UNSPECIFIED
;
935 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
936 len
= check_map_args (args
, len
, g_srfi1_for_each
, proc
, arg1
,
941 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
943 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
944 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
945 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
947 scm_apply (proc
, arg1
, SCM_EOL
);
950 return SCM_UNSPECIFIED
;
955 SCM_DEFINE (scm_srfi1_member
, "member", 2, 1, 0,
956 (SCM x
, SCM lst
, SCM pred
),
957 "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
958 "to @var{x}. If @var{x} does not appear in @var{lst}, return\n"
961 "Equality is determined by @code{equal?}, or by the equality\n"
962 "predicate @var{=} if given. @var{=} is called @code{(= @var{x}\n"
963 "elem)}, ie.@: with the given @var{x} first, so for example to\n"
964 "find the first element greater than 5,\n"
967 "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
970 "This version of @code{member} extends the core @code{member} by\n"
971 "accepting an equality predicate.")
972 #define FUNC_NAME s_scm_srfi1_member
974 scm_t_trampoline_2 equal_p
;
975 SCM_VALIDATE_LIST (2, lst
);
976 if (SCM_UNBNDP (pred
))
977 equal_p
= equal_trampoline
;
980 equal_p
= scm_trampoline_2 (pred
);
981 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
983 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
985 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
992 SCM_DEFINE (scm_srfi1_assoc
, "assoc", 2, 1, 0,
993 (SCM key
, SCM alist
, SCM pred
),
994 "Behaves like @code{assq} but uses third argument @var{pred?}\n"
995 "for key comparison. If @var{pred?} is not supplied,\n"
996 "@code{equal?} is used. (Extended from R5RS.)\n")
997 #define FUNC_NAME s_scm_srfi1_assoc
1000 scm_t_trampoline_2 equal_p
;
1001 if (SCM_UNBNDP (pred
))
1002 equal_p
= equal_trampoline
;
1005 equal_p
= scm_trampoline_2 (pred
);
1006 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
1008 for(; scm_is_pair (ls
); ls
= SCM_CDR (ls
))
1010 SCM tmp
= SCM_CAR (ls
);
1011 SCM_ASSERT_TYPE (scm_is_pair (tmp
), alist
, SCM_ARG2
, FUNC_NAME
,
1012 "association list");
1013 if (scm_is_true (equal_p (pred
, SCM_CAR (tmp
), key
)))
1016 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls
), alist
, SCM_ARG2
, FUNC_NAME
,
1017 "association list");
1022 SCM_DEFINE (scm_srfi1_partition
, "partition", 2, 0, 0,
1023 (SCM pred
, SCM list
),
1024 "Partition the elements of @var{list} with predicate @var{pred}.\n"
1025 "Return two values: the list of elements satifying @var{pred} and\n"
1026 "the list of elements @emph{not} satisfying @var{pred}. The order\n"
1027 "of the output lists follows the order of @var{list}. @var{list}\n"
1028 "is not mutated. One of the output lists may share memory with @var{list}.\n")
1029 #define FUNC_NAME s_scm_srfi1_partition
1031 /* In this implementation, the output lists don't share memory with
1032 list, because it's probably not worth the effort. */
1033 scm_t_trampoline_1 call
= scm_trampoline_1(pred
);
1034 SCM kept
= scm_cons(SCM_EOL
, SCM_EOL
);
1035 SCM kept_tail
= kept
;
1036 SCM dropped
= scm_cons(SCM_EOL
, SCM_EOL
);
1037 SCM dropped_tail
= dropped
;
1039 SCM_ASSERT(call
, pred
, 2, FUNC_NAME
);
1041 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR(list
)) {
1042 SCM elt
= SCM_CAR(list
);
1043 SCM new_tail
= scm_cons(SCM_CAR(list
), SCM_EOL
);
1044 if (scm_is_true (call (pred
, elt
))) {
1045 SCM_SETCDR(kept_tail
, new_tail
);
1046 kept_tail
= new_tail
;
1049 SCM_SETCDR(dropped_tail
, new_tail
);
1050 dropped_tail
= new_tail
;
1053 /* re-use the initial conses for the values list */
1054 SCM_SETCAR(kept
, SCM_CDR(kept
));
1055 SCM_SETCDR(kept
, dropped
);
1056 SCM_SETCAR(dropped
, SCM_CDR(dropped
));
1057 SCM_SETCDR(dropped
, SCM_EOL
);
1058 return scm_values(kept
);
1063 SCM_DEFINE (scm_srfi1_partition_x
, "partition!", 2, 0, 0,
1064 (SCM pred
, SCM lst
),
1065 "Split @var{lst} into those elements which do and don't satisfy\n"
1066 "the predicate @var{pred}.\n"
1068 "The return is two values (@pxref{Multiple Values}), the first\n"
1069 "being a list of all elements from @var{lst} which satisfy\n"
1070 "@var{pred}, the second a list of those which do not.\n"
1072 "The elements in the result lists are in the same order as in\n"
1073 "@var{lst} but the order in which the calls @code{(@var{pred}\n"
1074 "elem)} are made on the list elements is unspecified.\n"
1076 "@var{lst} may be modified to construct the return lists.")
1077 #define FUNC_NAME s_scm_srfi1_partition_x
1079 SCM tlst
, flst
, *tp
, *fp
;
1080 scm_t_trampoline_1 pred_tramp
;
1082 pred_tramp
= scm_trampoline_1 (pred
);
1083 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1085 /* tlst and flst are the lists of true and false elements. tp and fp are
1086 where to store to append to them, initially &tlst and &flst, then
1087 SCM_CDRLOC of the last pair in the respective lists. */
1094 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1096 if (scm_is_true (pred_tramp (pred
, SCM_CAR (lst
))))
1099 tp
= SCM_CDRLOC (lst
);
1104 fp
= SCM_CDRLOC (lst
);
1108 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1110 /* terminate whichever didn't get the last element(s) */
1114 return scm_values (scm_list_2 (tlst
, flst
));
1119 SCM_DEFINE (scm_srfi1_remove
, "remove", 2, 0, 0,
1120 (SCM pred
, SCM list
),
1121 "Return a list containing all elements from @var{lst} which do\n"
1122 "not satisfy the predicate @var{pred}. The elements in the\n"
1123 "result list have the same order as in @var{lst}. The order in\n"
1124 "which @var{pred} is applied to the list elements is not\n"
1126 #define FUNC_NAME s_scm_srfi1_remove
1128 scm_t_trampoline_1 call
= scm_trampoline_1 (pred
);
1132 SCM_ASSERT (call
, pred
, 1, FUNC_NAME
);
1133 SCM_VALIDATE_LIST (2, list
);
1135 for (prev
= &res
, walk
= list
;
1137 walk
= SCM_CDR (walk
))
1139 if (scm_is_false (call (pred
, SCM_CAR (walk
))))
1141 *prev
= scm_cons (SCM_CAR (walk
), SCM_EOL
);
1142 prev
= SCM_CDRLOC (*prev
);
1151 SCM_DEFINE (scm_srfi1_remove_x
, "remove!", 2, 0, 0,
1152 (SCM pred
, SCM list
),
1153 "Return a list containing all elements from @var{list} which do\n"
1154 "not satisfy the predicate @var{pred}. The elements in the\n"
1155 "result list have the same order as in @var{list}. The order in\n"
1156 "which @var{pred} is applied to the list elements is not\n"
1157 "specified. @var{list} may be modified to build the return\n"
1159 #define FUNC_NAME s_scm_srfi1_remove_x
1161 scm_t_trampoline_1 call
= scm_trampoline_1 (pred
);
1164 SCM_ASSERT (call
, pred
, 1, FUNC_NAME
);
1165 SCM_VALIDATE_LIST (2, list
);
1167 for (prev
= &list
, walk
= list
;
1169 walk
= SCM_CDR (walk
))
1171 if (scm_is_false (call (pred
, SCM_CAR (walk
))))
1172 prev
= SCM_CDRLOC (walk
);
1174 *prev
= SCM_CDR (walk
);
1182 SCM_DEFINE (scm_srfi1_split_at
, "split-at", 2, 0, 0,
1184 "Return two values (multiple values), being a list of the\n"
1185 "elements before index @var{n} in @var{lst}, and a list of those\n"
1187 #define FUNC_NAME s_scm_srfi1_split_at
1190 /* pre is a list of elements before the i split point, loc is the CDRLOC
1191 of the last cell, ie. where to store to append to it */
1195 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1197 SCM_VALIDATE_CONS (SCM_ARG1
, lst
);
1199 *loc
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
1200 loc
= SCM_CDRLOC (*loc
);
1203 return scm_values (scm_list_2 (pre
, lst
));
1208 SCM_DEFINE (scm_srfi1_split_at_x
, "split-at!", 2, 0, 0,
1210 "Return two values (multiple values), being a list of the\n"
1211 "elements before index @var{n} in @var{lst}, and a list of those\n"
1212 "after. @var{lst} is modified to form those values.")
1213 #define FUNC_NAME s_scm_srfi1_split_at
1219 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1221 SCM_VALIDATE_CONS (SCM_ARG1
, upto
);
1223 loc
= SCM_CDRLOC (upto
);
1224 upto
= SCM_CDR (upto
);
1228 return scm_values (scm_list_2 (lst
, upto
));
1233 SCM_DEFINE (scm_srfi1_take_right
, "take-right", 2, 0, 0,
1235 "Return the a list containing the @var{n} last elements of\n"
1237 #define FUNC_NAME s_scm_srfi1_take_right
1239 SCM tail
= scm_list_tail (lst
, n
);
1240 while (scm_is_pair (tail
))
1242 lst
= SCM_CDR (lst
);
1243 tail
= SCM_CDR (tail
);
1245 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
1252 scm_init_srfi_1 (void)
1254 SCM the_root_module
= scm_lookup_closure_module (SCM_BOOL_F
);
1255 #ifndef SCM_MAGIC_SNARFER
1256 #include "srfi/srfi-1.x"
1258 scm_c_extend_primitive_generic
1259 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "map")),
1260 SCM_VARIABLE_REF (scm_c_lookup ("map")));
1261 scm_c_extend_primitive_generic
1262 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "for-each")),
1263 SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
1266 /* End of srfi-1.c. */