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
90 SCM_VALIDATE_REST_ARGUMENT (rest
);
94 if (scm_is_null (rest
))
97 scm_t_trampoline_1 pred_tramp
;
98 pred_tramp
= scm_trampoline_1 (pred
);
99 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
101 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
102 count
+= scm_is_true (pred_tramp (pred
, SCM_CAR (list1
)));
105 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (list1
), list1
, SCM_ARG2
, FUNC_NAME
,
108 else if (scm_is_pair (rest
) && scm_is_null (SCM_CDR (rest
)))
111 scm_t_trampoline_2 pred_tramp
;
114 pred_tramp
= scm_trampoline_2 (pred
);
115 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
117 list2
= SCM_CAR (rest
);
120 if (! scm_is_pair (list1
))
122 if (! scm_is_pair (list2
))
124 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (list2
), list2
, SCM_ARG3
,
128 count
+= scm_is_true (pred_tramp
129 (pred
, SCM_CAR (list1
), SCM_CAR (list2
)));
130 list1
= SCM_CDR (list1
);
131 list2
= SCM_CDR (list2
);
136 /* three or more lists */
137 SCM lstlst
, args
, l
, a
, lst
;
140 /* lstlst is a list of the list arguments */
141 lstlst
= scm_cons (list1
, rest
);
143 /* args is the argument list to pass to pred, same length as lstlst,
144 re-used for each call */
146 for (l
= lstlst
; scm_is_pair (l
); l
= SCM_CDR (l
))
147 args
= scm_cons (SCM_BOOL_F
, args
);
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
))
160 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
,
161 argnum
, FUNC_NAME
, "list");
164 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for pred */
165 SCM_SETCAR (l
, SCM_CDR (lst
)); /* keep rest of lst */
168 count
+= scm_is_true (scm_apply (pred
, args
, SCM_EOL
));
172 return scm_from_long (count
);
177 SCM_DEFINE (scm_srfi1_delete
, "delete", 2, 1, 0,
178 (SCM x
, SCM lst
, SCM pred
),
179 "Return a list containing the elements of @var{lst} but with\n"
180 "those equal to @var{x} deleted. The returned elements will be\n"
181 "in the same order as they were in @var{lst}.\n"
183 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
184 "given. An equality call is made just once for each element,\n"
185 "but the order in which the calls are made on the elements is\n"
188 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
189 "given @var{x} is first. This means for instance elements\n"
190 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
192 "@var{lst} is not modified, but the returned list might share a\n"
193 "common tail with @var{lst}.")
194 #define FUNC_NAME s_scm_srfi1_delete
196 scm_t_trampoline_2 equal_p
;
197 SCM ret
, *p
, keeplst
;
199 if (SCM_UNBNDP (pred
))
200 return scm_delete (x
, lst
);
202 equal_p
= scm_trampoline_2 (pred
);
203 SCM_ASSERT (equal_p
, pred
, SCM_ARG3
, FUNC_NAME
);
205 /* ret is the return list being constructed. p is where to append to it,
206 initially &ret then SCM_CDRLOC of the last pair. lst progresses as
207 elements are considered.
209 Elements to be retained are not immediately copied, instead keeplst is
210 the last pair in lst which is to be retained but not yet copied. When
211 there's no more deletions, *p can be set to keeplst to share the
212 remainder of the original lst. (The entire original lst if there's no
213 deletions at all.) */
219 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
221 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
223 /* delete this element, so copy from keeplst (inclusive) to lst
224 (exclusive) onto ret */
225 while (! scm_is_eq (keeplst
, lst
))
227 SCM c
= scm_cons (SCM_CAR (keeplst
), SCM_EOL
);
230 keeplst
= SCM_CDR (keeplst
);
233 keeplst
= SCM_CDR (lst
);
237 /* final retained elements */
240 /* demand that lst was a proper list */
241 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
248 SCM_DEFINE (scm_srfi1_delete_x
, "delete!", 2, 1, 0,
249 (SCM x
, SCM lst
, SCM pred
),
250 "Return a list containing the elements of @var{lst} but with\n"
251 "those equal to @var{x} deleted. The returned elements will be\n"
252 "in the same order as they were in @var{lst}.\n"
254 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
255 "given. An equality call is made just once for each element,\n"
256 "but the order in which the calls are made on the elements is\n"
259 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
260 "given @var{x} is first. This means for instance elements\n"
261 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
263 "@var{lst} may be modified to construct the returned list.")
264 #define FUNC_NAME s_scm_srfi1_delete_x
266 scm_t_trampoline_2 equal_p
;
270 if (SCM_UNBNDP (pred
))
271 return scm_delete_x (x
, lst
);
273 equal_p
= scm_trampoline_2 (pred
);
274 SCM_ASSERT (equal_p
, pred
, SCM_ARG3
, FUNC_NAME
);
276 for (prev
= &lst
, walk
= lst
;
278 walk
= SCM_CDR (walk
))
280 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (walk
))))
281 *prev
= SCM_CDR (walk
);
283 prev
= SCM_CDRLOC (walk
);
286 /* demand the input was a proper list */
287 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk
), walk
, SCM_ARG2
, FUNC_NAME
,"list");
293 SCM_DEFINE (scm_srfi1_delete_duplicates
, "delete-duplicates", 1, 1, 0,
295 "Return a list containing the elements of @var{lst} but without\n"
298 "When elements are equal, only the first in @var{lst} is\n"
299 "retained. Equal elements can be anywhere in @var{lst}, they\n"
300 "don't have to be adjacent. The returned list will have the\n"
301 "retained elements in the same order as they were in @var{lst}.\n"
303 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
304 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
305 "being before @var{y} in @var{lst}. A call is made at most once\n"
306 "for each combination, but the sequence of the calls across the\n"
307 "elements is unspecified.\n"
309 "@var{lst} is not modified, but the return might share a common\n"
310 "tail with @var{lst}.\n"
312 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
313 "it must check each element against all those preceding it. For\n"
314 "long lists it is more efficient to sort and then compare only\n"
315 "adjacent elements.")
316 #define FUNC_NAME s_scm_srfi1_delete_duplicates
318 scm_t_trampoline_2 equal_p
;
319 SCM ret
, *p
, keeplst
, item
, l
;
321 /* ret is the new list constructed. p is where to append, initially &ret
322 then SCM_CDRLOC of the last pair. lst is advanced as each element is
325 Elements retained are not immediately appended to ret, instead keeplst
326 is the last pair in lst which is to be kept but is not yet copied.
327 Initially this is the first pair of lst, since the first element is
330 *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
331 the elements retained, making the equality search loop easy.
333 If an item must be deleted, elements from keeplst (inclusive) to lst
334 (exclusive) must be copied and appended to ret. When there's no more
335 deletions, *p is left set to keeplst, so ret shares structure with the
336 original lst. (ret will be the entire original lst if there are no
339 /* skip to end if an empty list (or something invalid) */
341 if (scm_is_pair (lst
))
343 if (SCM_UNBNDP (pred
))
344 equal_p
= equal_trampoline
;
347 equal_p
= scm_trampoline_2 (pred
);
348 SCM_ASSERT (equal_p
, pred
, SCM_ARG2
, FUNC_NAME
);
354 /* loop over lst elements starting from second */
358 if (! scm_is_pair (lst
))
360 item
= SCM_CAR (lst
);
362 /* loop searching ret upto lst */
363 for (l
= ret
; ! scm_is_eq (l
, lst
); l
= SCM_CDR (l
))
365 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
367 /* duplicate, don't want this element, so copy keeplst
368 (inclusive) to lst (exclusive) onto ret */
369 while (! scm_is_eq (keeplst
, lst
))
371 SCM c
= scm_cons (SCM_CAR (keeplst
), SCM_EOL
);
374 keeplst
= SCM_CDR (keeplst
);
377 keeplst
= SCM_CDR (lst
); /* elem after the one deleted */
385 /* demand that lst was a proper list */
386 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
393 SCM_DEFINE (scm_srfi1_delete_duplicates_x
, "delete-duplicates!", 1, 1, 0,
395 "Return a list containing the elements of @var{lst} but without\n"
398 "When elements are equal, only the first in @var{lst} is\n"
399 "retained. Equal elements can be anywhere in @var{lst}, they\n"
400 "don't have to be adjacent. The returned list will have the\n"
401 "retained elements in the same order as they were in @var{lst}.\n"
403 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
404 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
405 "being before @var{y} in @var{lst}. A call is made at most once\n"
406 "for each combination, but the sequence of the calls across the\n"
407 "elements is unspecified.\n"
409 "@var{lst} may be modified to construct the returned list.\n"
411 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
412 "it must check each element against all those preceding it. For\n"
413 "long lists it is more efficient to sort and then compare only\n"
414 "adjacent elements.")
415 #define FUNC_NAME s_scm_srfi1_delete_duplicates_x
417 scm_t_trampoline_2 equal_p
;
418 SCM ret
, endret
, item
, l
;
420 /* ret is the return list, constructed from the pairs in lst. endret is
421 the last pair of ret, initially the first pair. lst is advanced as
422 elements are considered. */
424 /* skip to end if an empty list (or something invalid) */
426 if (scm_is_pair (lst
))
428 if (SCM_UNBNDP (pred
))
429 equal_p
= equal_trampoline
;
432 equal_p
= scm_trampoline_2 (pred
);
433 SCM_ASSERT (equal_p
, pred
, SCM_ARG2
, FUNC_NAME
);
438 /* loop over lst elements starting from second */
442 if (! scm_is_pair (lst
))
444 item
= SCM_CAR (lst
);
446 /* is item equal to any element from ret to endret (inclusive)? */
450 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
451 break; /* equal, forget this element */
453 if (scm_is_eq (l
, endret
))
455 /* not equal to any, so append this pair */
456 SCM_SETCDR (endret
, lst
);
464 /* terminate, in case last element was deleted */
465 SCM_SETCDR (endret
, SCM_EOL
);
468 /* demand that lst was a proper list */
469 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
476 SCM_DEFINE (scm_srfi1_drop_right
, "drop-right", 2, 0, 0,
478 "Return a new list containing all except the last @var{n}\n"
479 "elements of @var{lst}.")
480 #define FUNC_NAME s_scm_srfi1_drop_right
482 SCM tail
= scm_list_tail (lst
, n
);
485 while (scm_is_pair (tail
))
487 *rend
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
488 rend
= SCM_CDRLOC (*rend
);
491 tail
= SCM_CDR (tail
);
493 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
499 SCM_DEFINE (scm_srfi1_find
, "find", 2, 0, 0,
501 "Return the first element of @var{lst} which satisfies the\n"
502 "predicate @var{pred}, or return @code{#f} if no such element is\n"
504 #define FUNC_NAME s_scm_srfi1_find
506 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (pred
);
507 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
509 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
511 SCM elem
= SCM_CAR (lst
);
512 if (scm_is_true (pred_tramp (pred
, elem
)))
515 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
522 SCM_DEFINE (scm_srfi1_find_tail
, "find-tail", 2, 0, 0,
524 "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
525 "predicate @var{pred}, or return @code{#f} if no such element is\n"
527 #define FUNC_NAME s_scm_srfi1_find_tail
529 scm_t_trampoline_1 pred_tramp
= scm_trampoline_1 (pred
);
530 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
532 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
533 if (scm_is_true (pred_tramp (pred
, SCM_CAR (lst
))))
535 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
542 SCM_DEFINE (scm_srfi1_length_plus
, "length+", 1, 0, 0,
544 "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
546 #define FUNC_NAME s_scm_srfi1_length_plus
548 long len
= scm_ilength (lst
);
549 return (len
>= 0 ? SCM_I_MAKINUM (len
) : SCM_BOOL_F
);
554 /* This routine differs from the core list-copy in allowing improper lists.
555 Maybe the core could allow them similarly. */
557 SCM_DEFINE (scm_srfi1_list_copy
, "list-copy", 1, 0, 0,
559 "Return a copy of the given list @var{lst}.\n"
561 "@var{lst} can be a proper or improper list. And if @var{lst}\n"
562 "is not a pair then it's treated as the final tail of an\n"
563 "improper list and simply returned.")
564 #define FUNC_NAME s_scm_srfi1_list_copy
574 while (scm_is_pair (from_here
))
577 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
579 fill_here
= SCM_CDRLOC (c
);
580 from_here
= SCM_CDR (from_here
);
587 /* Typechecking for multi-argument MAP and FOR-EACH.
589 Verify that each element of the vector ARGV, except for the first,
590 is a list and return minimum length. Attribute errors to WHO,
591 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
593 check_map_args (SCM argv
,
602 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
604 SCM elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
607 if (!(scm_is_null (elt
) || scm_is_pair (elt
)))
611 scm_apply_generic (gf
, scm_cons (proc
, args
));
613 scm_wrong_type_arg (who
, i
+ 2, elt
);
616 elt_len
= srfi1_ilength (elt
);
618 goto check_map_error
;
620 if (len
< 0 || (elt_len
>= 0 && elt_len
< len
))
625 goto check_map_error
;
627 scm_remember_upto_here_1 (argv
);
632 SCM_GPROC (s_srfi1_map
, "map", 2, 0, 1, scm_srfi1_map
, g_srfi1_map
);
634 /* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
635 sequentially, starting with the first element(s). This is used in
636 the Scheme procedure `map-in-order', which guarantees sequential
637 behaviour, is implemented using scm_map. If the behaviour changes,
638 we need to update `map-in-order'.
642 scm_srfi1_map (SCM proc
, SCM arg1
, SCM args
)
643 #define FUNC_NAME s_srfi1_map
649 len
= srfi1_ilength (arg1
);
650 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
652 scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_srfi1_map
);
653 SCM_VALIDATE_REST_ARGUMENT (args
);
654 if (scm_is_null (args
))
656 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
657 SCM_GASSERT2 (call
, g_srfi1_map
, proc
, arg1
, SCM_ARG1
, s_srfi1_map
);
658 SCM_GASSERT2 (len
>= 0, g_srfi1_map
, proc
, arg1
, SCM_ARG2
, s_srfi1_map
);
659 while (SCM_NIMP (arg1
))
661 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
662 pres
= SCM_CDRLOC (*pres
);
663 arg1
= SCM_CDR (arg1
);
667 if (scm_is_null (SCM_CDR (args
)))
669 SCM arg2
= SCM_CAR (args
);
670 int len2
= srfi1_ilength (arg2
);
671 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
672 SCM_GASSERTn (call
, g_srfi1_map
,
673 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_map
);
674 if (len
< 0 || (len2
>= 0 && len2
< len
))
676 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
677 && len
>= 0 && len2
>= -1,
679 scm_cons2 (proc
, arg1
, args
),
680 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
684 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
685 pres
= SCM_CDRLOC (*pres
);
686 arg1
= SCM_CDR (arg1
);
687 arg2
= SCM_CDR (arg2
);
692 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
693 len
= check_map_args (args
, len
, g_srfi1_map
, proc
, arg1
, s_srfi1_map
);
697 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
699 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
700 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
701 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
703 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
704 pres
= SCM_CDRLOC (*pres
);
711 SCM_REGISTER_PROC (s_srfi1_map_in_order
, "map-in-order", 2, 0, 1, scm_srfi1_map
);
713 SCM_GPROC (s_srfi1_for_each
, "for-each", 2, 0, 1, scm_srfi1_for_each
, g_srfi1_for_each
);
716 scm_srfi1_for_each (SCM proc
, SCM arg1
, SCM args
)
717 #define FUNC_NAME s_srfi1_for_each
720 len
= srfi1_ilength (arg1
);
721 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
722 g_srfi1_for_each
, scm_cons2 (proc
, arg1
, args
),
723 SCM_ARG2
, s_srfi1_for_each
);
724 SCM_VALIDATE_REST_ARGUMENT (args
);
725 if (scm_is_null (args
))
727 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
728 SCM_GASSERT2 (call
, g_srfi1_for_each
, proc
, arg1
,
729 SCM_ARG1
, s_srfi1_for_each
);
730 SCM_GASSERT2 (len
>= 0, g_srfi1_for_each
, proc
, arg1
,
731 SCM_ARG2
, s_srfi1_map
);
732 while (SCM_NIMP (arg1
))
734 call (proc
, SCM_CAR (arg1
));
735 arg1
= SCM_CDR (arg1
);
737 return SCM_UNSPECIFIED
;
739 if (scm_is_null (SCM_CDR (args
)))
741 SCM arg2
= SCM_CAR (args
);
742 int len2
= srfi1_ilength (arg2
);
743 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
744 SCM_GASSERTn (call
, g_srfi1_for_each
,
745 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_for_each
);
746 if (len
< 0 || (len2
>= 0 && len2
< len
))
748 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
749 && len
>= 0 && len2
>= -1,
751 scm_cons2 (proc
, arg1
, args
),
752 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
756 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
757 arg1
= SCM_CDR (arg1
);
758 arg2
= SCM_CDR (arg2
);
761 return SCM_UNSPECIFIED
;
763 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
764 len
= check_map_args (args
, len
, g_srfi1_for_each
, proc
, arg1
,
769 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
771 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
772 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
773 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
775 scm_apply (proc
, arg1
, SCM_EOL
);
778 return SCM_UNSPECIFIED
;
783 SCM_DEFINE (scm_srfi1_member
, "member", 2, 1, 0,
784 (SCM x
, SCM lst
, SCM pred
),
785 "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
786 "to @var{x}. If @var{x} does not appear in @var{lst}, return\n"
789 "Equality is determined by @code{equal?}, or by the equality\n"
790 "predicate @var{=} if given. @var{=} is called @code{(= @var{x}\n"
791 "elem)}, ie.@: with the given @var{x} first, so for example to\n"
792 "find the first element greater than 5,\n"
795 "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
798 "This version of @code{member} extends the core @code{member} by\n"
799 "accepting an equality predicate.")
800 #define FUNC_NAME s_scm_srfi1_member
802 scm_t_trampoline_2 equal_p
;
803 SCM_VALIDATE_LIST (2, lst
);
804 if (SCM_UNBNDP (pred
))
805 equal_p
= equal_trampoline
;
808 equal_p
= scm_trampoline_2 (pred
);
809 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
811 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
813 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
820 SCM_DEFINE (scm_srfi1_assoc
, "assoc", 2, 1, 0,
821 (SCM key
, SCM alist
, SCM pred
),
822 "Behaves like @code{assq} but uses third argument @var{pred?}\n"
823 "for key comparison. If @var{pred?} is not supplied,\n"
824 "@code{equal?} is used. (Extended from R5RS.)\n")
825 #define FUNC_NAME s_scm_srfi1_assoc
828 scm_t_trampoline_2 equal_p
;
829 if (SCM_UNBNDP (pred
))
830 equal_p
= equal_trampoline
;
833 equal_p
= scm_trampoline_2 (pred
);
834 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
836 for(; scm_is_pair (ls
); ls
= SCM_CDR (ls
))
838 SCM tmp
= SCM_CAR (ls
);
839 SCM_ASSERT_TYPE (scm_is_pair (tmp
), alist
, SCM_ARG2
, FUNC_NAME
,
841 if (scm_is_true (equal_p (pred
, SCM_CAR (tmp
), key
)))
844 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls
), alist
, SCM_ARG2
, FUNC_NAME
,
850 SCM_DEFINE (scm_srfi1_partition
, "partition", 2, 0, 0,
851 (SCM pred
, SCM list
),
852 "Partition the elements of @var{list} with predicate @var{pred}.\n"
853 "Return two values: the list of elements satifying @var{pred} and\n"
854 "the list of elements @emph{not} satisfying @var{pred}. The order\n"
855 "of the output lists follows the order of @var{list}. @var{list}\n"
856 "is not mutated. One of the output lists may share memory with @var{list}.\n")
857 #define FUNC_NAME s_scm_srfi1_partition
859 /* In this implementation, the output lists don't share memory with
860 list, because it's probably not worth the effort. */
861 scm_t_trampoline_1 call
= scm_trampoline_1(pred
);
862 SCM kept
= scm_cons(SCM_EOL
, SCM_EOL
);
863 SCM kept_tail
= kept
;
864 SCM dropped
= scm_cons(SCM_EOL
, SCM_EOL
);
865 SCM dropped_tail
= dropped
;
867 SCM_ASSERT(call
, pred
, 2, FUNC_NAME
);
869 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR(list
)) {
870 SCM elt
= SCM_CAR(list
);
871 SCM new_tail
= scm_cons(SCM_CAR(list
), SCM_EOL
);
872 if (scm_is_true (call (pred
, elt
))) {
873 SCM_SETCDR(kept_tail
, new_tail
);
874 kept_tail
= new_tail
;
877 SCM_SETCDR(dropped_tail
, new_tail
);
878 dropped_tail
= new_tail
;
881 /* re-use the initial conses for the values list */
882 SCM_SETCAR(kept
, SCM_CDR(kept
));
883 SCM_SETCDR(kept
, dropped
);
884 SCM_SETCAR(dropped
, SCM_CDR(dropped
));
885 SCM_SETCDR(dropped
, SCM_EOL
);
886 return scm_values(kept
);
891 SCM_DEFINE (scm_srfi1_partition_x
, "partition!", 2, 0, 0,
893 "Split @var{lst} into those elements which do and don't satisfy\n"
894 "the predicate @var{pred}.\n"
896 "The return is two values (@pxref{Multiple Values}), the first\n"
897 "being a list of all elements from @var{lst} which satisfy\n"
898 "@var{pred}, the second a list of those which do not.\n"
900 "The elements in the result lists are in the same order as in\n"
901 "@var{lst} but the order in which the calls @code{(@var{pred}\n"
902 "elem)} are made on the list elements is unspecified.\n"
904 "@var{lst} may be modified to construct the return lists.")
905 #define FUNC_NAME s_scm_srfi1_partition_x
907 SCM tlst
, flst
, *tp
, *fp
;
908 scm_t_trampoline_1 pred_tramp
;
910 pred_tramp
= scm_trampoline_1 (pred
);
911 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
913 /* tlst and flst are the lists of true and false elements. tp and fp are
914 where to store to append to them, initially &tlst and &flst, then
915 SCM_CDRLOC of the last pair in the respective lists. */
922 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
924 if (scm_is_true (pred_tramp (pred
, SCM_CAR (lst
))))
927 tp
= SCM_CDRLOC (lst
);
932 fp
= SCM_CDRLOC (lst
);
936 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
938 /* terminate whichever didn't get the last element(s) */
942 return scm_values (scm_list_2 (tlst
, flst
));
947 SCM_DEFINE (scm_srfi1_remove
, "remove", 2, 0, 0,
948 (SCM pred
, SCM list
),
949 "Return a list containing all elements from @var{lst} which do\n"
950 "not satisfy the predicate @var{pred}. The elements in the\n"
951 "result list have the same order as in @var{lst}. The order in\n"
952 "which @var{pred} is applied to the list elements is not\n"
954 #define FUNC_NAME s_scm_srfi1_remove
956 scm_t_trampoline_1 call
= scm_trampoline_1 (pred
);
960 SCM_ASSERT (call
, pred
, 1, FUNC_NAME
);
961 SCM_VALIDATE_LIST (2, list
);
963 for (prev
= &res
, walk
= list
;
965 walk
= SCM_CDR (walk
))
967 if (scm_is_false (call (pred
, SCM_CAR (walk
))))
969 *prev
= scm_cons (SCM_CAR (walk
), SCM_EOL
);
970 prev
= SCM_CDRLOC (*prev
);
979 SCM_DEFINE (scm_srfi1_remove_x
, "remove!", 2, 0, 0,
980 (SCM pred
, SCM list
),
981 "Return a list containing all elements from @var{list} which do\n"
982 "not satisfy the predicate @var{pred}. The elements in the\n"
983 "result list have the same order as in @var{list}. The order in\n"
984 "which @var{pred} is applied to the list elements is not\n"
985 "specified. @var{list} may be modified to build the return\n"
987 #define FUNC_NAME s_scm_srfi1_remove_x
989 scm_t_trampoline_1 call
= scm_trampoline_1 (pred
);
992 SCM_ASSERT (call
, pred
, 1, FUNC_NAME
);
993 SCM_VALIDATE_LIST (2, list
);
995 for (prev
= &list
, walk
= list
;
997 walk
= SCM_CDR (walk
))
999 if (scm_is_false (call (pred
, SCM_CAR (walk
))))
1000 prev
= SCM_CDRLOC (walk
);
1002 *prev
= SCM_CDR (walk
);
1010 SCM_DEFINE (scm_srfi1_split_at
, "split-at", 2, 0, 0,
1012 "Return two values (multiple values), being a list of the\n"
1013 "elements before index @var{n} in @var{lst}, and a list of those\n"
1015 #define FUNC_NAME s_scm_srfi1_split_at
1018 /* pre is a list of elements before the i split point, loc is the CDRLOC
1019 of the last cell, ie. where to store to append to it */
1023 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1025 SCM_VALIDATE_CONS (SCM_ARG1
, lst
);
1027 *loc
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
1028 loc
= SCM_CDRLOC (*loc
);
1031 return scm_values (scm_list_2 (pre
, lst
));
1036 SCM_DEFINE (scm_srfi1_split_at_x
, "split-at!", 2, 0, 0,
1038 "Return two values (multiple values), being a list of the\n"
1039 "elements before index @var{n} in @var{lst}, and a list of those\n"
1040 "after. @var{lst} is modified to form those values.")
1041 #define FUNC_NAME s_scm_srfi1_split_at
1047 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1049 SCM_VALIDATE_CONS (SCM_ARG1
, upto
);
1051 loc
= SCM_CDRLOC (upto
);
1052 upto
= SCM_CDR (upto
);
1056 return scm_values (scm_list_2 (lst
, upto
));
1061 SCM_DEFINE (scm_srfi1_take_right
, "take-right", 2, 0, 0,
1063 "Return the a list containing the @var{n} last elements of\n"
1065 #define FUNC_NAME s_scm_srfi1_take_right
1067 SCM tail
= scm_list_tail (lst
, n
);
1068 while (scm_is_pair (tail
))
1070 lst
= SCM_CDR (lst
);
1071 tail
= SCM_CDR (tail
);
1073 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
1080 scm_init_srfi_1 (void)
1082 SCM the_root_module
= scm_lookup_closure_module (SCM_BOOL_F
);
1083 #ifndef SCM_MAGIC_SNARFER
1084 #include "srfi/srfi-1.x"
1086 scm_c_extend_primitive_generic
1087 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "map")),
1088 SCM_VARIABLE_REF (scm_c_lookup ("map")));
1089 scm_c_extend_primitive_generic
1090 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "for-each")),
1091 SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
1094 /* End of srfi-1.c. */