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_append and scm_append_x don't modify their list argument (only the
67 lists within that list in the case of scm_append_x), hence making them
68 suitable for direct use for concatentate. */
70 SCM_REGISTER_PROC (s_srfi1_concatenate
, "concatenate", 1, 0, 0, scm_append
);
71 SCM_REGISTER_PROC (s_srfi1_concatenate_x
, "concatenate!", 1, 0, 0, scm_append_x
);
74 SCM_DEFINE (scm_srfi1_count
, "count", 2, 0, 1,
75 (SCM pred
, SCM list1
, SCM rest
),
76 "Return a count of the number of times @var{pred} returns true\n"
77 "when called on elements from the given lists.\n"
79 "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
80 "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
81 "corresponding @var{list1} @dots{} @var{lstN}. The first call is\n"
82 "with the first element of each list, the second with the second\n"
83 "element from each, and so on.\n"
85 "Counting stops when the end of the shortest list is reached.\n"
86 "At least one list must be non-circular.")
87 #define FUNC_NAME s_scm_srfi1_count
92 SCM_VALIDATE_REST_ARGUMENT (rest
);
96 if (scm_is_null (rest
))
99 scm_t_trampoline_1 pred_tramp
;
100 pred_tramp
= scm_trampoline_1 (pred
);
101 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
103 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
104 count
+= scm_is_true (pred_tramp (pred
, SCM_CAR (list1
)));
106 /* check below that list1 is a proper list, and done */
111 else if (scm_is_pair (rest
) && scm_is_null (SCM_CDR (rest
)))
114 scm_t_trampoline_2 pred_tramp
;
117 pred_tramp
= scm_trampoline_2 (pred
);
118 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
120 list2
= SCM_CAR (rest
);
123 if (! scm_is_pair (list1
))
125 if (! scm_is_pair (list2
))
131 count
+= scm_is_true (pred_tramp
132 (pred
, SCM_CAR (list1
), SCM_CAR (list2
)));
133 list1
= SCM_CDR (list1
);
134 list2
= SCM_CDR (list2
);
139 /* three or more lists */
140 SCM lstlst
, args
, l
, a
;
142 /* lstlst is a list of the list arguments */
143 lstlst
= scm_cons (list1
, rest
);
145 /* args is the argument list to pass to pred, same length as lstlst,
146 re-used for each call */
147 args
= scm_list_copy (lstlst
);
151 /* first elem of each list in lstlst into args, and step those
152 lstlst entries onto their next element */
153 for (l
= lstlst
, a
= args
, argnum
= 2;
155 l
= SCM_CDR (l
), a
= SCM_CDR (a
), argnum
++)
157 lst
= SCM_CAR (l
); /* list argument */
158 if (! scm_is_pair (lst
))
159 goto check_lst_and_done
;
160 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for pred */
161 SCM_SETCAR (l
, SCM_CDR (lst
)); /* keep rest of lst */
164 count
+= scm_is_true (scm_apply (pred
, args
, SCM_EOL
));
169 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
170 return scm_from_long (count
);
175 SCM_DEFINE (scm_srfi1_delete
, "delete", 2, 1, 0,
176 (SCM x
, SCM lst
, SCM pred
),
177 "Return a list containing the elements of @var{lst} but with\n"
178 "those equal to @var{x} deleted. The returned elements will be\n"
179 "in the same order as they were in @var{lst}.\n"
181 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
182 "given. An equality call is made just once for each element,\n"
183 "but the order in which the calls are made on the elements is\n"
186 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
187 "given @var{x} is first. This means for instance elements\n"
188 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
190 "@var{lst} is not modified, but the returned list might share a\n"
191 "common tail with @var{lst}.")
192 #define FUNC_NAME s_scm_srfi1_delete
194 scm_t_trampoline_2 equal_p
;
195 SCM ret
, *p
, keeplst
;
197 if (SCM_UNBNDP (pred
))
198 return scm_delete (x
, lst
);
200 equal_p
= scm_trampoline_2 (pred
);
201 SCM_ASSERT (equal_p
, pred
, SCM_ARG3
, FUNC_NAME
);
203 /* ret is the return list being constructed. p is where to append to it,
204 initially &ret then SCM_CDRLOC of the last pair. lst progresses as
205 elements are considered.
207 Elements to be retained are not immediately copied, instead keeplst is
208 the last pair in lst which is to be retained but not yet copied. When
209 there's no more deletions, *p can be set to keeplst to share the
210 remainder of the original lst. (The entire original lst if there's no
211 deletions at all.) */
217 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
219 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
221 /* delete this element, so copy from keeplst (inclusive) to lst
222 (exclusive) onto ret */
223 while (! scm_is_eq (keeplst
, lst
))
225 SCM c
= scm_cons (SCM_CAR (keeplst
), SCM_EOL
);
228 keeplst
= SCM_CDR (keeplst
);
231 keeplst
= SCM_CDR (lst
);
235 /* final retained elements */
238 /* demand that lst was a proper list */
239 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
246 SCM_DEFINE (scm_srfi1_delete_x
, "delete!", 2, 1, 0,
247 (SCM x
, SCM lst
, SCM pred
),
248 "Return a list containing the elements of @var{lst} but with\n"
249 "those equal to @var{x} deleted. The returned elements will be\n"
250 "in the same order as they were in @var{lst}.\n"
252 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
253 "given. An equality call is made just once for each element,\n"
254 "but the order in which the calls are made on the elements is\n"
257 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
258 "given @var{x} is first. This means for instance elements\n"
259 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
261 "@var{lst} may be modified to construct the returned list.")
262 #define FUNC_NAME s_scm_srfi1_delete_x
264 scm_t_trampoline_2 equal_p
;
268 if (SCM_UNBNDP (pred
))
269 return scm_delete_x (x
, lst
);
271 equal_p
= scm_trampoline_2 (pred
);
272 SCM_ASSERT (equal_p
, pred
, SCM_ARG3
, FUNC_NAME
);
274 for (prev
= &lst
, walk
= lst
;
276 walk
= SCM_CDR (walk
))
278 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (walk
))))
279 *prev
= SCM_CDR (walk
);
281 prev
= SCM_CDRLOC (walk
);
284 /* demand the input was a proper list */
285 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk
), walk
, SCM_ARG2
, FUNC_NAME
,"list");
291 SCM_DEFINE (scm_srfi1_delete_duplicates
, "delete-duplicates", 1, 1, 0,
293 "Return a list containing the elements of @var{lst} but without\n"
296 "When elements are equal, only the first in @var{lst} is\n"
297 "retained. Equal elements can be anywhere in @var{lst}, they\n"
298 "don't have to be adjacent. The returned list will have the\n"
299 "retained elements in the same order as they were in @var{lst}.\n"
301 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
302 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
303 "being before @var{y} in @var{lst}. A call is made at most once\n"
304 "for each combination, but the sequence of the calls across the\n"
305 "elements is unspecified.\n"
307 "@var{lst} is not modified, but the return might share a common\n"
308 "tail with @var{lst}.\n"
310 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
311 "it must check each element against all those preceding it. For\n"
312 "long lists it is more efficient to sort and then compare only\n"
313 "adjacent elements.")
314 #define FUNC_NAME s_scm_srfi1_delete_duplicates
316 scm_t_trampoline_2 equal_p
;
317 SCM ret
, *p
, keeplst
, item
, l
;
319 /* ret is the new list constructed. p is where to append, initially &ret
320 then SCM_CDRLOC of the last pair. lst is advanced as each element is
323 Elements retained are not immediately appended to ret, instead keeplst
324 is the last pair in lst which is to be kept but is not yet copied.
325 Initially this is the first pair of lst, since the first element is
328 *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
329 the elements retained, making the equality search loop easy.
331 If an item must be deleted, elements from keeplst (inclusive) to lst
332 (exclusive) must be copied and appended to ret. When there's no more
333 deletions, *p is left set to keeplst, so ret shares structure with the
334 original lst. (ret will be the entire original lst if there are no
337 /* skip to end if an empty list (or something invalid) */
339 if (scm_is_pair (lst
))
341 if (SCM_UNBNDP (pred
))
342 equal_p
= equal_trampoline
;
345 equal_p
= scm_trampoline_2 (pred
);
346 SCM_ASSERT (equal_p
, pred
, SCM_ARG2
, FUNC_NAME
);
352 /* loop over lst elements starting from second */
356 if (! scm_is_pair (lst
))
358 item
= SCM_CAR (lst
);
360 /* loop searching ret upto lst */
361 for (l
= ret
; ! scm_is_eq (l
, lst
); l
= SCM_CDR (l
))
363 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
365 /* duplicate, don't want this element, so copy keeplst
366 (inclusive) to lst (exclusive) onto ret */
367 while (! scm_is_eq (keeplst
, lst
))
369 SCM c
= scm_cons (SCM_CAR (keeplst
), SCM_EOL
);
372 keeplst
= SCM_CDR (keeplst
);
375 keeplst
= SCM_CDR (lst
); /* elem after the one deleted */
383 /* demand that lst was a proper list */
384 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
391 SCM_DEFINE (scm_srfi1_delete_duplicates_x
, "delete-duplicates!", 1, 1, 0,
393 "Return a list containing the elements of @var{lst} but without\n"
396 "When elements are equal, only the first in @var{lst} is\n"
397 "retained. Equal elements can be anywhere in @var{lst}, they\n"
398 "don't have to be adjacent. The returned list will have the\n"
399 "retained elements in the same order as they were in @var{lst}.\n"
401 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
402 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
403 "being before @var{y} in @var{lst}. A call is made at most once\n"
404 "for each combination, but the sequence of the calls across the\n"
405 "elements is unspecified.\n"
407 "@var{lst} may be modified to construct the returned list.\n"
409 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
410 "it must check each element against all those preceding it. For\n"
411 "long lists it is more efficient to sort and then compare only\n"
412 "adjacent elements.")
413 #define FUNC_NAME s_scm_srfi1_delete_duplicates_x
415 scm_t_trampoline_2 equal_p
;
416 SCM ret
, endret
, item
, l
;
418 /* ret is the return list, constructed from the pairs in lst. endret is
419 the last pair of ret, initially the first pair. lst is advanced as
420 elements are considered. */
422 /* skip to end if an empty list (or something invalid) */
424 if (scm_is_pair (lst
))
426 if (SCM_UNBNDP (pred
))
427 equal_p
= equal_trampoline
;
430 equal_p
= scm_trampoline_2 (pred
);
431 SCM_ASSERT (equal_p
, pred
, SCM_ARG2
, FUNC_NAME
);
436 /* loop over lst elements starting from second */
440 if (! scm_is_pair (lst
))
442 item
= SCM_CAR (lst
);
444 /* is item equal to any element from ret to endret (inclusive)? */
448 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
449 break; /* equal, forget this element */
451 if (scm_is_eq (l
, endret
))
453 /* not equal to any, so append this pair */
454 SCM_SETCDR (endret
, lst
);
462 /* terminate, in case last element was deleted */
463 SCM_SETCDR (endret
, SCM_EOL
);
466 /* demand that lst was a proper list */
467 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
474 SCM_DEFINE (scm_srfi1_drop_right
, "drop-right", 2, 0, 0,
476 "Return a new list containing all except the last @var{n}\n"
477 "elements of @var{lst}.")
478 #define FUNC_NAME s_scm_srfi1_drop_right
480 SCM tail
= scm_list_tail (lst
, n
);
483 while (scm_is_pair (tail
))
485 *rend
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
486 rend
= SCM_CDRLOC (*rend
);
489 tail
= SCM_CDR (tail
);
491 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
497 SCM_DEFINE (scm_srfi1_filter_map
, "filter-map", 2, 0, 1,
498 (SCM proc
, SCM list1
, SCM rest
),
499 "Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
500 "return a list of the results as per SRFI-1 @code{map}, except\n"
501 "that any @code{#f} results are omitted from the list returned.")
502 #define FUNC_NAME s_scm_srfi1_filter_map
504 SCM ret
, *loc
, elem
, newcell
, lst
;
507 SCM_VALIDATE_REST_ARGUMENT (rest
);
512 if (SCM_NULLP (rest
))
515 scm_t_trampoline_1 proc_tramp
= scm_trampoline_1 (proc
);
516 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
518 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
520 elem
= proc_tramp (proc
, SCM_CAR (list1
));
521 if (scm_is_true (elem
))
523 newcell
= scm_cons (elem
, SCM_EOL
);
525 loc
= SCM_CDRLOC (newcell
);
529 /* check below that list1 is a proper list, and done */
533 else if (SCM_NULLP (SCM_CDR (rest
)))
536 scm_t_trampoline_2 proc_tramp
= scm_trampoline_2 (proc
);
537 SCM list2
= SCM_CAR (rest
);
538 SCM_ASSERT (proc_tramp
, proc
, SCM_ARG1
, FUNC_NAME
);
542 if (! scm_is_pair (list1
))
546 goto check_lst_and_done
;
548 if (! scm_is_pair (list2
))
552 goto check_lst_and_done
;
554 elem
= proc_tramp (proc
, SCM_CAR (list1
), SCM_CAR (list2
));
555 if (scm_is_true (elem
))
557 newcell
= scm_cons (elem
, SCM_EOL
);
559 loc
= SCM_CDRLOC (newcell
);
561 list1
= SCM_CDR (list1
);
562 list2
= SCM_CDR (list2
);
567 /* three or more lists */
568 SCM lstlst
, args
, l
, a
;
570 /* lstlst is a list of the list arguments */
571 lstlst
= scm_cons (list1
, rest
);
573 /* args is the argument list to pass to proc, same length as lstlst,
574 re-used for each call */
575 args
= scm_list_copy (lstlst
);
579 /* first elem of each list in lstlst into args, and step those
580 lstlst entries onto their next element */
581 for (l
= lstlst
, a
= args
, argnum
= 2;
583 l
= SCM_CDR (l
), a
= SCM_CDR (a
), argnum
++)
585 lst
= SCM_CAR (l
); /* list argument */
586 if (! scm_is_pair (lst
))
587 goto check_lst_and_done
;
588 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for proc */
589 SCM_SETCAR (l
, SCM_CDR (lst
)); /* keep rest of lst */
592 elem
= scm_apply (proc
, args
, SCM_EOL
);
593 if (scm_is_true (elem
))
595 newcell
= scm_cons (elem
, SCM_EOL
);
597 loc
= SCM_CDRLOC (newcell
);
603 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
609 SCM_DEFINE (scm_srfi1_find
, "find", 2, 0, 0,
611 "Return the first element of @var{lst} which satisfies the\n"
612 "predicate @var{pred}, or return @code{#f} if no such element is\n"
614 #define FUNC_NAME s_scm_srfi1_find
616 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (pred
);
617 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
619 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
621 SCM elem
= SCM_CAR (lst
);
622 if (scm_is_true (pred_tramp (pred
, elem
)))
625 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
632 SCM_DEFINE (scm_srfi1_find_tail
, "find-tail", 2, 0, 0,
634 "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
635 "predicate @var{pred}, or return @code{#f} if no such element is\n"
637 #define FUNC_NAME s_scm_srfi1_find_tail
639 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (pred
);
640 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
642 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
643 if (scm_is_true (pred_tramp (pred
, SCM_CAR (lst
))))
645 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
652 SCM_DEFINE (scm_srfi1_length_plus
, "length+", 1, 0, 0,
654 "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
656 #define FUNC_NAME s_scm_srfi1_length_plus
658 long len
= scm_ilength (lst
);
659 return (len
>= 0 ? SCM_I_MAKINUM (len
) : SCM_BOOL_F
);
664 /* This routine differs from the core list-copy in allowing improper lists.
665 Maybe the core could allow them similarly. */
667 SCM_DEFINE (scm_srfi1_list_copy
, "list-copy", 1, 0, 0,
669 "Return a copy of the given list @var{lst}.\n"
671 "@var{lst} can be a proper or improper list. And if @var{lst}\n"
672 "is not a pair then it's treated as the final tail of an\n"
673 "improper list and simply returned.")
674 #define FUNC_NAME s_scm_srfi1_list_copy
684 while (scm_is_pair (from_here
))
687 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
689 fill_here
= SCM_CDRLOC (c
);
690 from_here
= SCM_CDR (from_here
);
697 /* Typechecking for multi-argument MAP and FOR-EACH.
699 Verify that each element of the vector ARGV, except for the first,
700 is a list and return minimum length. Attribute errors to WHO,
701 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
703 check_map_args (SCM argv
,
712 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
714 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
717 if (!(scm_is_null (elt
) || scm_is_pair (elt
)))
721 scm_apply_generic (gf
, scm_cons (proc
, args
));
723 scm_wrong_type_arg (who
, i
+ 2, elt
);
726 elt_len
= srfi1_ilength (elt
);
728 goto check_map_error
;
730 if (len
< 0 || (elt_len
>= 0 && elt_len
< len
))
735 goto check_map_error
;
737 scm_remember_upto_here_1 (argv
);
742 SCM_GPROC (s_srfi1_map
, "map", 2, 0, 1, scm_srfi1_map
, g_srfi1_map
);
744 /* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
745 sequentially, starting with the first element(s). This is used in
746 the Scheme procedure `map-in-order', which guarantees sequential
747 behaviour, is implemented using scm_map. If the behaviour changes,
748 we need to update `map-in-order'.
752 scm_srfi1_map (SCM proc
, SCM arg1
, SCM args
)
753 #define FUNC_NAME s_srfi1_map
759 len
= srfi1_ilength (arg1
);
760 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
762 scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_srfi1_map
);
763 SCM_VALIDATE_REST_ARGUMENT (args
);
764 if (scm_is_null (args
))
766 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
767 SCM_GASSERT2 (call
, g_srfi1_map
, proc
, arg1
, SCM_ARG1
, s_srfi1_map
);
768 SCM_GASSERT2 (len
>= 0, g_srfi1_map
, proc
, arg1
, SCM_ARG2
, s_srfi1_map
);
769 while (SCM_NIMP (arg1
))
771 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
772 pres
= SCM_CDRLOC (*pres
);
773 arg1
= SCM_CDR (arg1
);
777 if (scm_is_null (SCM_CDR (args
)))
779 SCM arg2
= SCM_CAR (args
);
780 int len2
= srfi1_ilength (arg2
);
781 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
782 SCM_GASSERTn (call
, g_srfi1_map
,
783 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_map
);
784 if (len
< 0 || (len2
>= 0 && len2
< len
))
786 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
787 && len
>= 0 && len2
>= -1,
789 scm_cons2 (proc
, arg1
, args
),
790 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
794 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
795 pres
= SCM_CDRLOC (*pres
);
796 arg1
= SCM_CDR (arg1
);
797 arg2
= SCM_CDR (arg2
);
802 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
803 len
= check_map_args (args
, len
, g_srfi1_map
, proc
, arg1
, s_srfi1_map
);
807 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
809 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
810 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
811 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
813 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
814 pres
= SCM_CDRLOC (*pres
);
821 SCM_REGISTER_PROC (s_srfi1_map_in_order
, "map-in-order", 2, 0, 1, scm_srfi1_map
);
823 SCM_GPROC (s_srfi1_for_each
, "for-each", 2, 0, 1, scm_srfi1_for_each
, g_srfi1_for_each
);
826 scm_srfi1_for_each (SCM proc
, SCM arg1
, SCM args
)
827 #define FUNC_NAME s_srfi1_for_each
830 len
= srfi1_ilength (arg1
);
831 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
832 g_srfi1_for_each
, scm_cons2 (proc
, arg1
, args
),
833 SCM_ARG2
, s_srfi1_for_each
);
834 SCM_VALIDATE_REST_ARGUMENT (args
);
835 if (scm_is_null (args
))
837 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
838 SCM_GASSERT2 (call
, g_srfi1_for_each
, proc
, arg1
,
839 SCM_ARG1
, s_srfi1_for_each
);
840 SCM_GASSERT2 (len
>= 0, g_srfi1_for_each
, proc
, arg1
,
841 SCM_ARG2
, s_srfi1_map
);
842 while (SCM_NIMP (arg1
))
844 call (proc
, SCM_CAR (arg1
));
845 arg1
= SCM_CDR (arg1
);
847 return SCM_UNSPECIFIED
;
849 if (scm_is_null (SCM_CDR (args
)))
851 SCM arg2
= SCM_CAR (args
);
852 int len2
= srfi1_ilength (arg2
);
853 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
854 SCM_GASSERTn (call
, g_srfi1_for_each
,
855 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_for_each
);
856 if (len
< 0 || (len2
>= 0 && len2
< len
))
858 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
859 && len
>= 0 && len2
>= -1,
861 scm_cons2 (proc
, arg1
, args
),
862 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
866 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
867 arg1
= SCM_CDR (arg1
);
868 arg2
= SCM_CDR (arg2
);
871 return SCM_UNSPECIFIED
;
873 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
874 len
= check_map_args (args
, len
, g_srfi1_for_each
, proc
, arg1
,
879 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
881 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
882 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
883 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
885 scm_apply (proc
, arg1
, SCM_EOL
);
888 return SCM_UNSPECIFIED
;
893 SCM_DEFINE (scm_srfi1_member
, "member", 2, 1, 0,
894 (SCM x
, SCM lst
, SCM pred
),
895 "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
896 "to @var{x}. If @var{x} does not appear in @var{lst}, return\n"
899 "Equality is determined by @code{equal?}, or by the equality\n"
900 "predicate @var{=} if given. @var{=} is called @code{(= @var{x}\n"
901 "elem)}, ie.@: with the given @var{x} first, so for example to\n"
902 "find the first element greater than 5,\n"
905 "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
908 "This version of @code{member} extends the core @code{member} by\n"
909 "accepting an equality predicate.")
910 #define FUNC_NAME s_scm_srfi1_member
912 scm_t_trampoline_2 equal_p
;
913 SCM_VALIDATE_LIST (2, lst
);
914 if (SCM_UNBNDP (pred
))
915 equal_p
= equal_trampoline
;
918 equal_p
= scm_trampoline_2 (pred
);
919 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
921 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
923 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
930 SCM_DEFINE (scm_srfi1_assoc
, "assoc", 2, 1, 0,
931 (SCM key
, SCM alist
, SCM pred
),
932 "Behaves like @code{assq} but uses third argument @var{pred?}\n"
933 "for key comparison. If @var{pred?} is not supplied,\n"
934 "@code{equal?} is used. (Extended from R5RS.)\n")
935 #define FUNC_NAME s_scm_srfi1_assoc
938 scm_t_trampoline_2 equal_p
;
939 if (SCM_UNBNDP (pred
))
940 equal_p
= equal_trampoline
;
943 equal_p
= scm_trampoline_2 (pred
);
944 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
946 for(; scm_is_pair (ls
); ls
= SCM_CDR (ls
))
948 SCM tmp
= SCM_CAR (ls
);
949 SCM_ASSERT_TYPE (scm_is_pair (tmp
), alist
, SCM_ARG2
, FUNC_NAME
,
951 if (scm_is_true (equal_p (pred
, SCM_CAR (tmp
), key
)))
954 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls
), alist
, SCM_ARG2
, FUNC_NAME
,
960 SCM_DEFINE (scm_srfi1_partition
, "partition", 2, 0, 0,
961 (SCM pred
, SCM list
),
962 "Partition the elements of @var{list} with predicate @var{pred}.\n"
963 "Return two values: the list of elements satifying @var{pred} and\n"
964 "the list of elements @emph{not} satisfying @var{pred}. The order\n"
965 "of the output lists follows the order of @var{list}. @var{list}\n"
966 "is not mutated. One of the output lists may share memory with @var{list}.\n")
967 #define FUNC_NAME s_scm_srfi1_partition
969 /* In this implementation, the output lists don't share memory with
970 list, because it's probably not worth the effort. */
971 scm_t_trampoline_1 call
= scm_trampoline_1(pred
);
972 SCM kept
= scm_cons(SCM_EOL
, SCM_EOL
);
973 SCM kept_tail
= kept
;
974 SCM dropped
= scm_cons(SCM_EOL
, SCM_EOL
);
975 SCM dropped_tail
= dropped
;
977 SCM_ASSERT(call
, pred
, 2, FUNC_NAME
);
979 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR(list
)) {
980 SCM elt
= SCM_CAR(list
);
981 SCM new_tail
= scm_cons(SCM_CAR(list
), SCM_EOL
);
982 if (scm_is_true (call (pred
, elt
))) {
983 SCM_SETCDR(kept_tail
, new_tail
);
984 kept_tail
= new_tail
;
987 SCM_SETCDR(dropped_tail
, new_tail
);
988 dropped_tail
= new_tail
;
991 /* re-use the initial conses for the values list */
992 SCM_SETCAR(kept
, SCM_CDR(kept
));
993 SCM_SETCDR(kept
, dropped
);
994 SCM_SETCAR(dropped
, SCM_CDR(dropped
));
995 SCM_SETCDR(dropped
, SCM_EOL
);
996 return scm_values(kept
);
1001 SCM_DEFINE (scm_srfi1_partition_x
, "partition!", 2, 0, 0,
1002 (SCM pred
, SCM lst
),
1003 "Split @var{lst} into those elements which do and don't satisfy\n"
1004 "the predicate @var{pred}.\n"
1006 "The return is two values (@pxref{Multiple Values}), the first\n"
1007 "being a list of all elements from @var{lst} which satisfy\n"
1008 "@var{pred}, the second a list of those which do not.\n"
1010 "The elements in the result lists are in the same order as in\n"
1011 "@var{lst} but the order in which the calls @code{(@var{pred}\n"
1012 "elem)} are made on the list elements is unspecified.\n"
1014 "@var{lst} may be modified to construct the return lists.")
1015 #define FUNC_NAME s_scm_srfi1_partition_x
1017 SCM tlst
, flst
, *tp
, *fp
;
1018 scm_t_trampoline_1 pred_tramp
;
1020 pred_tramp
= scm_trampoline_1 (pred
);
1021 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
1023 /* tlst and flst are the lists of true and false elements. tp and fp are
1024 where to store to append to them, initially &tlst and &flst, then
1025 SCM_CDRLOC of the last pair in the respective lists. */
1032 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1034 if (scm_is_true (pred_tramp (pred
, SCM_CAR (lst
))))
1037 tp
= SCM_CDRLOC (lst
);
1042 fp
= SCM_CDRLOC (lst
);
1046 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1048 /* terminate whichever didn't get the last element(s) */
1052 return scm_values (scm_list_2 (tlst
, flst
));
1057 SCM_DEFINE (scm_srfi1_remove
, "remove", 2, 0, 0,
1058 (SCM pred
, SCM list
),
1059 "Return a list containing all elements from @var{lst} which do\n"
1060 "not satisfy the predicate @var{pred}. The elements in the\n"
1061 "result list have the same order as in @var{lst}. The order in\n"
1062 "which @var{pred} is applied to the list elements is not\n"
1064 #define FUNC_NAME s_scm_srfi1_remove
1066 scm_t_trampoline_1 call
= scm_trampoline_1 (pred
);
1070 SCM_ASSERT (call
, pred
, 1, FUNC_NAME
);
1071 SCM_VALIDATE_LIST (2, list
);
1073 for (prev
= &res
, walk
= list
;
1075 walk
= SCM_CDR (walk
))
1077 if (scm_is_false (call (pred
, SCM_CAR (walk
))))
1079 *prev
= scm_cons (SCM_CAR (walk
), SCM_EOL
);
1080 prev
= SCM_CDRLOC (*prev
);
1089 SCM_DEFINE (scm_srfi1_remove_x
, "remove!", 2, 0, 0,
1090 (SCM pred
, SCM list
),
1091 "Return a list containing all elements from @var{list} which do\n"
1092 "not satisfy the predicate @var{pred}. The elements in the\n"
1093 "result list have the same order as in @var{list}. The order in\n"
1094 "which @var{pred} is applied to the list elements is not\n"
1095 "specified. @var{list} may be modified to build the return\n"
1097 #define FUNC_NAME s_scm_srfi1_remove_x
1099 scm_t_trampoline_1 call
= scm_trampoline_1 (pred
);
1102 SCM_ASSERT (call
, pred
, 1, FUNC_NAME
);
1103 SCM_VALIDATE_LIST (2, list
);
1105 for (prev
= &list
, walk
= list
;
1107 walk
= SCM_CDR (walk
))
1109 if (scm_is_false (call (pred
, SCM_CAR (walk
))))
1110 prev
= SCM_CDRLOC (walk
);
1112 *prev
= SCM_CDR (walk
);
1120 SCM_DEFINE (scm_srfi1_split_at
, "split-at", 2, 0, 0,
1122 "Return two values (multiple values), being a list of the\n"
1123 "elements before index @var{n} in @var{lst}, and a list of those\n"
1125 #define FUNC_NAME s_scm_srfi1_split_at
1128 /* pre is a list of elements before the i split point, loc is the CDRLOC
1129 of the last cell, ie. where to store to append to it */
1133 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1135 SCM_VALIDATE_CONS (SCM_ARG1
, lst
);
1137 *loc
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
1138 loc
= SCM_CDRLOC (*loc
);
1141 return scm_values (scm_list_2 (pre
, lst
));
1146 SCM_DEFINE (scm_srfi1_split_at_x
, "split-at!", 2, 0, 0,
1148 "Return two values (multiple values), being a list of the\n"
1149 "elements before index @var{n} in @var{lst}, and a list of those\n"
1150 "after. @var{lst} is modified to form those values.")
1151 #define FUNC_NAME s_scm_srfi1_split_at
1157 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1159 SCM_VALIDATE_CONS (SCM_ARG1
, upto
);
1161 loc
= SCM_CDRLOC (upto
);
1162 upto
= SCM_CDR (upto
);
1166 return scm_values (scm_list_2 (lst
, upto
));
1171 SCM_DEFINE (scm_srfi1_take_right
, "take-right", 2, 0, 0,
1173 "Return the a list containing the @var{n} last elements of\n"
1175 #define FUNC_NAME s_scm_srfi1_take_right
1177 SCM tail
= scm_list_tail (lst
, n
);
1178 while (scm_is_pair (tail
))
1180 lst
= SCM_CDR (lst
);
1181 tail
= SCM_CDR (tail
);
1183 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
1190 scm_init_srfi_1 (void)
1192 SCM the_root_module
= scm_lookup_closure_module (SCM_BOOL_F
);
1193 #ifndef SCM_MAGIC_SNARFER
1194 #include "srfi/srfi-1.x"
1196 scm_c_extend_primitive_generic
1197 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "map")),
1198 SCM_VARIABLE_REF (scm_c_lookup ("map")));
1199 scm_c_extend_primitive_generic
1200 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "for-each")),
1201 SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
1204 /* End of srfi-1.c. */