1 /* Copyright (C) 1995-1997, 2000, 2001, 2003, 2004, 2008-2011,
2 * 2014 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. */
190 if (!scm_is_pair (hare
))
191 return SCM_NULL_OR_NIL_P (hare
) ? i
: -1;
192 hare
= SCM_CDR (hare
);
194 if (!scm_is_pair (hare
))
195 return SCM_NULL_OR_NIL_P (hare
) ? i
: -1;
196 hare
= SCM_CDR (hare
);
198 /* For every two steps the hare takes, the tortoise takes one. */
199 tortoise
= SCM_CDR (tortoise
);
201 while (!scm_is_eq (hare
, tortoise
));
203 /* If the tortoise ever catches the hare, then the list must contain
209 SCM_DEFINE (scm_length
, "length", 1, 0, 0,
211 "Return the number of elements in list @var{lst}.")
212 #define FUNC_NAME s_scm_length
215 SCM_VALIDATE_LIST_COPYLEN (1, lst
, i
);
216 return scm_from_long (i
);
222 /* appending lists */
224 SCM_DEFINE (scm_append
, "append", 0, 0, 1,
226 "Return a list consisting of the elements the lists passed as\n"
229 "(append '(x) '(y)) @result{} (x y)\n"
230 "(append '(a) '(b c d)) @result{} (a b c d)\n"
231 "(append '(a (b)) '((c))) @result{} (a (b) (c))\n"
233 "The resulting list is always newly allocated, except that it\n"
234 "shares structure with the last list argument. The last\n"
235 "argument may actually be any object; an improper list results\n"
236 "if the last argument is not a proper list.\n"
238 "(append '(a b) '(c . d)) @result{} (a b c . d)\n"
239 "(append '() 'a) @result{} a\n"
241 #define FUNC_NAME s_scm_append
243 SCM_VALIDATE_REST_ARGUMENT (args
);
244 if (scm_is_null (args
)) {
249 SCM arg
= SCM_CAR (args
);
251 args
= SCM_CDR (args
);
252 while (!scm_is_null (args
)) {
253 while (scm_is_pair (arg
)) {
254 *lloc
= scm_cons (SCM_CAR (arg
), SCM_EOL
);
255 lloc
= SCM_CDRLOC (*lloc
);
258 SCM_VALIDATE_NULL_OR_NIL (argnum
, arg
);
259 arg
= SCM_CAR (args
);
260 args
= SCM_CDR (args
);
270 SCM_DEFINE (scm_append_x
, "append!", 0, 0, 1,
272 "A destructive version of @code{append} (@pxref{Pairs and\n"
273 "Lists,,,r5rs, The Revised^5 Report on Scheme}). The cdr field\n"
274 "of each list's final pair is changed to point to the head of\n"
275 "the next list, so no consing is performed. Return\n"
277 #define FUNC_NAME s_scm_append_x
281 SCM_VALIDATE_REST_ARGUMENT (args
);
283 if (scm_is_null (args
))
289 SCM arg
= SCM_CAR (args
);
292 args
= SCM_CDR (args
);
293 if (scm_is_null (args
))
296 if (!SCM_NULL_OR_NIL_P (arg
))
298 SCM_VALIDATE_CONS (argnum
, arg
);
299 loc
= SCM_CDRLOC (scm_last_pair (arg
));
300 SCM_VALIDATE_NULL_OR_NIL (argnum
, *loc
);
308 SCM_DEFINE (scm_last_pair
, "last-pair", 1, 0, 0,
310 "Return the last pair in @var{lst}, signalling an error if\n"
311 "@var{lst} is circular.")
312 #define FUNC_NAME s_scm_last_pair
317 if (SCM_NULL_OR_NIL_P (lst
))
320 SCM_VALIDATE_CONS (SCM_ARG1
, lst
);
322 SCM ahead
= SCM_CDR(hare
);
323 if (!scm_is_pair (ahead
)) return hare
;
325 ahead
= SCM_CDR(hare
);
326 if (!scm_is_pair (ahead
)) return hare
;
328 tortoise
= SCM_CDR(tortoise
);
330 while (!scm_is_eq (hare
, tortoise
));
331 SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst
));
336 /* reversing lists */
338 SCM_DEFINE (scm_reverse
, "reverse", 1, 0, 0,
340 "Return a new list that contains the elements of @var{lst} but\n"
342 #define FUNC_NAME s_scm_reverse
344 SCM result
= SCM_EOL
;
349 if (SCM_NULL_OR_NIL_P(hare
)) return result
;
350 SCM_ASSERT(scm_is_pair(hare
), lst
, 1, FUNC_NAME
);
351 result
= scm_cons (SCM_CAR (hare
), result
);
352 hare
= SCM_CDR (hare
);
353 if (SCM_NULL_OR_NIL_P(hare
)) return result
;
354 SCM_ASSERT(scm_is_pair(hare
), lst
, 1, FUNC_NAME
);
355 result
= scm_cons (SCM_CAR (hare
), result
);
356 hare
= SCM_CDR (hare
);
357 tortoise
= SCM_CDR (tortoise
);
359 while (!scm_is_eq (hare
, tortoise
));
360 SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst
));
364 SCM_DEFINE (scm_reverse_x
, "reverse!", 1, 1, 0,
365 (SCM lst
, SCM new_tail
),
366 "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r5rs,\n"
367 "The Revised^5 Report on Scheme}). The cdr of each cell in @var{lst} is\n"
368 "modified to point to the previous list element. Return the\n"
370 "Caveat: because the list is modified in place, the tail of the original\n"
371 "list now becomes its head, and the head of the original list now becomes\n"
372 "the tail. Therefore, the @var{lst} symbol to which the head of the\n"
373 "original list was bound now points to the tail. To ensure that the head\n"
374 "of the modified list is not lost, it is wise to save the return value of\n"
376 #define FUNC_NAME s_scm_reverse_x
379 SCM tail
= SCM_BOOL_F
;
381 if (SCM_UNBNDP (new_tail
))
384 if (SCM_NULL_OR_NIL_P (lst
))
387 /* SCM_VALIDATE_LIST would run through the whole list to make sure it
388 is not eventually circular. In contrast to most list operations,
389 reverse! cannot get stuck in an infinite loop but arrives back at
390 the start when given an eventually or fully circular list. Because
391 of that, we can save the cost of an upfront proper list check at
392 the price of having to do a double reversal in the error case.
395 while (scm_is_pair (lst
))
397 SCM old_tail
= SCM_CDR (lst
);
398 SCM_SETCDR (lst
, tail
);
403 if (SCM_LIKELY (SCM_NULL_OR_NIL_P (lst
)))
405 SCM_SETCDR (old_lst
, new_tail
);
409 /* We did not start with a proper list. Undo the reversal. */
411 while (scm_is_pair (tail
))
413 SCM old_tail
= SCM_CDR (tail
);
414 SCM_SETCDR (tail
, lst
);
419 SCM_WRONG_TYPE_ARG (1, lst
);
426 /* indexing lists by element number */
428 SCM_DEFINE (scm_list_ref
, "list-ref", 2, 0, 0,
430 "Return the @var{k}th element from @var{list}.")
431 #define FUNC_NAME s_scm_list_ref
435 i
= scm_to_ulong (k
);
436 while (scm_is_pair (lst
)) {
438 return SCM_CAR (lst
);
444 if (SCM_NULL_OR_NIL_P (lst
))
445 SCM_OUT_OF_RANGE (2, k
);
447 SCM_WRONG_TYPE_ARG (1, list
);
452 SCM_DEFINE (scm_list_set_x
, "list-set!", 3, 0, 0,
453 (SCM list
, SCM k
, SCM val
),
454 "Set the @var{k}th element of @var{list} to @var{val}.")
455 #define FUNC_NAME s_scm_list_set_x
458 unsigned long int i
= scm_to_ulong (k
);
459 while (scm_is_pair (lst
)) {
461 SCM_SETCAR (lst
, val
);
468 if (SCM_NULL_OR_NIL_P (lst
))
469 SCM_OUT_OF_RANGE (2, k
);
471 SCM_WRONG_TYPE_ARG (1, list
);
476 SCM_REGISTER_PROC(s_list_cdr_ref
, "list-cdr-ref", 2, 0, 0, scm_list_tail
);
478 SCM_DEFINE (scm_list_tail
, "list-tail", 2, 0, 0,
480 "@deffnx {Scheme Procedure} list-cdr-ref lst k\n"
481 "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n"
482 "The first element of the list is considered to be element 0.\n\n"
483 "@code{list-tail} and @code{list-cdr-ref} are identical. It may help to\n"
484 "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\n"
485 "or returning the results of cdring @var{k} times down @var{lst}.")
486 #define FUNC_NAME s_scm_list_tail
488 size_t i
= scm_to_size_t (k
);
490 SCM_VALIDATE_CONS (1, lst
);
498 SCM_DEFINE (scm_list_cdr_set_x
, "list-cdr-set!", 3, 0, 0,
499 (SCM list
, SCM k
, SCM val
),
500 "Set the @var{k}th cdr of @var{list} to @var{val}.")
501 #define FUNC_NAME s_scm_list_cdr_set_x
504 size_t i
= scm_to_size_t (k
);
505 while (scm_is_pair (lst
)) {
507 SCM_SETCDR (lst
, val
);
514 if (SCM_NULL_OR_NIL_P (lst
))
515 SCM_OUT_OF_RANGE (2, k
);
517 SCM_WRONG_TYPE_ARG (1, list
);
523 /* copying lists, perhaps partially */
525 SCM_DEFINE (scm_list_head
, "list-head", 2, 0, 0,
527 "Copy the first @var{k} elements from @var{lst} into a new list, and\n"
529 #define FUNC_NAME s_scm_list_head
533 size_t i
= scm_to_size_t (k
);
539 SCM_VALIDATE_CONS (1, lst
);
540 *pos
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
541 pos
= SCM_CDRLOC (*pos
);
549 /* Copy a list which is known to be finite. The last pair may or may not have
550 * a '() in its cdr. That is, improper lists are accepted. */
552 scm_i_finite_list_copy (SCM list
)
554 if (!scm_is_pair (list
))
561 const SCM result
= tail
= scm_list_1 (SCM_CAR (list
));
562 list
= SCM_CDR (list
);
563 while (scm_is_pair (list
))
565 const SCM new_tail
= scm_list_1 (SCM_CAR (list
));
566 SCM_SETCDR (tail
, new_tail
);
568 list
= SCM_CDR (list
);
570 SCM_SETCDR (tail
, list
);
577 SCM_DEFINE (scm_list_copy
, "list-copy", 1, 0, 0,
579 "Return a (newly-created) copy of @var{lst}.")
580 #define FUNC_NAME s_scm_list_copy
586 SCM_VALIDATE_LIST (1, lst
);
592 while (scm_is_pair (from_here
))
595 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
597 fill_here
= SCM_CDRLOC (c
);
598 from_here
= SCM_CDR (from_here
);
605 SCM_PROC (s_list
, "list", 0, 0, 1, scm_list_copy
);
606 SCM_SNARF_DOCS (primitive
, scm_list_copy
, "list", (SCM objs
), 0, 0, 1,
607 "Return a list containing @var{objs}, the arguments to\n"
610 /* This used to be the code for "list", but it's wrong when used via apply
611 (it should copy the list). It seems pretty unlikely anyone would have
612 been using this from C code, since it's a no-op, but keep it for strict
613 binary compatibility. */
622 /* membership tests (memq, memv, etc.) */
624 /* The function scm_c_memq returns the first sublist of list whose car is
625 * 'eq?' obj, where the sublists of list are the non-empty lists returned by
626 * (list-tail list k) for k less than the length of list. If obj does not
627 * occur in list, then #f (not the empty list) is returned.
628 * List must be a proper list, otherwise scm_c_memq may crash or loop
632 scm_c_memq (SCM obj
, SCM list
)
634 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR (list
))
636 if (scm_is_eq (SCM_CAR (list
), obj
))
643 SCM_DEFINE (scm_memq
, "memq", 2, 0, 0,
645 "Return the first sublist of @var{lst} whose car is @code{eq?}\n"
646 "to @var{x} where the sublists of @var{lst} are the non-empty\n"
647 "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
648 "@var{k} less than the length of @var{lst}. If @var{x} does not\n"
649 "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
651 #define FUNC_NAME s_scm_memq
653 SCM hare
= lst
, tortoise
= lst
;
655 while (scm_is_pair (hare
))
657 if (scm_is_eq (SCM_CAR (hare
), x
))
660 hare
= SCM_CDR (hare
);
662 if (!scm_is_pair (hare
))
665 if (scm_is_eq (SCM_CAR (hare
), x
))
668 hare
= SCM_CDR (hare
);
670 tortoise
= SCM_CDR (tortoise
);
671 if (SCM_UNLIKELY (scm_is_eq (hare
, tortoise
)))
675 if (SCM_LIKELY (scm_is_null (hare
)))
678 scm_wrong_type_arg_msg (FUNC_NAME
, 2, lst
, "list");
683 SCM_DEFINE (scm_memv
, "memv", 2, 0, 0,
685 "Return the first sublist of @var{lst} whose car is @code{eqv?}\n"
686 "to @var{x} where the sublists of @var{lst} are the non-empty\n"
687 "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
688 "@var{k} less than the length of @var{lst}. If @var{x} does not\n"
689 "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
691 #define FUNC_NAME s_scm_memv
693 SCM hare
= lst
, tortoise
= lst
;
695 while (scm_is_pair (hare
))
697 if (scm_is_true (scm_eqv_p (SCM_CAR (hare
), x
)))
700 hare
= SCM_CDR (hare
);
702 if (!scm_is_pair (hare
))
705 if (scm_is_true (scm_eqv_p (SCM_CAR (hare
), x
)))
708 hare
= SCM_CDR (hare
);
710 tortoise
= SCM_CDR (tortoise
);
711 if (SCM_UNLIKELY (scm_is_eq (hare
, tortoise
)))
715 if (SCM_LIKELY (scm_is_null (hare
)))
718 scm_wrong_type_arg_msg (FUNC_NAME
, 2, lst
, "list");
723 SCM_DEFINE (scm_member
, "member", 2, 0, 0,
725 "Return the first sublist of @var{lst} whose car is\n"
726 "@code{equal?} to @var{x} where the sublists of @var{lst} are\n"
727 "the non-empty lists returned by @code{(list-tail @var{lst}\n"
728 "@var{k})} for @var{k} less than the length of @var{lst}. If\n"
729 "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n"
730 "empty list) is returned.")
731 #define FUNC_NAME s_scm_member
733 SCM_VALIDATE_LIST (2, lst
);
734 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
736 if (! scm_is_false (scm_equal_p (SCM_CAR (lst
), x
)))
744 /* deleting elements from a list (delq, etc.) */
746 SCM_DEFINE (scm_delq_x
, "delq!", 2, 0, 0,
748 "@deffnx {Scheme Procedure} delv! item lst\n"
749 "@deffnx {Scheme Procedure} delete! item lst\n"
750 "These procedures are destructive versions of @code{delq}, @code{delv}\n"
751 "and @code{delete}: they modify the existing @var{lst}\n"
752 "rather than creating a new list. Caveat evaluator: Like other\n"
753 "destructive list functions, these functions cannot modify the binding of\n"
754 "@var{lst}, and so cannot be used to delete the first element of\n"
755 "@var{lst} destructively.")
756 #define FUNC_NAME s_scm_delq_x
761 for (prev
= &lst
, walk
= lst
;
763 walk
= SCM_CDR (walk
))
765 if (scm_is_eq (SCM_CAR (walk
), item
))
766 *prev
= SCM_CDR (walk
);
768 prev
= SCM_CDRLOC (walk
);
776 SCM_DEFINE (scm_delv_x
, "delv!", 2, 0, 0,
778 "Destructively remove all elements from @var{lst} that are\n"
779 "@code{eqv?} to @var{item}.")
780 #define FUNC_NAME s_scm_delv_x
785 for (prev
= &lst
, walk
= lst
;
787 walk
= SCM_CDR (walk
))
789 if (! scm_is_false (scm_eqv_p (SCM_CAR (walk
), item
)))
790 *prev
= SCM_CDR (walk
);
792 prev
= SCM_CDRLOC (walk
);
801 SCM_DEFINE (scm_delete_x
, "delete!", 2, 0, 0,
803 "Destructively remove all elements from @var{lst} that are\n"
804 "@code{equal?} to @var{item}.")
805 #define FUNC_NAME s_scm_delete_x
810 for (prev
= &lst
, walk
= lst
;
812 walk
= SCM_CDR (walk
))
814 if (! scm_is_false (scm_equal_p (SCM_CAR (walk
), item
)))
815 *prev
= SCM_CDR (walk
);
817 prev
= SCM_CDRLOC (walk
);
828 SCM_DEFINE (scm_delq
, "delq", 2, 0, 0,
830 "Return a newly-created copy of @var{lst} with elements\n"
831 "@code{eq?} to @var{item} removed. This procedure mirrors\n"
832 "@code{memq}: @code{delq} compares elements of @var{lst} against\n"
833 "@var{item} with @code{eq?}.")
834 #define FUNC_NAME s_scm_delq
836 SCM copy
= scm_list_copy (lst
);
837 return scm_delq_x (item
, copy
);
841 SCM_DEFINE (scm_delv
, "delv", 2, 0, 0,
843 "Return a newly-created copy of @var{lst} with elements\n"
844 "@code{eqv?} to @var{item} removed. This procedure mirrors\n"
845 "@code{memv}: @code{delv} compares elements of @var{lst} against\n"
846 "@var{item} with @code{eqv?}.")
847 #define FUNC_NAME s_scm_delv
849 SCM copy
= scm_list_copy (lst
);
850 return scm_delv_x (item
, copy
);
854 SCM_DEFINE (scm_delete
, "delete", 2, 0, 0,
856 "Return a newly-created copy of @var{lst} with elements\n"
857 "@code{equal?} to @var{item} removed. This procedure mirrors\n"
858 "@code{member}: @code{delete} compares elements of @var{lst}\n"
859 "against @var{item} with @code{equal?}.")
860 #define FUNC_NAME s_scm_delete
862 SCM copy
= scm_list_copy (lst
);
863 return scm_delete_x (item
, copy
);
868 SCM_DEFINE (scm_delq1_x
, "delq1!", 2, 0, 0,
870 "Like @code{delq!}, but only deletes the first occurrence of\n"
871 "@var{item} from @var{lst}. Tests for equality using\n"
872 "@code{eq?}. See also @code{delv1!} and @code{delete1!}.")
873 #define FUNC_NAME s_scm_delq1_x
878 for (prev
= &lst
, walk
= lst
;
880 walk
= SCM_CDR (walk
))
882 if (scm_is_eq (SCM_CAR (walk
), item
))
884 *prev
= SCM_CDR (walk
);
888 prev
= SCM_CDRLOC (walk
);
896 SCM_DEFINE (scm_delv1_x
, "delv1!", 2, 0, 0,
898 "Like @code{delv!}, but only deletes the first occurrence of\n"
899 "@var{item} from @var{lst}. Tests for equality using\n"
900 "@code{eqv?}. See also @code{delq1!} and @code{delete1!}.")
901 #define FUNC_NAME s_scm_delv1_x
906 for (prev
= &lst
, walk
= lst
;
908 walk
= SCM_CDR (walk
))
910 if (! scm_is_false (scm_eqv_p (SCM_CAR (walk
), item
)))
912 *prev
= SCM_CDR (walk
);
916 prev
= SCM_CDRLOC (walk
);
924 SCM_DEFINE (scm_delete1_x
, "delete1!", 2, 0, 0,
926 "Like @code{delete!}, but only deletes the first occurrence of\n"
927 "@var{item} from @var{lst}. Tests for equality using\n"
928 "@code{equal?}. See also @code{delq1!} and @code{delv1!}.")
929 #define FUNC_NAME s_scm_delete1_x
934 for (prev
= &lst
, walk
= lst
;
936 walk
= SCM_CDR (walk
))
938 if (! scm_is_false (scm_equal_p (SCM_CAR (walk
), item
)))
940 *prev
= SCM_CDR (walk
);
944 prev
= SCM_CDRLOC (walk
);
951 SCM_DEFINE (scm_filter
, "filter", 2, 0, 0,
952 (SCM pred
, SCM list
),
953 "Return all the elements of 2nd arg @var{list} that satisfy predicate @var{pred}.\n"
954 "The list is not disordered -- elements that appear in the result list occur\n"
955 "in the same order as they occur in the argument list. The returned list may\n"
956 "share a common tail with the argument list. The dynamic order in which the\n"
957 "various applications of pred are made is not specified.\n\n"
959 "(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)\n"
961 #define FUNC_NAME s_scm_filter
966 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, 1, FUNC_NAME
);
967 SCM_VALIDATE_LIST (2, list
);
969 for (prev
= &res
, walk
= list
;
971 walk
= SCM_CDR (walk
))
973 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (walk
))))
975 *prev
= scm_cons (SCM_CAR (walk
), SCM_EOL
);
976 prev
= SCM_CDRLOC (*prev
);
984 SCM_DEFINE (scm_filter_x
, "filter!", 2, 0, 0,
985 (SCM pred
, SCM list
),
986 "Linear-update variant of @code{filter}.")
987 #define FUNC_NAME s_scm_filter_x
991 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, 1, FUNC_NAME
);
992 SCM_VALIDATE_LIST (2, list
);
994 for (prev
= &list
, walk
= list
;
996 walk
= SCM_CDR (walk
))
998 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (walk
))))
999 prev
= SCM_CDRLOC (walk
);
1001 *prev
= SCM_CDR (walk
);
1012 #include "libguile/list.x"