1 /* srfi-1.c --- SRFI-1 procedures for Guile
3 * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006,
4 * 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
6 * This library is free software; you can redistribute it and/or
7 * modify it under the terms of the GNU Lesser General Public License
8 * as published by the Free Software Foundation; either version 3 of
9 * the License, or (at your option) any later version.
11 * This library is distributed in the hope that it will be useful, but
12 * 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., 51 Franklin Street, Fifth Floor, Boston, MA
27 #include "libguile/_scm.h"
28 #include "libguile/eq.h"
30 #include "libguile/validate.h"
31 #include "libguile/list.h"
32 #include "libguile/eval.h"
33 #include "libguile/srfi-1.h"
38 /* The intent of this file was to gradually replace those Scheme
39 * procedures in srfi-1.scm that extend core primitive procedures,
40 * so that using srfi-1 wouldn't have performance penalties.
42 * However, we now prefer to write these procedures in Scheme, let the compiler
43 * optimize them, and have the VM execute them efficiently.
48 srfi1_ilength (SCM sx
)
55 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
56 if (!scm_is_pair (hare
)) return -2;
59 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
60 if (!scm_is_pair (hare
)) return -2;
63 /* For every two steps the hare takes, the tortoise takes one. */
64 tortoise
= SCM_CDR(tortoise
);
66 while (! scm_is_eq (hare
, tortoise
));
68 /* If the tortoise ever catches the hare, then the list must contain
74 equal_trampoline (SCM proc
, SCM arg1
, SCM arg2
)
76 return scm_equal_p (arg1
, arg2
);
79 /* list_copy_part() copies the first COUNT cells of LST, puts the result at
80 *dst, and returns the SCM_CDRLOC of the last cell in that new list.
82 This function is designed to be careful about LST possibly having changed
83 in between the caller deciding what to copy, and the copy actually being
84 done here. The COUNT ensures we terminate if LST has become circular,
85 SCM_VALIDATE_CONS guards against a cdr in the list changed to some
90 list_copy_part (SCM lst
, int count
, SCM
*dst
)
91 #define FUNC_NAME "list_copy_part"
94 for ( ; count
> 0; count
--)
96 SCM_VALIDATE_CONS (SCM_ARGn
, lst
);
97 c
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
107 SCM_DEFINE (scm_srfi1_append_reverse
, "append-reverse", 2, 0, 0,
108 (SCM revhead
, SCM tail
),
109 "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
110 "result. This is equivalent to @code{(append (reverse\n"
111 "@var{rev-head}) @var{tail})}, but its implementation is more\n"
115 "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
117 #define FUNC_NAME s_scm_srfi1_append_reverse
119 while (scm_is_pair (revhead
))
121 /* copy first element of revhead onto front of tail */
122 tail
= scm_cons (SCM_CAR (revhead
), tail
);
123 revhead
= SCM_CDR (revhead
);
125 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead
), revhead
, SCM_ARG1
, FUNC_NAME
,
132 SCM_DEFINE (scm_srfi1_append_reverse_x
, "append-reverse!", 2, 0, 0,
133 (SCM revhead
, SCM tail
),
134 "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
135 "result. This is equivalent to @code{(append! (reverse!\n"
136 "@var{rev-head}) @var{tail})}, but its implementation is more\n"
140 "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
143 "@var{rev-head} may be modified in order to produce the result.")
144 #define FUNC_NAME s_scm_srfi1_append_reverse_x
148 while (scm_is_pair (revhead
))
150 /* take the first cons cell from revhead */
152 revhead
= SCM_CDR (revhead
);
154 /* make it the new start of tail, appending the previous */
155 SCM_SETCDR (newtail
, tail
);
158 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead
), revhead
, SCM_ARG1
, FUNC_NAME
,
164 SCM_DEFINE (scm_srfi1_concatenate
, "concatenate", 1, 0, 0,
166 "Construct a list by appending all lists in @var{lstlst}.\n"
168 "@code{concatenate} is the same as @code{(apply append\n"
169 "@var{lstlst})}. It exists because some Scheme implementations\n"
170 "have a limit on the number of arguments a function takes, which\n"
171 "the @code{apply} might exceed. In Guile there is no such\n"
173 #define FUNC_NAME s_scm_srfi1_concatenate
175 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
176 return scm_append (lstlst
);
181 SCM_DEFINE (scm_srfi1_concatenate_x
, "concatenate!", 1, 0, 0,
183 "Construct a list by appending all lists in @var{lstlst}. Those\n"
184 "lists may be modified to produce the result.\n"
186 "@code{concatenate!} is the same as @code{(apply append!\n"
187 "@var{lstlst})}. It exists because some Scheme implementations\n"
188 "have a limit on the number of arguments a function takes, which\n"
189 "the @code{apply} might exceed. In Guile there is no such\n"
191 #define FUNC_NAME s_scm_srfi1_concatenate_x
193 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
194 return scm_append_x (lstlst
);
199 SCM_DEFINE (scm_srfi1_count
, "count", 2, 0, 1,
200 (SCM pred
, SCM list1
, SCM rest
),
201 "Return a count of the number of times @var{pred} returns true\n"
202 "when called on elements from the given lists.\n"
204 "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
205 "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
206 "corresponding @var{list1} @dots{} @var{lstN}. The first call is\n"
207 "with the first element of each list, the second with the second\n"
208 "element from each, and so on.\n"
210 "Counting stops when the end of the shortest list is reached.\n"
211 "At least one list must be non-circular.")
212 #define FUNC_NAME s_scm_srfi1_count
217 SCM_VALIDATE_REST_ARGUMENT (rest
);
221 if (scm_is_null (rest
))
224 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
226 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
227 count
+= scm_is_true (scm_call_1 (pred
, SCM_CAR (list1
)));
229 /* check below that list1 is a proper list, and done */
234 else if (scm_is_pair (rest
) && scm_is_null (SCM_CDR (rest
)))
239 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
241 list2
= SCM_CAR (rest
);
244 if (! scm_is_pair (list1
))
246 if (! scm_is_pair (list2
))
252 count
+= scm_is_true (scm_call_2
253 (pred
, SCM_CAR (list1
), SCM_CAR (list2
)));
254 list1
= SCM_CDR (list1
);
255 list2
= SCM_CDR (list2
);
260 /* three or more lists */
264 /* vec is the list arguments */
265 vec
= scm_vector (scm_cons (list1
, rest
));
266 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
268 /* args is the argument list to pass to pred, same length as vec,
269 re-used for each call */
270 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
274 /* first elem of each list in vec into args, and step those
275 vec entries onto their next element */
276 for (i
= 0, a
= args
, argnum
= 2;
278 i
++, a
= SCM_CDR (a
), argnum
++)
280 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
281 if (! scm_is_pair (lst
))
282 goto check_lst_and_done
;
283 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for pred */
284 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
287 count
+= scm_is_true (scm_apply (pred
, args
, SCM_EOL
));
292 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
293 return scm_from_long (count
);
298 SCM_DEFINE (scm_srfi1_delete
, "delete", 2, 1, 0,
299 (SCM x
, SCM lst
, SCM pred
),
300 "Return a list containing the elements of @var{lst} but with\n"
301 "those equal to @var{x} deleted. The returned elements will be\n"
302 "in the same order as they were in @var{lst}.\n"
304 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
305 "given. An equality call is made just once for each element,\n"
306 "but the order in which the calls are made on the elements is\n"
309 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
310 "given @var{x} is first. This means for instance elements\n"
311 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
313 "@var{lst} is not modified, but the returned list might share a\n"
314 "common tail with @var{lst}.")
315 #define FUNC_NAME s_scm_srfi1_delete
317 SCM ret
, *p
, keeplst
;
320 if (SCM_UNBNDP (pred
))
321 return scm_delete (x
, lst
);
323 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG3
, FUNC_NAME
);
325 /* ret is the return list being constructed. p is where to append to it,
326 initially &ret then SCM_CDRLOC of the last pair. lst progresses as
327 elements are considered.
329 Elements to be retained are not immediately copied, instead keeplst is
330 the last pair in lst which is to be retained but not yet copied, count
331 is how many from there are wanted. When there's no more deletions, *p
332 can be set to keeplst to share the remainder of the original lst. (The
333 entire original lst if there's no deletions at all.) */
339 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
341 if (scm_is_true (scm_call_2 (pred
, x
, SCM_CAR (lst
))))
343 /* delete this element, so copy those at keeplst */
344 p
= list_copy_part (keeplst
, count
, p
);
345 keeplst
= SCM_CDR (lst
);
350 /* keep this element */
355 /* final retained elements */
358 /* demand that lst was a proper list */
359 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
366 SCM_DEFINE (scm_srfi1_delete_x
, "delete!", 2, 1, 0,
367 (SCM x
, SCM lst
, SCM pred
),
368 "Return a list containing the elements of @var{lst} but with\n"
369 "those equal to @var{x} deleted. The returned elements will be\n"
370 "in the same order as they were in @var{lst}.\n"
372 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
373 "given. An equality call is made just once for each element,\n"
374 "but the order in which the calls are made on the elements is\n"
377 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
378 "given @var{x} is first. This means for instance elements\n"
379 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
381 "@var{lst} may be modified to construct the returned list.")
382 #define FUNC_NAME s_scm_srfi1_delete_x
387 if (SCM_UNBNDP (pred
))
388 return scm_delete_x (x
, lst
);
390 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG3
, FUNC_NAME
);
392 for (prev
= &lst
, walk
= lst
;
394 walk
= SCM_CDR (walk
))
396 if (scm_is_true (scm_call_2 (pred
, x
, SCM_CAR (walk
))))
397 *prev
= SCM_CDR (walk
);
399 prev
= SCM_CDRLOC (walk
);
402 /* demand the input was a proper list */
403 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk
), walk
, SCM_ARG2
, FUNC_NAME
,"list");
409 SCM_DEFINE (scm_srfi1_delete_duplicates
, "delete-duplicates", 1, 1, 0,
411 "Return a list containing the elements of @var{lst} but without\n"
414 "When elements are equal, only the first in @var{lst} is\n"
415 "retained. Equal elements can be anywhere in @var{lst}, they\n"
416 "don't have to be adjacent. The returned list will have the\n"
417 "retained elements in the same order as they were in @var{lst}.\n"
419 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
420 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
421 "being before @var{y} in @var{lst}. A call is made at most once\n"
422 "for each combination, but the sequence of the calls across the\n"
423 "elements is unspecified.\n"
425 "@var{lst} is not modified, but the return might share a common\n"
426 "tail with @var{lst}.\n"
428 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
429 "it must check each element against all those preceding it. For\n"
430 "long lists it is more efficient to sort and then compare only\n"
431 "adjacent elements.")
432 #define FUNC_NAME s_scm_srfi1_delete_duplicates
434 scm_t_trampoline_2 equal_p
;
435 SCM ret
, *p
, keeplst
, item
, l
;
438 /* ret is the new list constructed. p is where to append, initially &ret
439 then SCM_CDRLOC of the last pair. lst is advanced as each element is
442 Elements retained are not immediately appended to ret, instead keeplst
443 is the last pair in lst which is to be kept but is not yet copied.
444 Initially this is the first pair of lst, since the first element is
447 *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
448 the elements retained, making the equality search loop easy.
450 If an item must be deleted, elements from keeplst (inclusive) to lst
451 (exclusive) must be copied and appended to ret. When there's no more
452 deletions, *p is left set to keeplst, so ret shares structure with the
453 original lst. (ret will be the entire original lst if there are no
456 /* skip to end if an empty list (or something invalid) */
459 if (SCM_UNBNDP (pred
))
460 equal_p
= equal_trampoline
;
463 SCM_VALIDATE_PROC (SCM_ARG2
, pred
);
464 equal_p
= scm_call_2
;
471 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
473 item
= SCM_CAR (lst
);
475 /* look for item in "ret" list */
476 for (l
= ret
; scm_is_pair (l
); l
= SCM_CDR (l
))
478 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
480 /* "item" is a duplicate, so copy keeplst onto ret */
482 p
= list_copy_part (keeplst
, count
, p
);
484 keeplst
= SCM_CDR (lst
); /* elem after the one deleted */
490 /* look for item in "keeplst" list
491 be careful traversing, in case nasty code changed the cdrs */
492 for (i
= 0, l
= keeplst
;
493 i
< count
&& scm_is_pair (l
);
494 i
++, l
= SCM_CDR (l
))
495 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
498 /* keep this element */
504 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
506 /* share tail of keeplst items */
514 SCM_DEFINE (scm_srfi1_delete_duplicates_x
, "delete-duplicates!", 1, 1, 0,
516 "Return a list containing the elements of @var{lst} but without\n"
519 "When elements are equal, only the first in @var{lst} is\n"
520 "retained. Equal elements can be anywhere in @var{lst}, they\n"
521 "don't have to be adjacent. The returned list will have the\n"
522 "retained elements in the same order as they were in @var{lst}.\n"
524 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
525 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
526 "being before @var{y} in @var{lst}. A call is made at most once\n"
527 "for each combination, but the sequence of the calls across the\n"
528 "elements is unspecified.\n"
530 "@var{lst} may be modified to construct the returned list.\n"
532 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
533 "it must check each element against all those preceding it. For\n"
534 "long lists it is more efficient to sort and then compare only\n"
535 "adjacent elements.")
536 #define FUNC_NAME s_scm_srfi1_delete_duplicates_x
538 scm_t_trampoline_2 equal_p
;
539 SCM ret
, endret
, item
, l
;
541 /* ret is the return list, constructed from the pairs in lst. endret is
542 the last pair of ret, initially the first pair. lst is advanced as
543 elements are considered. */
545 /* skip to end if an empty list (or something invalid) */
547 if (scm_is_pair (lst
))
549 if (SCM_UNBNDP (pred
))
550 equal_p
= equal_trampoline
;
553 SCM_VALIDATE_PROC (SCM_ARG2
, pred
);
554 equal_p
= scm_call_2
;
559 /* loop over lst elements starting from second */
563 if (! scm_is_pair (lst
))
565 item
= SCM_CAR (lst
);
567 /* is item equal to any element from ret to endret (inclusive)? */
571 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
572 break; /* equal, forget this element */
574 if (scm_is_eq (l
, endret
))
576 /* not equal to any, so append this pair */
577 SCM_SETCDR (endret
, lst
);
585 /* terminate, in case last element was deleted */
586 SCM_SETCDR (endret
, SCM_EOL
);
589 /* demand that lst was a proper list */
590 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
597 SCM_DEFINE (scm_srfi1_drop_right
, "drop-right", 2, 0, 0,
599 "Return a new list containing all except the last @var{n}\n"
600 "elements of @var{lst}.")
601 #define FUNC_NAME s_scm_srfi1_drop_right
603 SCM tail
= scm_list_tail (lst
, n
);
606 while (scm_is_pair (tail
))
608 *rend
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
609 rend
= SCM_CDRLOC (*rend
);
612 tail
= SCM_CDR (tail
);
614 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
619 SCM_DEFINE (scm_srfi1_find
, "find", 2, 0, 0,
621 "Return the first element of @var{lst} which satisfies the\n"
622 "predicate @var{pred}, or return @code{#f} if no such element is\n"
624 #define FUNC_NAME s_scm_srfi1_find
626 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
628 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
630 SCM elem
= SCM_CAR (lst
);
631 if (scm_is_true (scm_call_1 (pred
, elem
)))
634 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
641 SCM_DEFINE (scm_srfi1_find_tail
, "find-tail", 2, 0, 0,
643 "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
644 "predicate @var{pred}, or return @code{#f} if no such element is\n"
646 #define FUNC_NAME s_scm_srfi1_find_tail
648 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
650 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
651 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (lst
))))
653 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
659 SCM_DEFINE (scm_srfi1_length_plus
, "length+", 1, 0, 0,
661 "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
663 #define FUNC_NAME s_scm_srfi1_length_plus
665 long len
= scm_ilength (lst
);
666 return (len
>= 0 ? SCM_I_MAKINUM (len
) : SCM_BOOL_F
);
671 /* This routine differs from the core list-copy in allowing improper lists.
672 Maybe the core could allow them similarly. */
674 SCM_DEFINE (scm_srfi1_list_copy
, "list-copy", 1, 0, 0,
676 "Return a copy of the given list @var{lst}.\n"
678 "@var{lst} can be a proper or improper list. And if @var{lst}\n"
679 "is not a pair then it's treated as the final tail of an\n"
680 "improper list and simply returned.")
681 #define FUNC_NAME s_scm_srfi1_list_copy
691 while (scm_is_pair (from_here
))
694 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
696 fill_here
= SCM_CDRLOC (c
);
697 from_here
= SCM_CDR (from_here
);
703 SCM_DEFINE (scm_srfi1_lset_difference_x
, "lset-difference!", 2, 0, 1,
704 (SCM equal
, SCM lst
, SCM rest
),
705 "Return @var{lst} with any elements in the lists in @var{rest}\n"
706 "removed (ie.@: subtracted). For only one @var{lst} argument,\n"
707 "just that list is returned.\n"
709 "The given @var{equal} procedure is used for comparing elements,\n"
710 "called as @code{(@var{equal} elem1 elemN)}. The first argument\n"
711 "is from @var{lst} and the second from one of the subsequent\n"
712 "lists. But exactly which calls are made and in what order is\n"
716 "(lset-difference! eqv? (list 'x 'y)) @result{} (x y)\n"
717 "(lset-difference! eqv? (list 1 2 3) '(3 1)) @result{} (2)\n"
718 "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n"
721 "@code{lset-difference!} may modify @var{lst} to form its\n"
723 #define FUNC_NAME s_scm_srfi1_lset_difference_x
725 SCM ret
, *pos
, elem
, r
, b
;
728 SCM_VALIDATE_PROC (SCM_ARG1
, equal
);
729 SCM_VALIDATE_REST_ARGUMENT (rest
);
733 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
735 elem
= SCM_CAR (lst
);
737 for (r
= rest
, argnum
= SCM_ARG3
;
739 r
= SCM_CDR (r
), argnum
++)
741 for (b
= SCM_CAR (r
); scm_is_pair (b
); b
= SCM_CDR (b
))
742 if (scm_is_true (scm_call_2 (equal
, elem
, SCM_CAR (b
))))
743 goto next_elem
; /* equal to elem, so drop that elem */
745 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b
), b
, argnum
, FUNC_NAME
,"list");
748 /* elem not equal to anything in later lists, so keep it */
750 pos
= SCM_CDRLOC (lst
);
755 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
763 /* Typechecking for multi-argument MAP and FOR-EACH.
765 Verify that each element of the vector ARGV, except for the first,
766 is a list and return minimum length. Attribute errors to WHO,
767 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
769 check_map_args (SCM argv
,
779 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
782 elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
784 if (!(scm_is_null (elt
) || scm_is_pair (elt
)))
785 goto check_map_error
;
787 elt_len
= srfi1_ilength (elt
);
789 goto check_map_error
;
791 if (len
< 0 || (elt_len
>= 0 && elt_len
< len
))
801 scm_apply_generic (gf
, scm_cons (proc
, args
));
803 scm_wrong_type_arg (who
, i
+ 2, elt
);
806 scm_remember_upto_here_1 (argv
);
811 SCM_GPROC (s_srfi1_map
, "map", 2, 0, 1, scm_srfi1_map
, g_srfi1_map
);
813 /* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
814 sequentially, starting with the first element(s). This is used in
815 the Scheme procedure `map-in-order', which guarantees sequential
816 behaviour, is implemented using scm_map. If the behaviour changes,
817 we need to update `map-in-order'.
821 scm_srfi1_map (SCM proc
, SCM arg1
, SCM args
)
822 #define FUNC_NAME s_srfi1_map
828 len
= srfi1_ilength (arg1
);
829 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
831 scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_srfi1_map
);
832 SCM_VALIDATE_REST_ARGUMENT (args
);
833 if (scm_is_null (args
))
835 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_srfi1_map
,
836 proc
, arg1
, SCM_ARG1
, s_srfi1_map
);
837 SCM_GASSERT2 (len
>= 0, g_srfi1_map
, proc
, arg1
, SCM_ARG2
, s_srfi1_map
);
838 while (SCM_NIMP (arg1
))
840 *pres
= scm_list_1 (scm_call_1 (proc
, SCM_CAR (arg1
)));
841 pres
= SCM_CDRLOC (*pres
);
842 arg1
= SCM_CDR (arg1
);
846 if (scm_is_null (SCM_CDR (args
)))
848 SCM arg2
= SCM_CAR (args
);
849 int len2
= srfi1_ilength (arg2
);
850 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_srfi1_map
,
851 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_map
);
852 if (len
< 0 || (len2
>= 0 && len2
< len
))
854 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
855 && len
>= 0 && len2
>= -1,
857 scm_cons2 (proc
, arg1
, args
),
858 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
862 *pres
= scm_list_1 (scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
863 pres
= SCM_CDRLOC (*pres
);
864 arg1
= SCM_CDR (arg1
);
865 arg2
= SCM_CDR (arg2
);
870 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
871 len
= check_map_args (args
, len
, g_srfi1_map
, proc
, arg1
, s_srfi1_map
);
875 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
877 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
878 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
879 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
881 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
882 pres
= SCM_CDRLOC (*pres
);
889 SCM_REGISTER_PROC (s_srfi1_map_in_order
, "map-in-order", 2, 0, 1, scm_srfi1_map
);
891 SCM_GPROC (s_srfi1_for_each
, "for-each", 2, 0, 1, scm_srfi1_for_each
, g_srfi1_for_each
);
894 scm_srfi1_for_each (SCM proc
, SCM arg1
, SCM args
)
895 #define FUNC_NAME s_srfi1_for_each
898 len
= srfi1_ilength (arg1
);
899 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
900 g_srfi1_for_each
, scm_cons2 (proc
, arg1
, args
),
901 SCM_ARG2
, s_srfi1_for_each
);
902 SCM_VALIDATE_REST_ARGUMENT (args
);
903 if (scm_is_null (args
))
905 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_srfi1_for_each
,
906 proc
, arg1
, SCM_ARG1
, s_srfi1_for_each
);
907 SCM_GASSERT2 (len
>= 0, g_srfi1_for_each
, proc
, arg1
,
908 SCM_ARG2
, s_srfi1_map
);
909 while (SCM_NIMP (arg1
))
911 scm_call_1 (proc
, SCM_CAR (arg1
));
912 arg1
= SCM_CDR (arg1
);
914 return SCM_UNSPECIFIED
;
916 if (scm_is_null (SCM_CDR (args
)))
918 SCM arg2
= SCM_CAR (args
);
919 int len2
= srfi1_ilength (arg2
);
920 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_srfi1_for_each
,
921 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_for_each
);
922 if (len
< 0 || (len2
>= 0 && len2
< len
))
924 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
925 && len
>= 0 && len2
>= -1,
927 scm_cons2 (proc
, arg1
, args
),
928 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
932 scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
933 arg1
= SCM_CDR (arg1
);
934 arg2
= SCM_CDR (arg2
);
937 return SCM_UNSPECIFIED
;
939 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
940 len
= check_map_args (args
, len
, g_srfi1_for_each
, proc
, arg1
,
945 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
947 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
948 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
949 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
951 scm_apply (proc
, arg1
, SCM_EOL
);
954 return SCM_UNSPECIFIED
;
959 SCM_DEFINE (scm_srfi1_member
, "member", 2, 1, 0,
960 (SCM x
, SCM lst
, SCM pred
),
961 "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
962 "to @var{x}. If @var{x} does not appear in @var{lst}, return\n"
965 "Equality is determined by @code{equal?}, or by the equality\n"
966 "predicate @var{=} if given. @var{=} is called @code{(= @var{x}\n"
967 "elem)}, ie.@: with the given @var{x} first, so for example to\n"
968 "find the first element greater than 5,\n"
971 "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
974 "This version of @code{member} extends the core @code{member} by\n"
975 "accepting an equality predicate.")
976 #define FUNC_NAME s_scm_srfi1_member
978 scm_t_trampoline_2 equal_p
;
979 SCM_VALIDATE_LIST (2, lst
);
980 if (SCM_UNBNDP (pred
))
981 equal_p
= equal_trampoline
;
984 SCM_VALIDATE_PROC (SCM_ARG3
, pred
);
985 equal_p
= scm_call_2
;
987 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
989 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
996 SCM_DEFINE (scm_srfi1_assoc
, "assoc", 2, 1, 0,
997 (SCM key
, SCM alist
, SCM pred
),
998 "Behaves like @code{assq} but uses third argument @var{pred?}\n"
999 "for key comparison. If @var{pred?} is not supplied,\n"
1000 "@code{equal?} is used. (Extended from R5RS.)\n")
1001 #define FUNC_NAME s_scm_srfi1_assoc
1004 scm_t_trampoline_2 equal_p
;
1005 if (SCM_UNBNDP (pred
))
1006 equal_p
= equal_trampoline
;
1009 SCM_VALIDATE_PROC (SCM_ARG3
, pred
);
1010 equal_p
= scm_call_2
;
1012 for(; scm_is_pair (ls
); ls
= SCM_CDR (ls
))
1014 SCM tmp
= SCM_CAR (ls
);
1015 SCM_ASSERT_TYPE (scm_is_pair (tmp
), alist
, SCM_ARG2
, FUNC_NAME
,
1016 "association list");
1017 if (scm_is_true (equal_p (pred
, key
, SCM_CAR (tmp
))))
1020 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls
), alist
, SCM_ARG2
, FUNC_NAME
,
1021 "association list");
1026 SCM_DEFINE (scm_srfi1_partition
, "partition", 2, 0, 0,
1027 (SCM pred
, SCM list
),
1028 "Partition the elements of @var{list} with predicate @var{pred}.\n"
1029 "Return two values: the list of elements satisfying @var{pred} and\n"
1030 "the list of elements @emph{not} satisfying @var{pred}. The order\n"
1031 "of the output lists follows the order of @var{list}. @var{list}\n"
1032 "is not mutated. One of the output lists may share memory with @var{list}.\n")
1033 #define FUNC_NAME s_scm_srfi1_partition
1035 /* In this implementation, the output lists don't share memory with
1036 list, because it's probably not worth the effort. */
1037 SCM orig_list
= list
;
1038 SCM kept
= scm_cons(SCM_EOL
, SCM_EOL
);
1039 SCM kept_tail
= kept
;
1040 SCM dropped
= scm_cons(SCM_EOL
, SCM_EOL
);
1041 SCM dropped_tail
= dropped
;
1043 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
1045 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR(list
)) {
1048 /* Make sure LIST is not a dotted list. */
1049 SCM_ASSERT (scm_is_pair (list
), orig_list
, SCM_ARG2
, FUNC_NAME
);
1051 elt
= SCM_CAR (list
);
1052 new_tail
= scm_cons (SCM_CAR (list
), SCM_EOL
);
1054 if (scm_is_true (scm_call_1 (pred
, elt
))) {
1055 SCM_SETCDR(kept_tail
, new_tail
);
1056 kept_tail
= new_tail
;
1059 SCM_SETCDR(dropped_tail
, new_tail
);
1060 dropped_tail
= new_tail
;
1063 /* re-use the initial conses for the values list */
1064 SCM_SETCAR(kept
, SCM_CDR(kept
));
1065 SCM_SETCDR(kept
, dropped
);
1066 SCM_SETCAR(dropped
, SCM_CDR(dropped
));
1067 SCM_SETCDR(dropped
, SCM_EOL
);
1068 return scm_values(kept
);
1073 SCM_DEFINE (scm_srfi1_partition_x
, "partition!", 2, 0, 0,
1074 (SCM pred
, SCM lst
),
1075 "Split @var{lst} into those elements which do and don't satisfy\n"
1076 "the predicate @var{pred}.\n"
1078 "The return is two values (@pxref{Multiple Values}), the first\n"
1079 "being a list of all elements from @var{lst} which satisfy\n"
1080 "@var{pred}, the second a list of those which do not.\n"
1082 "The elements in the result lists are in the same order as in\n"
1083 "@var{lst} but the order in which the calls @code{(@var{pred}\n"
1084 "elem)} are made on the list elements is unspecified.\n"
1086 "@var{lst} may be modified to construct the return lists.")
1087 #define FUNC_NAME s_scm_srfi1_partition_x
1089 SCM tlst
, flst
, *tp
, *fp
;
1091 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
1093 /* tlst and flst are the lists of true and false elements. tp and fp are
1094 where to store to append to them, initially &tlst and &flst, then
1095 SCM_CDRLOC of the last pair in the respective lists. */
1102 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1104 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (lst
))))
1107 tp
= SCM_CDRLOC (lst
);
1112 fp
= SCM_CDRLOC (lst
);
1116 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1118 /* terminate whichever didn't get the last element(s) */
1122 return scm_values (scm_list_2 (tlst
, flst
));
1126 SCM_DEFINE (scm_srfi1_remove
, "remove", 2, 0, 0,
1127 (SCM pred
, SCM list
),
1128 "Return a list containing all elements from @var{lst} which do\n"
1129 "not satisfy the predicate @var{pred}. The elements in the\n"
1130 "result list have the same order as in @var{lst}. The order in\n"
1131 "which @var{pred} is applied to the list elements is not\n"
1133 #define FUNC_NAME s_scm_srfi1_remove
1138 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
1139 SCM_VALIDATE_LIST (2, list
);
1141 for (prev
= &res
, walk
= list
;
1143 walk
= SCM_CDR (walk
))
1145 if (scm_is_false (scm_call_1 (pred
, SCM_CAR (walk
))))
1147 *prev
= scm_cons (SCM_CAR (walk
), SCM_EOL
);
1148 prev
= SCM_CDRLOC (*prev
);
1157 SCM_DEFINE (scm_srfi1_remove_x
, "remove!", 2, 0, 0,
1158 (SCM pred
, SCM list
),
1159 "Return a list containing all elements from @var{list} which do\n"
1160 "not satisfy the predicate @var{pred}. The elements in the\n"
1161 "result list have the same order as in @var{list}. The order in\n"
1162 "which @var{pred} is applied to the list elements is not\n"
1163 "specified. @var{list} may be modified to build the return\n"
1165 #define FUNC_NAME s_scm_srfi1_remove_x
1169 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
1170 SCM_VALIDATE_LIST (2, list
);
1172 for (prev
= &list
, walk
= list
;
1174 walk
= SCM_CDR (walk
))
1176 if (scm_is_false (scm_call_1 (pred
, SCM_CAR (walk
))))
1177 prev
= SCM_CDRLOC (walk
);
1179 *prev
= SCM_CDR (walk
);
1186 SCM_DEFINE (scm_srfi1_take_right
, "take-right", 2, 0, 0,
1188 "Return a list containing the @var{n} last elements of\n"
1190 #define FUNC_NAME s_scm_srfi1_take_right
1192 SCM tail
= scm_list_tail (lst
, n
);
1193 while (scm_is_pair (tail
))
1195 lst
= SCM_CDR (lst
);
1196 tail
= SCM_CDR (tail
);
1198 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
1205 scm_register_srfi_1 (void)
1207 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1209 (scm_t_extension_init_func
)scm_init_srfi_1
, NULL
);
1213 scm_init_srfi_1 (void)
1215 SCM the_root_module
= scm_lookup_closure_module (SCM_BOOL_F
);
1216 #ifndef SCM_MAGIC_SNARFER
1217 #include "libguile/srfi-1.x"
1219 scm_c_extend_primitive_generic
1220 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "map")),
1221 SCM_VARIABLE_REF (scm_c_lookup ("map")));
1222 scm_c_extend_primitive_generic
1223 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "for-each")),
1224 SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
1227 /* End of srfi-1.c. */