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, 2013 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 equal_trampoline (SCM proc
, SCM arg1
, SCM arg2
)
50 return scm_equal_p (arg1
, arg2
);
53 /* list_copy_part() copies the first COUNT cells of LST, puts the result at
54 *dst, and returns the SCM_CDRLOC of the last cell in that new list.
56 This function is designed to be careful about LST possibly having changed
57 in between the caller deciding what to copy, and the copy actually being
58 done here. The COUNT ensures we terminate if LST has become circular,
59 SCM_VALIDATE_CONS guards against a cdr in the list changed to some
64 list_copy_part (SCM lst
, int count
, SCM
*dst
)
65 #define FUNC_NAME "list_copy_part"
68 for ( ; count
> 0; count
--)
70 SCM_VALIDATE_CONS (SCM_ARGn
, lst
);
71 c
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
81 SCM_DEFINE (scm_srfi1_append_reverse
, "append-reverse", 2, 0, 0,
82 (SCM revhead
, SCM tail
),
83 "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
84 "result. This is equivalent to @code{(append (reverse\n"
85 "@var{rev-head}) @var{tail})}, but its implementation is more\n"
89 "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
91 #define FUNC_NAME s_scm_srfi1_append_reverse
93 while (scm_is_pair (revhead
))
95 /* copy first element of revhead onto front of tail */
96 tail
= scm_cons (SCM_CAR (revhead
), tail
);
97 revhead
= SCM_CDR (revhead
);
99 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead
), revhead
, SCM_ARG1
, FUNC_NAME
,
106 SCM_DEFINE (scm_srfi1_append_reverse_x
, "append-reverse!", 2, 0, 0,
107 (SCM revhead
, SCM tail
),
108 "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
109 "result. This is equivalent to @code{(append! (reverse!\n"
110 "@var{rev-head}) @var{tail})}, but its implementation is more\n"
114 "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
117 "@var{rev-head} may be modified in order to produce the result.")
118 #define FUNC_NAME s_scm_srfi1_append_reverse_x
122 while (scm_is_pair (revhead
))
124 /* take the first cons cell from revhead */
126 revhead
= SCM_CDR (revhead
);
128 /* make it the new start of tail, appending the previous */
129 SCM_SETCDR (newtail
, tail
);
132 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead
), revhead
, SCM_ARG1
, FUNC_NAME
,
138 SCM_DEFINE (scm_srfi1_concatenate
, "concatenate", 1, 0, 0,
140 "Construct a list by appending all lists in @var{lstlst}.\n"
142 "@code{concatenate} is the same as @code{(apply append\n"
143 "@var{lstlst})}. It exists because some Scheme implementations\n"
144 "have a limit on the number of arguments a function takes, which\n"
145 "the @code{apply} might exceed. In Guile there is no such\n"
147 #define FUNC_NAME s_scm_srfi1_concatenate
149 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
150 return scm_append (lstlst
);
155 SCM_DEFINE (scm_srfi1_concatenate_x
, "concatenate!", 1, 0, 0,
157 "Construct a list by appending all lists in @var{lstlst}. Those\n"
158 "lists may be modified to produce the result.\n"
160 "@code{concatenate!} is the same as @code{(apply append!\n"
161 "@var{lstlst})}. It exists because some Scheme implementations\n"
162 "have a limit on the number of arguments a function takes, which\n"
163 "the @code{apply} might exceed. In Guile there is no such\n"
165 #define FUNC_NAME s_scm_srfi1_concatenate_x
167 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
168 return scm_append_x (lstlst
);
173 SCM_DEFINE (scm_srfi1_count
, "count", 2, 0, 1,
174 (SCM pred
, SCM list1
, SCM rest
),
175 "Return a count of the number of times @var{pred} returns true\n"
176 "when called on elements from the given lists.\n"
178 "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
179 "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
180 "corresponding @var{list1} @dots{} @var{lstN}. The first call is\n"
181 "with the first element of each list, the second with the second\n"
182 "element from each, and so on.\n"
184 "Counting stops when the end of the shortest list is reached.\n"
185 "At least one list must be non-circular.")
186 #define FUNC_NAME s_scm_srfi1_count
191 SCM_VALIDATE_REST_ARGUMENT (rest
);
195 if (scm_is_null (rest
))
198 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
200 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
201 count
+= scm_is_true (scm_call_1 (pred
, SCM_CAR (list1
)));
203 /* check below that list1 is a proper list, and done */
208 else if (scm_is_pair (rest
) && scm_is_null (SCM_CDR (rest
)))
213 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
215 list2
= SCM_CAR (rest
);
218 if (! scm_is_pair (list1
))
220 if (! scm_is_pair (list2
))
226 count
+= scm_is_true (scm_call_2
227 (pred
, SCM_CAR (list1
), SCM_CAR (list2
)));
228 list1
= SCM_CDR (list1
);
229 list2
= SCM_CDR (list2
);
234 /* three or more lists */
238 /* vec is the list arguments */
239 vec
= scm_vector (scm_cons (list1
, rest
));
240 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
242 /* args is the argument list to pass to pred, same length as vec,
243 re-used for each call */
244 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
248 /* first elem of each list in vec into args, and step those
249 vec entries onto their next element */
250 for (i
= 0, a
= args
, argnum
= 2;
252 i
++, a
= SCM_CDR (a
), argnum
++)
254 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
255 if (! scm_is_pair (lst
))
256 goto check_lst_and_done
;
257 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for pred */
258 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
261 count
+= scm_is_true (scm_apply_0 (pred
, args
));
266 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
267 return scm_from_long (count
);
272 SCM_DEFINE (scm_srfi1_delete
, "delete", 2, 1, 0,
273 (SCM x
, SCM lst
, SCM pred
),
274 "Return a list containing the elements of @var{lst} but with\n"
275 "those equal to @var{x} deleted. The returned elements will be\n"
276 "in the same order as they were in @var{lst}.\n"
278 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
279 "given. An equality call is made just once for each element,\n"
280 "but the order in which the calls are made on the elements is\n"
283 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
284 "given @var{x} is first. This means for instance elements\n"
285 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
287 "@var{lst} is not modified, but the returned list might share a\n"
288 "common tail with @var{lst}.")
289 #define FUNC_NAME s_scm_srfi1_delete
291 SCM ret
, *p
, keeplst
;
294 if (SCM_UNBNDP (pred
))
295 return scm_delete (x
, lst
);
297 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG3
, FUNC_NAME
);
299 /* ret is the return list being constructed. p is where to append to it,
300 initially &ret then SCM_CDRLOC of the last pair. lst progresses as
301 elements are considered.
303 Elements to be retained are not immediately copied, instead keeplst is
304 the last pair in lst which is to be retained but not yet copied, count
305 is how many from there are wanted. When there's no more deletions, *p
306 can be set to keeplst to share the remainder of the original lst. (The
307 entire original lst if there's no deletions at all.) */
313 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
315 if (scm_is_true (scm_call_2 (pred
, x
, SCM_CAR (lst
))))
317 /* delete this element, so copy those at keeplst */
318 p
= list_copy_part (keeplst
, count
, p
);
319 keeplst
= SCM_CDR (lst
);
324 /* keep this element */
329 /* final retained elements */
332 /* demand that lst was a proper list */
333 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
340 SCM_DEFINE (scm_srfi1_delete_x
, "delete!", 2, 1, 0,
341 (SCM x
, SCM lst
, SCM pred
),
342 "Return a list containing the elements of @var{lst} but with\n"
343 "those equal to @var{x} deleted. The returned elements will be\n"
344 "in the same order as they were in @var{lst}.\n"
346 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
347 "given. An equality call is made just once for each element,\n"
348 "but the order in which the calls are made on the elements is\n"
351 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
352 "given @var{x} is first. This means for instance elements\n"
353 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
355 "@var{lst} may be modified to construct the returned list.")
356 #define FUNC_NAME s_scm_srfi1_delete_x
361 if (SCM_UNBNDP (pred
))
362 return scm_delete_x (x
, lst
);
364 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG3
, FUNC_NAME
);
366 for (prev
= &lst
, walk
= lst
;
368 walk
= SCM_CDR (walk
))
370 if (scm_is_true (scm_call_2 (pred
, x
, SCM_CAR (walk
))))
371 *prev
= SCM_CDR (walk
);
373 prev
= SCM_CDRLOC (walk
);
376 /* demand the input was a proper list */
377 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk
), walk
, SCM_ARG2
, FUNC_NAME
,"list");
383 SCM_DEFINE (scm_srfi1_delete_duplicates
, "delete-duplicates", 1, 1, 0,
385 "Return a list containing the elements of @var{lst} but without\n"
388 "When elements are equal, only the first in @var{lst} is\n"
389 "retained. Equal elements can be anywhere in @var{lst}, they\n"
390 "don't have to be adjacent. The returned list will have the\n"
391 "retained elements in the same order as they were in @var{lst}.\n"
393 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
394 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
395 "being before @var{y} in @var{lst}. A call is made at most once\n"
396 "for each combination, but the sequence of the calls across the\n"
397 "elements is unspecified.\n"
399 "@var{lst} is not modified, but the return might share a common\n"
400 "tail with @var{lst}.\n"
402 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
403 "it must check each element against all those preceding it. For\n"
404 "long lists it is more efficient to sort and then compare only\n"
405 "adjacent elements.")
406 #define FUNC_NAME s_scm_srfi1_delete_duplicates
408 scm_t_trampoline_2 equal_p
;
409 SCM ret
, *p
, keeplst
, item
, l
;
412 /* ret is the new list constructed. p is where to append, initially &ret
413 then SCM_CDRLOC of the last pair. lst is advanced as each element is
416 Elements retained are not immediately appended to ret, instead keeplst
417 is the last pair in lst which is to be kept but is not yet copied.
418 Initially this is the first pair of lst, since the first element is
421 *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
422 the elements retained, making the equality search loop easy.
424 If an item must be deleted, elements from keeplst (inclusive) to lst
425 (exclusive) must be copied and appended to ret. When there's no more
426 deletions, *p is left set to keeplst, so ret shares structure with the
427 original lst. (ret will be the entire original lst if there are no
430 /* skip to end if an empty list (or something invalid) */
433 if (SCM_UNBNDP (pred
))
434 equal_p
= equal_trampoline
;
437 SCM_VALIDATE_PROC (SCM_ARG2
, pred
);
438 equal_p
= scm_call_2
;
445 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
447 item
= SCM_CAR (lst
);
449 /* look for item in "ret" list */
450 for (l
= ret
; scm_is_pair (l
); l
= SCM_CDR (l
))
452 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
454 /* "item" is a duplicate, so copy keeplst onto ret */
456 p
= list_copy_part (keeplst
, count
, p
);
458 keeplst
= SCM_CDR (lst
); /* elem after the one deleted */
464 /* look for item in "keeplst" list
465 be careful traversing, in case nasty code changed the cdrs */
466 for (i
= 0, l
= keeplst
;
467 i
< count
&& scm_is_pair (l
);
468 i
++, l
= SCM_CDR (l
))
469 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
472 /* keep this element */
478 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
480 /* share tail of keeplst items */
488 SCM_DEFINE (scm_srfi1_delete_duplicates_x
, "delete-duplicates!", 1, 1, 0,
490 "Return a list containing the elements of @var{lst} but without\n"
493 "When elements are equal, only the first in @var{lst} is\n"
494 "retained. Equal elements can be anywhere in @var{lst}, they\n"
495 "don't have to be adjacent. The returned list will have the\n"
496 "retained elements in the same order as they were in @var{lst}.\n"
498 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
499 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
500 "being before @var{y} in @var{lst}. A call is made at most once\n"
501 "for each combination, but the sequence of the calls across the\n"
502 "elements is unspecified.\n"
504 "@var{lst} may be modified to construct the returned list.\n"
506 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
507 "it must check each element against all those preceding it. For\n"
508 "long lists it is more efficient to sort and then compare only\n"
509 "adjacent elements.")
510 #define FUNC_NAME s_scm_srfi1_delete_duplicates_x
512 scm_t_trampoline_2 equal_p
;
513 SCM ret
, endret
, item
, l
;
515 /* ret is the return list, constructed from the pairs in lst. endret is
516 the last pair of ret, initially the first pair. lst is advanced as
517 elements are considered. */
519 /* skip to end if an empty list (or something invalid) */
521 if (scm_is_pair (lst
))
523 if (SCM_UNBNDP (pred
))
524 equal_p
= equal_trampoline
;
527 SCM_VALIDATE_PROC (SCM_ARG2
, pred
);
528 equal_p
= scm_call_2
;
533 /* loop over lst elements starting from second */
537 if (! scm_is_pair (lst
))
539 item
= SCM_CAR (lst
);
541 /* is item equal to any element from ret to endret (inclusive)? */
545 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
546 break; /* equal, forget this element */
548 if (scm_is_eq (l
, endret
))
550 /* not equal to any, so append this pair */
551 SCM_SETCDR (endret
, lst
);
559 /* terminate, in case last element was deleted */
560 SCM_SETCDR (endret
, SCM_EOL
);
563 /* demand that lst was a proper list */
564 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
571 SCM_DEFINE (scm_srfi1_find
, "find", 2, 0, 0,
573 "Return the first element of @var{lst} which satisfies the\n"
574 "predicate @var{pred}, or return @code{#f} if no such element is\n"
576 #define FUNC_NAME s_scm_srfi1_find
578 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
580 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
582 SCM elem
= SCM_CAR (lst
);
583 if (scm_is_true (scm_call_1 (pred
, elem
)))
586 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
593 SCM_DEFINE (scm_srfi1_find_tail
, "find-tail", 2, 0, 0,
595 "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
596 "predicate @var{pred}, or return @code{#f} if no such element is\n"
598 #define FUNC_NAME s_scm_srfi1_find_tail
600 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
602 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
603 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (lst
))))
605 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
611 SCM_DEFINE (scm_srfi1_length_plus
, "length+", 1, 0, 0,
613 "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
615 #define FUNC_NAME s_scm_srfi1_length_plus
617 long len
= scm_ilength (lst
);
618 return (len
>= 0 ? SCM_I_MAKINUM (len
) : SCM_BOOL_F
);
623 /* This routine differs from the core list-copy in allowing improper lists.
624 Maybe the core could allow them similarly. */
626 SCM_DEFINE (scm_srfi1_list_copy
, "list-copy", 1, 0, 0,
628 "Return a copy of the given list @var{lst}.\n"
630 "@var{lst} can be a proper or improper list. And if @var{lst}\n"
631 "is not a pair then it's treated as the final tail of an\n"
632 "improper list and simply returned.")
633 #define FUNC_NAME s_scm_srfi1_list_copy
643 while (scm_is_pair (from_here
))
646 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
648 fill_here
= SCM_CDRLOC (c
);
649 from_here
= SCM_CDR (from_here
);
655 SCM_DEFINE (scm_srfi1_lset_difference_x
, "lset-difference!", 2, 0, 1,
656 (SCM equal
, SCM lst
, SCM rest
),
657 "Return @var{lst} with any elements in the lists in @var{rest}\n"
658 "removed (ie.@: subtracted). For only one @var{lst} argument,\n"
659 "just that list is returned.\n"
661 "The given @var{equal} procedure is used for comparing elements,\n"
662 "called as @code{(@var{equal} elem1 elemN)}. The first argument\n"
663 "is from @var{lst} and the second from one of the subsequent\n"
664 "lists. But exactly which calls are made and in what order is\n"
668 "(lset-difference! eqv? (list 'x 'y)) @result{} (x y)\n"
669 "(lset-difference! eqv? (list 1 2 3) '(3 1)) @result{} (2)\n"
670 "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n"
673 "@code{lset-difference!} may modify @var{lst} to form its\n"
675 #define FUNC_NAME s_scm_srfi1_lset_difference_x
677 SCM ret
, *pos
, elem
, r
, b
;
680 SCM_VALIDATE_PROC (SCM_ARG1
, equal
);
681 SCM_VALIDATE_REST_ARGUMENT (rest
);
685 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
687 elem
= SCM_CAR (lst
);
689 for (r
= rest
, argnum
= SCM_ARG3
;
691 r
= SCM_CDR (r
), argnum
++)
693 for (b
= SCM_CAR (r
); scm_is_pair (b
); b
= SCM_CDR (b
))
694 if (scm_is_true (scm_call_2 (equal
, elem
, SCM_CAR (b
))))
695 goto next_elem
; /* equal to elem, so drop that elem */
697 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b
), b
, argnum
, FUNC_NAME
,"list");
700 /* elem not equal to anything in later lists, so keep it */
702 pos
= SCM_CDRLOC (lst
);
707 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
715 SCM_DEFINE (scm_srfi1_assoc
, "assoc", 2, 1, 0,
716 (SCM key
, SCM alist
, SCM pred
),
717 "Behaves like @code{assq} but uses third argument @var{pred}\n"
718 "for key comparison. If @var{pred} is not supplied,\n"
719 "@code{equal?} is used. (Extended from R5RS.)\n")
720 #define FUNC_NAME s_scm_srfi1_assoc
723 scm_t_trampoline_2 equal_p
;
724 if (SCM_UNBNDP (pred
))
725 equal_p
= equal_trampoline
;
728 SCM_VALIDATE_PROC (SCM_ARG3
, pred
);
729 equal_p
= scm_call_2
;
731 for(; scm_is_pair (ls
); ls
= SCM_CDR (ls
))
733 SCM tmp
= SCM_CAR (ls
);
734 SCM_ASSERT_TYPE (scm_is_pair (tmp
), alist
, SCM_ARG2
, FUNC_NAME
,
736 if (scm_is_true (equal_p (pred
, key
, SCM_CAR (tmp
))))
739 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls
), alist
, SCM_ARG2
, FUNC_NAME
,
745 SCM_DEFINE (scm_srfi1_partition
, "partition", 2, 0, 0,
746 (SCM pred
, SCM list
),
747 "Partition the elements of @var{list} with predicate @var{pred}.\n"
748 "Return two values: the list of elements satisfying @var{pred} and\n"
749 "the list of elements @emph{not} satisfying @var{pred}. The order\n"
750 "of the output lists follows the order of @var{list}. @var{list}\n"
751 "is not mutated. One of the output lists may share memory with @var{list}.\n")
752 #define FUNC_NAME s_scm_srfi1_partition
754 /* In this implementation, the output lists don't share memory with
755 list, because it's probably not worth the effort. */
756 SCM orig_list
= list
;
757 SCM kept
= scm_cons(SCM_EOL
, SCM_EOL
);
758 SCM kept_tail
= kept
;
759 SCM dropped
= scm_cons(SCM_EOL
, SCM_EOL
);
760 SCM dropped_tail
= dropped
;
762 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
764 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR(list
)) {
767 /* Make sure LIST is not a dotted list. */
768 SCM_ASSERT (scm_is_pair (list
), orig_list
, SCM_ARG2
, FUNC_NAME
);
770 elt
= SCM_CAR (list
);
771 new_tail
= scm_cons (SCM_CAR (list
), SCM_EOL
);
773 if (scm_is_true (scm_call_1 (pred
, elt
))) {
774 SCM_SETCDR(kept_tail
, new_tail
);
775 kept_tail
= new_tail
;
778 SCM_SETCDR(dropped_tail
, new_tail
);
779 dropped_tail
= new_tail
;
782 /* re-use the initial conses for the values list */
783 SCM_SETCAR(kept
, SCM_CDR(kept
));
784 SCM_SETCDR(kept
, dropped
);
785 SCM_SETCAR(dropped
, SCM_CDR(dropped
));
786 SCM_SETCDR(dropped
, SCM_EOL
);
787 return scm_values(kept
);
792 SCM_DEFINE (scm_srfi1_partition_x
, "partition!", 2, 0, 0,
794 "Split @var{lst} into those elements which do and don't satisfy\n"
795 "the predicate @var{pred}.\n"
797 "The return is two values (@pxref{Multiple Values}), the first\n"
798 "being a list of all elements from @var{lst} which satisfy\n"
799 "@var{pred}, the second a list of those which do not.\n"
801 "The elements in the result lists are in the same order as in\n"
802 "@var{lst} but the order in which the calls @code{(@var{pred}\n"
803 "elem)} are made on the list elements is unspecified.\n"
805 "@var{lst} may be modified to construct the return lists.")
806 #define FUNC_NAME s_scm_srfi1_partition_x
808 SCM tlst
, flst
, *tp
, *fp
;
810 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
812 /* tlst and flst are the lists of true and false elements. tp and fp are
813 where to store to append to them, initially &tlst and &flst, then
814 SCM_CDRLOC of the last pair in the respective lists. */
821 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
823 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (lst
))))
826 tp
= SCM_CDRLOC (lst
);
831 fp
= SCM_CDRLOC (lst
);
835 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
837 /* terminate whichever didn't get the last element(s) */
841 return scm_values (scm_list_2 (tlst
, flst
));
845 SCM_DEFINE (scm_srfi1_remove
, "remove", 2, 0, 0,
846 (SCM pred
, SCM list
),
847 "Return a list containing all elements from @var{list} which do\n"
848 "not satisfy the predicate @var{pred}. The elements in the\n"
849 "result list have the same order as in @var{list}. The order in\n"
850 "which @var{pred} is applied to the list elements is not\n"
852 #define FUNC_NAME s_scm_srfi1_remove
857 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
858 SCM_VALIDATE_LIST (2, list
);
860 for (prev
= &res
, walk
= list
;
862 walk
= SCM_CDR (walk
))
864 if (scm_is_false (scm_call_1 (pred
, SCM_CAR (walk
))))
866 *prev
= scm_cons (SCM_CAR (walk
), SCM_EOL
);
867 prev
= SCM_CDRLOC (*prev
);
876 SCM_DEFINE (scm_srfi1_remove_x
, "remove!", 2, 0, 0,
877 (SCM pred
, SCM list
),
878 "Return a list containing all elements from @var{list} which do\n"
879 "not satisfy the predicate @var{pred}. The elements in the\n"
880 "result list have the same order as in @var{list}. The order in\n"
881 "which @var{pred} is applied to the list elements is not\n"
882 "specified. @var{list} may be modified to build the return\n"
884 #define FUNC_NAME s_scm_srfi1_remove_x
888 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
889 SCM_VALIDATE_LIST (2, list
);
891 for (prev
= &list
, walk
= list
;
893 walk
= SCM_CDR (walk
))
895 if (scm_is_false (scm_call_1 (pred
, SCM_CAR (walk
))))
896 prev
= SCM_CDRLOC (walk
);
898 *prev
= SCM_CDR (walk
);
907 scm_register_srfi_1 (void)
909 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
911 (scm_t_extension_init_func
)scm_init_srfi_1
, NULL
);
915 scm_init_srfi_1 (void)
917 #ifndef SCM_MAGIC_SNARFER
918 #include "libguile/srfi-1.x"
922 /* End of srfi-1.c. */