1 /* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2008,2009,2010,2011
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 #include "libguile/_scm.h"
27 #include "libguile/eq.h"
29 #include "libguile/validate.h"
30 #include "libguile/list.h"
31 #include "libguile/eval.h"
38 #define SCM_I_CONS(cell, x, y) \
40 cell = scm_cell (SCM_UNPACK (x), SCM_UNPACK (y)); \
47 SCM_I_CONS (c1
, e1
, SCM_EOL
);
52 scm_list_2 (SCM e1
, SCM e2
)
55 SCM_I_CONS (c2
, e2
, SCM_EOL
);
56 SCM_I_CONS (c1
, e1
, c2
);
61 scm_list_3 (SCM e1
, SCM e2
, SCM e3
)
64 SCM_I_CONS (c3
, e3
, SCM_EOL
);
65 SCM_I_CONS (c2
, e2
, c3
);
66 SCM_I_CONS (c1
, e1
, c2
);
71 scm_list_4 (SCM e1
, SCM e2
, SCM e3
, SCM e4
)
73 return scm_cons2 (e1
, e2
, scm_list_2 (e3
, e4
));
77 scm_list_5 (SCM e1
, SCM e2
, SCM e3
, SCM e4
, SCM e5
)
79 return scm_cons2 (e1
, e2
, scm_list_3 (e3
, e4
, e5
));
83 scm_list_n (SCM elt
, ...)
90 while (! SCM_UNBNDP (elt
))
92 #if (SCM_DEBUG_CELL_ACCESSES == 1)
93 if (SCM_HEAP_OBJECT_P (elt
))
94 SCM_VALIDATE_CELL(elt
, 0);
96 *pos
= scm_cons (elt
, SCM_EOL
);
97 pos
= SCM_CDRLOC (*pos
);
98 elt
= va_arg (foo
, SCM
);
105 SCM_DEFINE (scm_make_list
, "make-list", 1, 1, 0,
107 "Create a list containing of @var{n} elements, where each\n"
108 "element is initialized to @var{init}. @var{init} defaults to\n"
109 "the empty list @code{()} if not given.")
110 #define FUNC_NAME s_scm_make_list
112 unsigned nn
= scm_to_uint (n
);
116 if (SCM_UNBNDP (init
))
119 for (i
= 0; i
< nn
; i
++)
120 ret
= scm_cons (init
, ret
);
126 SCM_DEFINE (scm_cons_star
, "cons*", 1, 0, 1,
128 "Like @code{list}, but the last arg provides the tail of the\n"
129 "constructed list, returning @code{(cons @var{arg1} (cons\n"
130 "@var{arg2} (cons @dots{} @var{argn})))}. Requires at least one\n"
131 "argument. If given one argument, that argument is returned as\n"
132 "result. This function is called @code{list*} in some other\n"
133 "Schemes and in Common LISP.")
134 #define FUNC_NAME s_scm_cons_star
139 SCM_VALIDATE_REST_ARGUMENT (rest
);
141 for ( ; scm_is_pair (rest
); rest
= SCM_CDR (rest
))
143 *p
= scm_cons (arg
, SCM_EOL
);
145 arg
= SCM_CAR (rest
);
155 /* general questions about lists --- null?, list?, length, etc. */
157 SCM_DEFINE (scm_null_p
, "null?", 1, 0, 0,
159 "Return @code{#t} iff @var{x} is the empty list, else @code{#f}.")
160 #define FUNC_NAME s_scm_null_p
162 return scm_from_bool (SCM_NULL_OR_NIL_P (x
));
167 SCM_DEFINE (scm_list_p
, "list?", 1, 0, 0,
169 "Return @code{#t} iff @var{x} is a proper list, else @code{#f}.")
170 #define FUNC_NAME s_scm_list_p
172 return scm_from_bool (scm_ilength (x
) >= 0);
177 /* Return the length of SX, or -1 if it's not a proper list.
178 This uses the "tortoise and hare" algorithm to detect "infinitely
179 long" lists (i.e. lists with cycles in their cdrs), and returns -1
180 if it does find one. */
189 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
190 if (!scm_is_pair (hare
)) return -1;
191 hare
= SCM_CDR(hare
);
193 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
194 if (!scm_is_pair (hare
)) return -1;
195 hare
= SCM_CDR(hare
);
197 /* For every two steps the hare takes, the tortoise takes one. */
198 tortoise
= SCM_CDR(tortoise
);
200 while (!scm_is_eq (hare
, tortoise
));
202 /* If the tortoise ever catches the hare, then the list must contain
208 SCM_DEFINE (scm_length
, "length", 1, 0, 0,
210 "Return the number of elements in list @var{lst}.")
211 #define FUNC_NAME s_scm_length
214 SCM_VALIDATE_LIST_COPYLEN (1, lst
, i
);
215 return scm_from_long (i
);
221 /* appending lists */
223 SCM_DEFINE (scm_append
, "append", 0, 0, 1,
225 "Return a list consisting of the elements the lists passed as\n"
228 "(append '(x) '(y)) @result{} (x y)\n"
229 "(append '(a) '(b c d)) @result{} (a b c d)\n"
230 "(append '(a (b)) '((c))) @result{} (a (b) (c))\n"
232 "The resulting list is always newly allocated, except that it\n"
233 "shares structure with the last list argument. The last\n"
234 "argument may actually be any object; an improper list results\n"
235 "if the last argument is not a proper list.\n"
237 "(append '(a b) '(c . d)) @result{} (a b c . d)\n"
238 "(append '() 'a) @result{} a\n"
240 #define FUNC_NAME s_scm_append
242 SCM_VALIDATE_REST_ARGUMENT (args
);
243 if (scm_is_null (args
)) {
248 SCM arg
= SCM_CAR (args
);
250 args
= SCM_CDR (args
);
251 while (!scm_is_null (args
)) {
252 while (scm_is_pair (arg
)) {
253 *lloc
= scm_cons (SCM_CAR (arg
), SCM_EOL
);
254 lloc
= SCM_CDRLOC (*lloc
);
257 SCM_VALIDATE_NULL_OR_NIL (argnum
, arg
);
258 arg
= SCM_CAR (args
);
259 args
= SCM_CDR (args
);
269 SCM_DEFINE (scm_append_x
, "append!", 0, 0, 1,
271 "A destructive version of @code{append} (@pxref{Pairs and\n"
272 "Lists,,,r5rs, The Revised^5 Report on Scheme}). The cdr field\n"
273 "of each list's final pair is changed to point to the head of\n"
274 "the next list, so no consing is performed. Return\n"
276 #define FUNC_NAME s_scm_append_x
280 SCM_VALIDATE_REST_ARGUMENT (args
);
282 if (scm_is_null (args
))
288 SCM arg
= SCM_CAR (args
);
291 args
= SCM_CDR (args
);
292 if (scm_is_null (args
))
295 if (!SCM_NULL_OR_NIL_P (arg
))
297 SCM_VALIDATE_CONS (argnum
, arg
);
298 loc
= SCM_CDRLOC (scm_last_pair (arg
));
299 SCM_VALIDATE_NULL_OR_NIL (argnum
, *loc
);
307 SCM_DEFINE (scm_last_pair
, "last-pair", 1, 0, 0,
309 "Return the last pair in @var{lst}, signalling an error if\n"
310 "@var{lst} is circular.")
311 #define FUNC_NAME s_scm_last_pair
316 if (SCM_NULL_OR_NIL_P (lst
))
319 SCM_VALIDATE_CONS (SCM_ARG1
, lst
);
321 SCM ahead
= SCM_CDR(hare
);
322 if (!scm_is_pair (ahead
)) return hare
;
324 ahead
= SCM_CDR(hare
);
325 if (!scm_is_pair (ahead
)) return hare
;
327 tortoise
= SCM_CDR(tortoise
);
329 while (!scm_is_eq (hare
, tortoise
));
330 SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst
));
335 /* reversing lists */
337 SCM_DEFINE (scm_reverse
, "reverse", 1, 0, 0,
339 "Return a new list that contains the elements of @var{lst} but\n"
341 #define FUNC_NAME s_scm_reverse
343 SCM result
= SCM_EOL
;
348 if (SCM_NULL_OR_NIL_P(hare
)) return result
;
349 SCM_ASSERT(scm_is_pair(hare
), lst
, 1, FUNC_NAME
);
350 result
= scm_cons (SCM_CAR (hare
), result
);
351 hare
= SCM_CDR (hare
);
352 if (SCM_NULL_OR_NIL_P(hare
)) return result
;
353 SCM_ASSERT(scm_is_pair(hare
), lst
, 1, FUNC_NAME
);
354 result
= scm_cons (SCM_CAR (hare
), result
);
355 hare
= SCM_CDR (hare
);
356 tortoise
= SCM_CDR (tortoise
);
358 while (!scm_is_eq (hare
, tortoise
));
359 SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst
));
363 SCM_DEFINE (scm_reverse_x
, "reverse!", 1, 1, 0,
364 (SCM lst
, SCM new_tail
),
365 "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r5rs,\n"
366 "The Revised^5 Report on Scheme}). The cdr of each cell in @var{lst} is\n"
367 "modified to point to the previous list element. Return the\n"
369 "Caveat: because the list is modified in place, the tail of the original\n"
370 "list now becomes its head, and the head of the original list now becomes\n"
371 "the tail. Therefore, the @var{lst} symbol to which the head of the\n"
372 "original list was bound now points to the tail. To ensure that the head\n"
373 "of the modified list is not lost, it is wise to save the return value of\n"
375 #define FUNC_NAME s_scm_reverse_x
377 SCM_VALIDATE_LIST (1, lst
);
378 if (SCM_UNBNDP (new_tail
))
381 SCM_VALIDATE_LIST (2, new_tail
);
383 while (!SCM_NULL_OR_NIL_P (lst
))
385 SCM old_tail
= SCM_CDR (lst
);
386 SCM_SETCDR (lst
, new_tail
);
396 /* indexing lists by element number */
398 SCM_DEFINE (scm_list_ref
, "list-ref", 2, 0, 0,
400 "Return the @var{k}th element from @var{list}.")
401 #define FUNC_NAME s_scm_list_ref
405 i
= scm_to_ulong (k
);
406 while (scm_is_pair (lst
)) {
408 return SCM_CAR (lst
);
414 if (SCM_NULL_OR_NIL_P (lst
))
415 SCM_OUT_OF_RANGE (2, k
);
417 SCM_WRONG_TYPE_ARG (1, list
);
422 SCM_DEFINE (scm_list_set_x
, "list-set!", 3, 0, 0,
423 (SCM list
, SCM k
, SCM val
),
424 "Set the @var{k}th element of @var{list} to @var{val}.")
425 #define FUNC_NAME s_scm_list_set_x
428 unsigned long int i
= scm_to_ulong (k
);
429 while (scm_is_pair (lst
)) {
431 SCM_SETCAR (lst
, val
);
438 if (SCM_NULL_OR_NIL_P (lst
))
439 SCM_OUT_OF_RANGE (2, k
);
441 SCM_WRONG_TYPE_ARG (1, list
);
446 SCM_REGISTER_PROC(s_list_cdr_ref
, "list-cdr-ref", 2, 0, 0, scm_list_tail
);
448 SCM_DEFINE (scm_list_tail
, "list-tail", 2, 0, 0,
450 "@deffnx {Scheme Procedure} list-cdr-ref lst k\n"
451 "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n"
452 "The first element of the list is considered to be element 0.\n\n"
453 "@code{list-tail} and @code{list-cdr-ref} are identical. It may help to\n"
454 "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\n"
455 "or returning the results of cdring @var{k} times down @var{lst}.")
456 #define FUNC_NAME s_scm_list_tail
458 size_t i
= scm_to_size_t (k
);
460 SCM_VALIDATE_CONS (1, lst
);
468 SCM_DEFINE (scm_list_cdr_set_x
, "list-cdr-set!", 3, 0, 0,
469 (SCM list
, SCM k
, SCM val
),
470 "Set the @var{k}th cdr of @var{list} to @var{val}.")
471 #define FUNC_NAME s_scm_list_cdr_set_x
474 size_t i
= scm_to_size_t (k
);
475 while (scm_is_pair (lst
)) {
477 SCM_SETCDR (lst
, val
);
484 if (SCM_NULL_OR_NIL_P (lst
))
485 SCM_OUT_OF_RANGE (2, k
);
487 SCM_WRONG_TYPE_ARG (1, list
);
493 /* copying lists, perhaps partially */
495 SCM_DEFINE (scm_list_head
, "list-head", 2, 0, 0,
497 "Copy the first @var{k} elements from @var{lst} into a new list, and\n"
499 #define FUNC_NAME s_scm_list_head
503 size_t i
= scm_to_size_t (k
);
509 SCM_VALIDATE_CONS (1, lst
);
510 *pos
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
511 pos
= SCM_CDRLOC (*pos
);
519 /* Copy a list which is known to be finite. The last pair may or may not have
520 * a '() in its cdr. That is, improper lists are accepted. */
522 scm_i_finite_list_copy (SCM list
)
524 if (!scm_is_pair (list
))
531 const SCM result
= tail
= scm_list_1 (SCM_CAR (list
));
532 list
= SCM_CDR (list
);
533 while (scm_is_pair (list
))
535 const SCM new_tail
= scm_list_1 (SCM_CAR (list
));
536 SCM_SETCDR (tail
, new_tail
);
538 list
= SCM_CDR (list
);
540 SCM_SETCDR (tail
, list
);
547 SCM_DEFINE (scm_list_copy
, "list-copy", 1, 0, 0,
549 "Return a (newly-created) copy of @var{lst}.")
550 #define FUNC_NAME s_scm_list_copy
556 SCM_VALIDATE_LIST (1, lst
);
562 while (scm_is_pair (from_here
))
565 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
567 fill_here
= SCM_CDRLOC (c
);
568 from_here
= SCM_CDR (from_here
);
575 SCM_PROC (s_list
, "list", 0, 0, 1, scm_list_copy
);
576 SCM_SNARF_DOCS (primitive
, scm_list_copy
, "list", (SCM objs
), 0, 0, 1,
577 "Return a list containing @var{objs}, the arguments to\n"
580 /* This used to be the code for "list", but it's wrong when used via apply
581 (it should copy the list). It seems pretty unlikely anyone would have
582 been using this from C code, since it's a no-op, but keep it for strict
583 binary compatibility. */
592 /* membership tests (memq, memv, etc.) */
594 /* The function scm_c_memq returns the first sublist of list whose car is
595 * 'eq?' obj, where the sublists of list are the non-empty lists returned by
596 * (list-tail list k) for k less than the length of list. If obj does not
597 * occur in list, then #f (not the empty list) is returned.
598 * List must be a proper list, otherwise scm_c_memq may crash or loop
602 scm_c_memq (SCM obj
, SCM list
)
604 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR (list
))
606 if (scm_is_eq (SCM_CAR (list
), obj
))
613 SCM_DEFINE (scm_memq
, "memq", 2, 0, 0,
615 "Return the first sublist of @var{lst} whose car is @code{eq?}\n"
616 "to @var{x} where the sublists of @var{lst} are the non-empty\n"
617 "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
618 "@var{k} less than the length of @var{lst}. If @var{x} does not\n"
619 "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
621 #define FUNC_NAME s_scm_memq
623 SCM hare
= lst
, tortoise
= lst
;
625 while (scm_is_pair (hare
))
627 if (scm_is_eq (SCM_CAR (hare
), x
))
630 hare
= SCM_CDR (hare
);
632 if (!scm_is_pair (hare
))
635 if (scm_is_eq (SCM_CAR (hare
), x
))
638 hare
= SCM_CDR (hare
);
640 tortoise
= SCM_CDR (tortoise
);
641 if (SCM_UNLIKELY (scm_is_eq (hare
, tortoise
)))
645 if (SCM_LIKELY (scm_is_null (hare
)))
648 scm_wrong_type_arg_msg (FUNC_NAME
, 2, lst
, "list");
653 SCM_DEFINE (scm_memv
, "memv", 2, 0, 0,
655 "Return the first sublist of @var{lst} whose car is @code{eqv?}\n"
656 "to @var{x} where the sublists of @var{lst} are the non-empty\n"
657 "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
658 "@var{k} less than the length of @var{lst}. If @var{x} does not\n"
659 "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
661 #define FUNC_NAME s_scm_memv
663 SCM hare
= lst
, tortoise
= lst
;
665 while (scm_is_pair (hare
))
667 if (scm_is_true (scm_eqv_p (SCM_CAR (hare
), x
)))
670 hare
= SCM_CDR (hare
);
672 if (!scm_is_pair (hare
))
675 if (scm_is_true (scm_eqv_p (SCM_CAR (hare
), x
)))
678 hare
= SCM_CDR (hare
);
680 tortoise
= SCM_CDR (tortoise
);
681 if (SCM_UNLIKELY (scm_is_eq (hare
, tortoise
)))
685 if (SCM_LIKELY (scm_is_null (hare
)))
688 scm_wrong_type_arg_msg (FUNC_NAME
, 2, lst
, "list");
693 SCM_DEFINE (scm_member
, "member", 2, 0, 0,
695 "Return the first sublist of @var{lst} whose car is\n"
696 "@code{equal?} to @var{x} where the sublists of @var{lst} are\n"
697 "the non-empty lists returned by @code{(list-tail @var{lst}\n"
698 "@var{k})} for @var{k} less than the length of @var{lst}. If\n"
699 "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n"
700 "empty list) is returned.")
701 #define FUNC_NAME s_scm_member
703 SCM_VALIDATE_LIST (2, lst
);
704 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
706 if (! scm_is_false (scm_equal_p (SCM_CAR (lst
), x
)))
714 /* deleting elements from a list (delq, etc.) */
716 SCM_DEFINE (scm_delq_x
, "delq!", 2, 0, 0,
718 "@deffnx {Scheme Procedure} delv! item lst\n"
719 "@deffnx {Scheme Procedure} delete! item lst\n"
720 "These procedures are destructive versions of @code{delq}, @code{delv}\n"
721 "and @code{delete}: they modify the existing @var{lst}\n"
722 "rather than creating a new list. Caveat evaluator: Like other\n"
723 "destructive list functions, these functions cannot modify the binding of\n"
724 "@var{lst}, and so cannot be used to delete the first element of\n"
725 "@var{lst} destructively.")
726 #define FUNC_NAME s_scm_delq_x
731 for (prev
= &lst
, walk
= lst
;
733 walk
= SCM_CDR (walk
))
735 if (scm_is_eq (SCM_CAR (walk
), item
))
736 *prev
= SCM_CDR (walk
);
738 prev
= SCM_CDRLOC (walk
);
746 SCM_DEFINE (scm_delv_x
, "delv!", 2, 0, 0,
748 "Destructively remove all elements from @var{lst} that are\n"
749 "@code{eqv?} to @var{item}.")
750 #define FUNC_NAME s_scm_delv_x
755 for (prev
= &lst
, walk
= lst
;
757 walk
= SCM_CDR (walk
))
759 if (! scm_is_false (scm_eqv_p (SCM_CAR (walk
), item
)))
760 *prev
= SCM_CDR (walk
);
762 prev
= SCM_CDRLOC (walk
);
771 SCM_DEFINE (scm_delete_x
, "delete!", 2, 0, 0,
773 "Destructively remove all elements from @var{lst} that are\n"
774 "@code{equal?} to @var{item}.")
775 #define FUNC_NAME s_scm_delete_x
780 for (prev
= &lst
, walk
= lst
;
782 walk
= SCM_CDR (walk
))
784 if (! scm_is_false (scm_equal_p (SCM_CAR (walk
), item
)))
785 *prev
= SCM_CDR (walk
);
787 prev
= SCM_CDRLOC (walk
);
798 SCM_DEFINE (scm_delq
, "delq", 2, 0, 0,
800 "Return a newly-created copy of @var{lst} with elements\n"
801 "@code{eq?} to @var{item} removed. This procedure mirrors\n"
802 "@code{memq}: @code{delq} compares elements of @var{lst} against\n"
803 "@var{item} with @code{eq?}.")
804 #define FUNC_NAME s_scm_delq
806 SCM copy
= scm_list_copy (lst
);
807 return scm_delq_x (item
, copy
);
811 SCM_DEFINE (scm_delv
, "delv", 2, 0, 0,
813 "Return a newly-created copy of @var{lst} with elements\n"
814 "@code{eqv?} to @var{item} removed. This procedure mirrors\n"
815 "@code{memv}: @code{delv} compares elements of @var{lst} against\n"
816 "@var{item} with @code{eqv?}.")
817 #define FUNC_NAME s_scm_delv
819 SCM copy
= scm_list_copy (lst
);
820 return scm_delv_x (item
, copy
);
824 SCM_DEFINE (scm_delete
, "delete", 2, 0, 0,
826 "Return a newly-created copy of @var{lst} with elements\n"
827 "@code{equal?} to @var{item} removed. This procedure mirrors\n"
828 "@code{member}: @code{delete} compares elements of @var{lst}\n"
829 "against @var{item} with @code{equal?}.")
830 #define FUNC_NAME s_scm_delete
832 SCM copy
= scm_list_copy (lst
);
833 return scm_delete_x (item
, copy
);
838 SCM_DEFINE (scm_delq1_x
, "delq1!", 2, 0, 0,
840 "Like @code{delq!}, but only deletes the first occurrence of\n"
841 "@var{item} from @var{lst}. Tests for equality using\n"
842 "@code{eq?}. See also @code{delv1!} and @code{delete1!}.")
843 #define FUNC_NAME s_scm_delq1_x
848 for (prev
= &lst
, walk
= lst
;
850 walk
= SCM_CDR (walk
))
852 if (scm_is_eq (SCM_CAR (walk
), item
))
854 *prev
= SCM_CDR (walk
);
858 prev
= SCM_CDRLOC (walk
);
866 SCM_DEFINE (scm_delv1_x
, "delv1!", 2, 0, 0,
868 "Like @code{delv!}, but only deletes the first occurrence of\n"
869 "@var{item} from @var{lst}. Tests for equality using\n"
870 "@code{eqv?}. See also @code{delq1!} and @code{delete1!}.")
871 #define FUNC_NAME s_scm_delv1_x
876 for (prev
= &lst
, walk
= lst
;
878 walk
= SCM_CDR (walk
))
880 if (! scm_is_false (scm_eqv_p (SCM_CAR (walk
), item
)))
882 *prev
= SCM_CDR (walk
);
886 prev
= SCM_CDRLOC (walk
);
894 SCM_DEFINE (scm_delete1_x
, "delete1!", 2, 0, 0,
896 "Like @code{delete!}, but only deletes the first occurrence of\n"
897 "@var{item} from @var{lst}. Tests for equality using\n"
898 "@code{equal?}. See also @code{delq1!} and @code{delv1!}.")
899 #define FUNC_NAME s_scm_delete1_x
904 for (prev
= &lst
, walk
= lst
;
906 walk
= SCM_CDR (walk
))
908 if (! scm_is_false (scm_equal_p (SCM_CAR (walk
), item
)))
910 *prev
= SCM_CDR (walk
);
914 prev
= SCM_CDRLOC (walk
);
921 SCM_DEFINE (scm_filter
, "filter", 2, 0, 0,
922 (SCM pred
, SCM list
),
923 "Return all the elements of 2nd arg @var{list} that satisfy predicate @var{pred}.\n"
924 "The list is not disordered -- elements that appear in the result list occur\n"
925 "in the same order as they occur in the argument list. The returned list may\n"
926 "share a common tail with the argument list. The dynamic order in which the\n"
927 "various applications of pred are made is not specified.\n\n"
929 "(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)\n"
931 #define FUNC_NAME s_scm_filter
936 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, 1, FUNC_NAME
);
937 SCM_VALIDATE_LIST (2, list
);
939 for (prev
= &res
, walk
= list
;
941 walk
= SCM_CDR (walk
))
943 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (walk
))))
945 *prev
= scm_cons (SCM_CAR (walk
), SCM_EOL
);
946 prev
= SCM_CDRLOC (*prev
);
954 SCM_DEFINE (scm_filter_x
, "filter!", 2, 0, 0,
955 (SCM pred
, SCM list
),
956 "Linear-update variant of @code{filter}.")
957 #define FUNC_NAME s_scm_filter_x
961 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, 1, FUNC_NAME
);
962 SCM_VALIDATE_LIST (2, list
);
964 for (prev
= &list
, walk
= list
;
966 walk
= SCM_CDR (walk
))
968 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (walk
))))
969 prev
= SCM_CDRLOC (walk
);
971 *prev
= SCM_CDR (walk
);
982 #include "libguile/list.x"