1 /* srfi-1.c --- SRFI-1 procedures for Guile
3 * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006, 2008, 2009, 2010
4 * 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_alist_copy
, "alist-copy", 1, 0, 0,
109 "Return a copy of @var{alist}, copying both the pairs comprising\n"
110 "the list and those making the associations.")
111 #define FUNC_NAME s_scm_srfi1_alist_copy
113 SCM ret
, *p
, elem
, c
;
115 /* ret is the list to return. p is where to append to it, initially &ret
116 then SCM_CDRLOC of the last pair. */
120 for ( ; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
122 elem
= SCM_CAR (alist
);
124 /* each element of alist must be a pair */
125 SCM_ASSERT_TYPE (scm_is_pair (elem
), alist
, SCM_ARG1
, FUNC_NAME
,
128 c
= scm_cons (scm_cons (SCM_CAR (elem
), SCM_CDR (elem
)), SCM_EOL
);
133 /* alist must be a proper list */
134 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (alist
), alist
, SCM_ARG1
, FUNC_NAME
,
142 SCM_DEFINE (scm_srfi1_append_reverse
, "append-reverse", 2, 0, 0,
143 (SCM revhead
, SCM tail
),
144 "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
145 "result. This is equivalent to @code{(append (reverse\n"
146 "@var{rev-head}) @var{tail})}, but its implementation is more\n"
150 "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
152 #define FUNC_NAME s_scm_srfi1_append_reverse
154 while (scm_is_pair (revhead
))
156 /* copy first element of revhead onto front of tail */
157 tail
= scm_cons (SCM_CAR (revhead
), tail
);
158 revhead
= SCM_CDR (revhead
);
160 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead
), revhead
, SCM_ARG1
, FUNC_NAME
,
167 SCM_DEFINE (scm_srfi1_append_reverse_x
, "append-reverse!", 2, 0, 0,
168 (SCM revhead
, SCM tail
),
169 "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
170 "result. This is equivalent to @code{(append! (reverse!\n"
171 "@var{rev-head}) @var{tail})}, but its implementation is more\n"
175 "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
178 "@var{rev-head} may be modified in order to produce the result.")
179 #define FUNC_NAME s_scm_srfi1_append_reverse_x
183 while (scm_is_pair (revhead
))
185 /* take the first cons cell from revhead */
187 revhead
= SCM_CDR (revhead
);
189 /* make it the new start of tail, appending the previous */
190 SCM_SETCDR (newtail
, tail
);
193 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead
), revhead
, SCM_ARG1
, FUNC_NAME
,
199 SCM_DEFINE (scm_srfi1_concatenate
, "concatenate", 1, 0, 0,
201 "Construct a list by appending all lists in @var{lstlst}.\n"
203 "@code{concatenate} is the same as @code{(apply append\n"
204 "@var{lstlst})}. It exists because some Scheme implementations\n"
205 "have a limit on the number of arguments a function takes, which\n"
206 "the @code{apply} might exceed. In Guile there is no such\n"
208 #define FUNC_NAME s_scm_srfi1_concatenate
210 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
211 return scm_append (lstlst
);
216 SCM_DEFINE (scm_srfi1_concatenate_x
, "concatenate!", 1, 0, 0,
218 "Construct a list by appending all lists in @var{lstlst}. Those\n"
219 "lists may be modified to produce the result.\n"
221 "@code{concatenate!} is the same as @code{(apply append!\n"
222 "@var{lstlst})}. It exists because some Scheme implementations\n"
223 "have a limit on the number of arguments a function takes, which\n"
224 "the @code{apply} might exceed. In Guile there is no such\n"
226 #define FUNC_NAME s_scm_srfi1_concatenate
228 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
229 return scm_append_x (lstlst
);
234 SCM_DEFINE (scm_srfi1_count
, "count", 2, 0, 1,
235 (SCM pred
, SCM list1
, SCM rest
),
236 "Return a count of the number of times @var{pred} returns true\n"
237 "when called on elements from the given lists.\n"
239 "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
240 "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
241 "corresponding @var{list1} @dots{} @var{lstN}. The first call is\n"
242 "with the first element of each list, the second with the second\n"
243 "element from each, and so on.\n"
245 "Counting stops when the end of the shortest list is reached.\n"
246 "At least one list must be non-circular.")
247 #define FUNC_NAME s_scm_srfi1_count
252 SCM_VALIDATE_REST_ARGUMENT (rest
);
256 if (scm_is_null (rest
))
259 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
261 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
262 count
+= scm_is_true (scm_call_1 (pred
, SCM_CAR (list1
)));
264 /* check below that list1 is a proper list, and done */
269 else if (scm_is_pair (rest
) && scm_is_null (SCM_CDR (rest
)))
274 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
276 list2
= SCM_CAR (rest
);
279 if (! scm_is_pair (list1
))
281 if (! scm_is_pair (list2
))
287 count
+= scm_is_true (scm_call_2
288 (pred
, SCM_CAR (list1
), SCM_CAR (list2
)));
289 list1
= SCM_CDR (list1
);
290 list2
= SCM_CDR (list2
);
295 /* three or more lists */
299 /* vec is the list arguments */
300 vec
= scm_vector (scm_cons (list1
, rest
));
301 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
303 /* args is the argument list to pass to pred, same length as vec,
304 re-used for each call */
305 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
309 /* first elem of each list in vec into args, and step those
310 vec entries onto their next element */
311 for (i
= 0, a
= args
, argnum
= 2;
313 i
++, a
= SCM_CDR (a
), argnum
++)
315 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
316 if (! scm_is_pair (lst
))
317 goto check_lst_and_done
;
318 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for pred */
319 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
322 count
+= scm_is_true (scm_apply (pred
, args
, SCM_EOL
));
327 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
328 return scm_from_long (count
);
333 SCM_DEFINE (scm_srfi1_delete
, "delete", 2, 1, 0,
334 (SCM x
, SCM lst
, SCM pred
),
335 "Return a list containing the elements of @var{lst} but with\n"
336 "those equal to @var{x} deleted. The returned elements will be\n"
337 "in the same order as they were in @var{lst}.\n"
339 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
340 "given. An equality call is made just once for each element,\n"
341 "but the order in which the calls are made on the elements is\n"
344 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
345 "given @var{x} is first. This means for instance elements\n"
346 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
348 "@var{lst} is not modified, but the returned list might share a\n"
349 "common tail with @var{lst}.")
350 #define FUNC_NAME s_scm_srfi1_delete
352 SCM ret
, *p
, keeplst
;
355 if (SCM_UNBNDP (pred
))
356 return scm_delete (x
, lst
);
358 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG3
, FUNC_NAME
);
360 /* ret is the return list being constructed. p is where to append to it,
361 initially &ret then SCM_CDRLOC of the last pair. lst progresses as
362 elements are considered.
364 Elements to be retained are not immediately copied, instead keeplst is
365 the last pair in lst which is to be retained but not yet copied, count
366 is how many from there are wanted. When there's no more deletions, *p
367 can be set to keeplst to share the remainder of the original lst. (The
368 entire original lst if there's no deletions at all.) */
374 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
376 if (scm_is_true (scm_call_2 (pred
, x
, SCM_CAR (lst
))))
378 /* delete this element, so copy those at keeplst */
379 p
= list_copy_part (keeplst
, count
, p
);
380 keeplst
= SCM_CDR (lst
);
385 /* keep this element */
390 /* final retained elements */
393 /* demand that lst was a proper list */
394 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
401 SCM_DEFINE (scm_srfi1_delete_x
, "delete!", 2, 1, 0,
402 (SCM x
, SCM lst
, SCM pred
),
403 "Return a list containing the elements of @var{lst} but with\n"
404 "those equal to @var{x} deleted. The returned elements will be\n"
405 "in the same order as they were in @var{lst}.\n"
407 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
408 "given. An equality call is made just once for each element,\n"
409 "but the order in which the calls are made on the elements is\n"
412 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
413 "given @var{x} is first. This means for instance elements\n"
414 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
416 "@var{lst} may be modified to construct the returned list.")
417 #define FUNC_NAME s_scm_srfi1_delete_x
422 if (SCM_UNBNDP (pred
))
423 return scm_delete_x (x
, lst
);
425 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG3
, FUNC_NAME
);
427 for (prev
= &lst
, walk
= lst
;
429 walk
= SCM_CDR (walk
))
431 if (scm_is_true (scm_call_2 (pred
, x
, SCM_CAR (walk
))))
432 *prev
= SCM_CDR (walk
);
434 prev
= SCM_CDRLOC (walk
);
437 /* demand the input was a proper list */
438 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk
), walk
, SCM_ARG2
, FUNC_NAME
,"list");
444 SCM_DEFINE (scm_srfi1_delete_duplicates
, "delete-duplicates", 1, 1, 0,
446 "Return a list containing the elements of @var{lst} but without\n"
449 "When elements are equal, only the first in @var{lst} is\n"
450 "retained. Equal elements can be anywhere in @var{lst}, they\n"
451 "don't have to be adjacent. The returned list will have the\n"
452 "retained elements in the same order as they were in @var{lst}.\n"
454 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
455 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
456 "being before @var{y} in @var{lst}. A call is made at most once\n"
457 "for each combination, but the sequence of the calls across the\n"
458 "elements is unspecified.\n"
460 "@var{lst} is not modified, but the return might share a common\n"
461 "tail with @var{lst}.\n"
463 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
464 "it must check each element against all those preceding it. For\n"
465 "long lists it is more efficient to sort and then compare only\n"
466 "adjacent elements.")
467 #define FUNC_NAME s_scm_srfi1_delete_duplicates
469 scm_t_trampoline_2 equal_p
;
470 SCM ret
, *p
, keeplst
, item
, l
;
473 /* ret is the new list constructed. p is where to append, initially &ret
474 then SCM_CDRLOC of the last pair. lst is advanced as each element is
477 Elements retained are not immediately appended to ret, instead keeplst
478 is the last pair in lst which is to be kept but is not yet copied.
479 Initially this is the first pair of lst, since the first element is
482 *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
483 the elements retained, making the equality search loop easy.
485 If an item must be deleted, elements from keeplst (inclusive) to lst
486 (exclusive) must be copied and appended to ret. When there's no more
487 deletions, *p is left set to keeplst, so ret shares structure with the
488 original lst. (ret will be the entire original lst if there are no
491 /* skip to end if an empty list (or something invalid) */
494 if (SCM_UNBNDP (pred
))
495 equal_p
= equal_trampoline
;
498 SCM_VALIDATE_PROC (SCM_ARG2
, pred
);
499 equal_p
= scm_call_2
;
506 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
508 item
= SCM_CAR (lst
);
510 /* look for item in "ret" list */
511 for (l
= ret
; scm_is_pair (l
); l
= SCM_CDR (l
))
513 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
515 /* "item" is a duplicate, so copy keeplst onto ret */
517 p
= list_copy_part (keeplst
, count
, p
);
519 keeplst
= SCM_CDR (lst
); /* elem after the one deleted */
525 /* look for item in "keeplst" list
526 be careful traversing, in case nasty code changed the cdrs */
527 for (i
= 0, l
= keeplst
;
528 i
< count
&& scm_is_pair (l
);
529 i
++, l
= SCM_CDR (l
))
530 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
533 /* keep this element */
539 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
541 /* share tail of keeplst items */
549 SCM_DEFINE (scm_srfi1_delete_duplicates_x
, "delete-duplicates!", 1, 1, 0,
551 "Return a list containing the elements of @var{lst} but without\n"
554 "When elements are equal, only the first in @var{lst} is\n"
555 "retained. Equal elements can be anywhere in @var{lst}, they\n"
556 "don't have to be adjacent. The returned list will have the\n"
557 "retained elements in the same order as they were in @var{lst}.\n"
559 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
560 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
561 "being before @var{y} in @var{lst}. A call is made at most once\n"
562 "for each combination, but the sequence of the calls across the\n"
563 "elements is unspecified.\n"
565 "@var{lst} may be modified to construct the returned list.\n"
567 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
568 "it must check each element against all those preceding it. For\n"
569 "long lists it is more efficient to sort and then compare only\n"
570 "adjacent elements.")
571 #define FUNC_NAME s_scm_srfi1_delete_duplicates_x
573 scm_t_trampoline_2 equal_p
;
574 SCM ret
, endret
, item
, l
;
576 /* ret is the return list, constructed from the pairs in lst. endret is
577 the last pair of ret, initially the first pair. lst is advanced as
578 elements are considered. */
580 /* skip to end if an empty list (or something invalid) */
582 if (scm_is_pair (lst
))
584 if (SCM_UNBNDP (pred
))
585 equal_p
= equal_trampoline
;
588 SCM_VALIDATE_PROC (SCM_ARG2
, pred
);
589 equal_p
= scm_call_2
;
594 /* loop over lst elements starting from second */
598 if (! scm_is_pair (lst
))
600 item
= SCM_CAR (lst
);
602 /* is item equal to any element from ret to endret (inclusive)? */
606 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
607 break; /* equal, forget this element */
609 if (scm_is_eq (l
, endret
))
611 /* not equal to any, so append this pair */
612 SCM_SETCDR (endret
, lst
);
620 /* terminate, in case last element was deleted */
621 SCM_SETCDR (endret
, SCM_EOL
);
624 /* demand that lst was a proper list */
625 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
632 SCM_DEFINE (scm_srfi1_drop_right
, "drop-right", 2, 0, 0,
634 "Return a new list containing all except the last @var{n}\n"
635 "elements of @var{lst}.")
636 #define FUNC_NAME s_scm_srfi1_drop_right
638 SCM tail
= scm_list_tail (lst
, n
);
641 while (scm_is_pair (tail
))
643 *rend
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
644 rend
= SCM_CDRLOC (*rend
);
647 tail
= SCM_CDR (tail
);
649 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
654 SCM_DEFINE (scm_srfi1_filter_map
, "filter-map", 2, 0, 1,
655 (SCM proc
, SCM list1
, SCM rest
),
656 "Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
657 "return a list of the results as per SRFI-1 @code{map}, except\n"
658 "that any @code{#f} results are omitted from the list returned.")
659 #define FUNC_NAME s_scm_srfi1_filter_map
661 SCM ret
, *loc
, elem
, newcell
, lst
;
664 SCM_VALIDATE_REST_ARGUMENT (rest
);
669 if (scm_is_null (rest
))
672 SCM_VALIDATE_PROC (SCM_ARG1
, proc
);
674 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
676 elem
= scm_call_1 (proc
, SCM_CAR (list1
));
677 if (scm_is_true (elem
))
679 newcell
= scm_cons (elem
, SCM_EOL
);
681 loc
= SCM_CDRLOC (newcell
);
685 /* check below that list1 is a proper list, and done */
690 else if (scm_is_null (SCM_CDR (rest
)))
693 SCM list2
= SCM_CAR (rest
);
694 SCM_VALIDATE_PROC (SCM_ARG1
, proc
);
698 if (! scm_is_pair (list1
))
700 if (! scm_is_pair (list2
))
704 goto check_lst_and_done
;
706 elem
= scm_call_2 (proc
, SCM_CAR (list1
), SCM_CAR (list2
));
707 if (scm_is_true (elem
))
709 newcell
= scm_cons (elem
, SCM_EOL
);
711 loc
= SCM_CDRLOC (newcell
);
713 list1
= SCM_CDR (list1
);
714 list2
= SCM_CDR (list2
);
719 /* three or more lists */
723 /* vec is the list arguments */
724 vec
= scm_vector (scm_cons (list1
, rest
));
725 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
727 /* args is the argument list to pass to proc, same length as vec,
728 re-used for each call */
729 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
733 /* first elem of each list in vec into args, and step those
734 vec entries onto their next element */
735 for (i
= 0, a
= args
, argnum
= 2;
737 i
++, a
= SCM_CDR (a
), argnum
++)
739 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
740 if (! scm_is_pair (lst
))
741 goto check_lst_and_done
;
742 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for proc */
743 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
746 elem
= scm_apply (proc
, args
, SCM_EOL
);
747 if (scm_is_true (elem
))
749 newcell
= scm_cons (elem
, SCM_EOL
);
751 loc
= SCM_CDRLOC (newcell
);
757 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
763 SCM_DEFINE (scm_srfi1_find
, "find", 2, 0, 0,
765 "Return the first element of @var{lst} which satisfies the\n"
766 "predicate @var{pred}, or return @code{#f} if no such element is\n"
768 #define FUNC_NAME s_scm_srfi1_find
770 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
772 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
774 SCM elem
= SCM_CAR (lst
);
775 if (scm_is_true (scm_call_1 (pred
, elem
)))
778 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
785 SCM_DEFINE (scm_srfi1_find_tail
, "find-tail", 2, 0, 0,
787 "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
788 "predicate @var{pred}, or return @code{#f} if no such element is\n"
790 #define FUNC_NAME s_scm_srfi1_find_tail
792 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
794 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
795 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (lst
))))
797 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
803 SCM_DEFINE (scm_srfi1_length_plus
, "length+", 1, 0, 0,
805 "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
807 #define FUNC_NAME s_scm_srfi1_length_plus
809 long len
= scm_ilength (lst
);
810 return (len
>= 0 ? SCM_I_MAKINUM (len
) : SCM_BOOL_F
);
815 /* This routine differs from the core list-copy in allowing improper lists.
816 Maybe the core could allow them similarly. */
818 SCM_DEFINE (scm_srfi1_list_copy
, "list-copy", 1, 0, 0,
820 "Return a copy of the given list @var{lst}.\n"
822 "@var{lst} can be a proper or improper list. And if @var{lst}\n"
823 "is not a pair then it's treated as the final tail of an\n"
824 "improper list and simply returned.")
825 #define FUNC_NAME s_scm_srfi1_list_copy
835 while (scm_is_pair (from_here
))
838 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
840 fill_here
= SCM_CDRLOC (c
);
841 from_here
= SCM_CDR (from_here
);
847 SCM_DEFINE (scm_srfi1_lset_difference_x
, "lset-difference!", 2, 0, 1,
848 (SCM equal
, SCM lst
, SCM rest
),
849 "Return @var{lst} with any elements in the lists in @var{rest}\n"
850 "removed (ie.@: subtracted). For only one @var{lst} argument,\n"
851 "just that list is returned.\n"
853 "The given @var{equal} procedure is used for comparing elements,\n"
854 "called as @code{(@var{equal} elem1 elemN)}. The first argument\n"
855 "is from @var{lst} and the second from one of the subsequent\n"
856 "lists. But exactly which calls are made and in what order is\n"
860 "(lset-difference! eqv? (list 'x 'y)) @result{} (x y)\n"
861 "(lset-difference! eqv? (list 1 2 3) '(3 1)) @result{} (2)\n"
862 "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n"
865 "@code{lset-difference!} may modify @var{lst} to form its\n"
867 #define FUNC_NAME s_scm_srfi1_lset_difference_x
869 SCM ret
, *pos
, elem
, r
, b
;
872 SCM_VALIDATE_PROC (SCM_ARG1
, equal
);
873 SCM_VALIDATE_REST_ARGUMENT (rest
);
877 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
879 elem
= SCM_CAR (lst
);
881 for (r
= rest
, argnum
= SCM_ARG3
;
883 r
= SCM_CDR (r
), argnum
++)
885 for (b
= SCM_CAR (r
); scm_is_pair (b
); b
= SCM_CDR (b
))
886 if (scm_is_true (scm_call_2 (equal
, elem
, SCM_CAR (b
))))
887 goto next_elem
; /* equal to elem, so drop that elem */
889 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b
), b
, argnum
, FUNC_NAME
,"list");
892 /* elem not equal to anything in later lists, so keep it */
894 pos
= SCM_CDRLOC (lst
);
899 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
907 /* Typechecking for multi-argument MAP and FOR-EACH.
909 Verify that each element of the vector ARGV, except for the first,
910 is a list and return minimum length. Attribute errors to WHO,
911 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
913 check_map_args (SCM argv
,
923 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
926 elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
928 if (!(scm_is_null (elt
) || scm_is_pair (elt
)))
929 goto check_map_error
;
931 elt_len
= srfi1_ilength (elt
);
933 goto check_map_error
;
935 if (len
< 0 || (elt_len
>= 0 && elt_len
< len
))
945 scm_apply_generic (gf
, scm_cons (proc
, args
));
947 scm_wrong_type_arg (who
, i
+ 2, elt
);
950 scm_remember_upto_here_1 (argv
);
955 SCM_GPROC (s_srfi1_map
, "map", 2, 0, 1, scm_srfi1_map
, g_srfi1_map
);
957 /* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
958 sequentially, starting with the first element(s). This is used in
959 the Scheme procedure `map-in-order', which guarantees sequential
960 behaviour, is implemented using scm_map. If the behaviour changes,
961 we need to update `map-in-order'.
965 scm_srfi1_map (SCM proc
, SCM arg1
, SCM args
)
966 #define FUNC_NAME s_srfi1_map
972 len
= srfi1_ilength (arg1
);
973 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
975 scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_srfi1_map
);
976 SCM_VALIDATE_REST_ARGUMENT (args
);
977 if (scm_is_null (args
))
979 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_srfi1_map
,
980 proc
, arg1
, SCM_ARG1
, s_srfi1_map
);
981 SCM_GASSERT2 (len
>= 0, g_srfi1_map
, proc
, arg1
, SCM_ARG2
, s_srfi1_map
);
982 while (SCM_NIMP (arg1
))
984 *pres
= scm_list_1 (scm_call_1 (proc
, SCM_CAR (arg1
)));
985 pres
= SCM_CDRLOC (*pres
);
986 arg1
= SCM_CDR (arg1
);
990 if (scm_is_null (SCM_CDR (args
)))
992 SCM arg2
= SCM_CAR (args
);
993 int len2
= srfi1_ilength (arg2
);
994 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_srfi1_map
,
995 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_map
);
996 if (len
< 0 || (len2
>= 0 && len2
< len
))
998 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
999 && len
>= 0 && len2
>= -1,
1001 scm_cons2 (proc
, arg1
, args
),
1002 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
1006 *pres
= scm_list_1 (scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
1007 pres
= SCM_CDRLOC (*pres
);
1008 arg1
= SCM_CDR (arg1
);
1009 arg2
= SCM_CDR (arg2
);
1014 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
1015 len
= check_map_args (args
, len
, g_srfi1_map
, proc
, arg1
, s_srfi1_map
);
1019 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
1021 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
1022 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
1023 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
1025 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
1026 pres
= SCM_CDRLOC (*pres
);
1033 SCM_REGISTER_PROC (s_srfi1_map_in_order
, "map-in-order", 2, 0, 1, scm_srfi1_map
);
1035 SCM_GPROC (s_srfi1_for_each
, "for-each", 2, 0, 1, scm_srfi1_for_each
, g_srfi1_for_each
);
1038 scm_srfi1_for_each (SCM proc
, SCM arg1
, SCM args
)
1039 #define FUNC_NAME s_srfi1_for_each
1042 len
= srfi1_ilength (arg1
);
1043 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
1044 g_srfi1_for_each
, scm_cons2 (proc
, arg1
, args
),
1045 SCM_ARG2
, s_srfi1_for_each
);
1046 SCM_VALIDATE_REST_ARGUMENT (args
);
1047 if (scm_is_null (args
))
1049 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_srfi1_for_each
,
1050 proc
, arg1
, SCM_ARG1
, s_srfi1_for_each
);
1051 SCM_GASSERT2 (len
>= 0, g_srfi1_for_each
, proc
, arg1
,
1052 SCM_ARG2
, s_srfi1_map
);
1053 while (SCM_NIMP (arg1
))
1055 scm_call_1 (proc
, SCM_CAR (arg1
));
1056 arg1
= SCM_CDR (arg1
);
1058 return SCM_UNSPECIFIED
;
1060 if (scm_is_null (SCM_CDR (args
)))
1062 SCM arg2
= SCM_CAR (args
);
1063 int len2
= srfi1_ilength (arg2
);
1064 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_srfi1_for_each
,
1065 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_for_each
);
1066 if (len
< 0 || (len2
>= 0 && len2
< len
))
1068 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
1069 && len
>= 0 && len2
>= -1,
1071 scm_cons2 (proc
, arg1
, args
),
1072 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
1076 scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
1077 arg1
= SCM_CDR (arg1
);
1078 arg2
= SCM_CDR (arg2
);
1081 return SCM_UNSPECIFIED
;
1083 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
1084 len
= check_map_args (args
, len
, g_srfi1_for_each
, proc
, arg1
,
1089 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
1091 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
1092 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
1093 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
1095 scm_apply (proc
, arg1
, SCM_EOL
);
1098 return SCM_UNSPECIFIED
;
1103 SCM_DEFINE (scm_srfi1_member
, "member", 2, 1, 0,
1104 (SCM x
, SCM lst
, SCM pred
),
1105 "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
1106 "to @var{x}. If @var{x} does not appear in @var{lst}, return\n"
1109 "Equality is determined by @code{equal?}, or by the equality\n"
1110 "predicate @var{=} if given. @var{=} is called @code{(= @var{x}\n"
1111 "elem)}, ie.@: with the given @var{x} first, so for example to\n"
1112 "find the first element greater than 5,\n"
1115 "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
1118 "This version of @code{member} extends the core @code{member} by\n"
1119 "accepting an equality predicate.")
1120 #define FUNC_NAME s_scm_srfi1_member
1122 scm_t_trampoline_2 equal_p
;
1123 SCM_VALIDATE_LIST (2, lst
);
1124 if (SCM_UNBNDP (pred
))
1125 equal_p
= equal_trampoline
;
1128 SCM_VALIDATE_PROC (SCM_ARG3
, pred
);
1129 equal_p
= scm_call_2
;
1131 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
1133 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
1140 SCM_DEFINE (scm_srfi1_assoc
, "assoc", 2, 1, 0,
1141 (SCM key
, SCM alist
, SCM pred
),
1142 "Behaves like @code{assq} but uses third argument @var{pred?}\n"
1143 "for key comparison. If @var{pred?} is not supplied,\n"
1144 "@code{equal?} is used. (Extended from R5RS.)\n")
1145 #define FUNC_NAME s_scm_srfi1_assoc
1148 scm_t_trampoline_2 equal_p
;
1149 if (SCM_UNBNDP (pred
))
1150 equal_p
= equal_trampoline
;
1153 SCM_VALIDATE_PROC (SCM_ARG3
, pred
);
1154 equal_p
= scm_call_2
;
1156 for(; scm_is_pair (ls
); ls
= SCM_CDR (ls
))
1158 SCM tmp
= SCM_CAR (ls
);
1159 SCM_ASSERT_TYPE (scm_is_pair (tmp
), alist
, SCM_ARG2
, FUNC_NAME
,
1160 "association list");
1161 if (scm_is_true (equal_p (pred
, key
, SCM_CAR (tmp
))))
1164 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls
), alist
, SCM_ARG2
, FUNC_NAME
,
1165 "association list");
1170 SCM_DEFINE (scm_srfi1_partition
, "partition", 2, 0, 0,
1171 (SCM pred
, SCM list
),
1172 "Partition the elements of @var{list} with predicate @var{pred}.\n"
1173 "Return two values: the list of elements satifying @var{pred} and\n"
1174 "the list of elements @emph{not} satisfying @var{pred}. The order\n"
1175 "of the output lists follows the order of @var{list}. @var{list}\n"
1176 "is not mutated. One of the output lists may share memory with @var{list}.\n")
1177 #define FUNC_NAME s_scm_srfi1_partition
1179 /* In this implementation, the output lists don't share memory with
1180 list, because it's probably not worth the effort. */
1181 SCM orig_list
= list
;
1182 SCM kept
= scm_cons(SCM_EOL
, SCM_EOL
);
1183 SCM kept_tail
= kept
;
1184 SCM dropped
= scm_cons(SCM_EOL
, SCM_EOL
);
1185 SCM dropped_tail
= dropped
;
1187 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
1189 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR(list
)) {
1192 /* Make sure LIST is not a dotted list. */
1193 SCM_ASSERT (scm_is_pair (list
), orig_list
, SCM_ARG2
, FUNC_NAME
);
1195 elt
= SCM_CAR (list
);
1196 new_tail
= scm_cons (SCM_CAR (list
), SCM_EOL
);
1198 if (scm_is_true (scm_call_1 (pred
, elt
))) {
1199 SCM_SETCDR(kept_tail
, new_tail
);
1200 kept_tail
= new_tail
;
1203 SCM_SETCDR(dropped_tail
, new_tail
);
1204 dropped_tail
= new_tail
;
1207 /* re-use the initial conses for the values list */
1208 SCM_SETCAR(kept
, SCM_CDR(kept
));
1209 SCM_SETCDR(kept
, dropped
);
1210 SCM_SETCAR(dropped
, SCM_CDR(dropped
));
1211 SCM_SETCDR(dropped
, SCM_EOL
);
1212 return scm_values(kept
);
1217 SCM_DEFINE (scm_srfi1_partition_x
, "partition!", 2, 0, 0,
1218 (SCM pred
, SCM lst
),
1219 "Split @var{lst} into those elements which do and don't satisfy\n"
1220 "the predicate @var{pred}.\n"
1222 "The return is two values (@pxref{Multiple Values}), the first\n"
1223 "being a list of all elements from @var{lst} which satisfy\n"
1224 "@var{pred}, the second a list of those which do not.\n"
1226 "The elements in the result lists are in the same order as in\n"
1227 "@var{lst} but the order in which the calls @code{(@var{pred}\n"
1228 "elem)} are made on the list elements is unspecified.\n"
1230 "@var{lst} may be modified to construct the return lists.")
1231 #define FUNC_NAME s_scm_srfi1_partition_x
1233 SCM tlst
, flst
, *tp
, *fp
;
1235 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
1237 /* tlst and flst are the lists of true and false elements. tp and fp are
1238 where to store to append to them, initially &tlst and &flst, then
1239 SCM_CDRLOC of the last pair in the respective lists. */
1246 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1248 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (lst
))))
1251 tp
= SCM_CDRLOC (lst
);
1256 fp
= SCM_CDRLOC (lst
);
1260 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1262 /* terminate whichever didn't get the last element(s) */
1266 return scm_values (scm_list_2 (tlst
, flst
));
1270 SCM_DEFINE (scm_srfi1_remove
, "remove", 2, 0, 0,
1271 (SCM pred
, SCM list
),
1272 "Return a list containing all elements from @var{lst} which do\n"
1273 "not satisfy the predicate @var{pred}. The elements in the\n"
1274 "result list have the same order as in @var{lst}. The order in\n"
1275 "which @var{pred} is applied to the list elements is not\n"
1277 #define FUNC_NAME s_scm_srfi1_remove
1282 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
1283 SCM_VALIDATE_LIST (2, list
);
1285 for (prev
= &res
, walk
= list
;
1287 walk
= SCM_CDR (walk
))
1289 if (scm_is_false (scm_call_1 (pred
, SCM_CAR (walk
))))
1291 *prev
= scm_cons (SCM_CAR (walk
), SCM_EOL
);
1292 prev
= SCM_CDRLOC (*prev
);
1301 SCM_DEFINE (scm_srfi1_remove_x
, "remove!", 2, 0, 0,
1302 (SCM pred
, SCM list
),
1303 "Return a list containing all elements from @var{list} which do\n"
1304 "not satisfy the predicate @var{pred}. The elements in the\n"
1305 "result list have the same order as in @var{list}. The order in\n"
1306 "which @var{pred} is applied to the list elements is not\n"
1307 "specified. @var{list} may be modified to build the return\n"
1309 #define FUNC_NAME s_scm_srfi1_remove_x
1313 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
1314 SCM_VALIDATE_LIST (2, list
);
1316 for (prev
= &list
, walk
= list
;
1318 walk
= SCM_CDR (walk
))
1320 if (scm_is_false (scm_call_1 (pred
, SCM_CAR (walk
))))
1321 prev
= SCM_CDRLOC (walk
);
1323 *prev
= SCM_CDR (walk
);
1331 SCM_DEFINE (scm_srfi1_split_at
, "split-at", 2, 0, 0,
1333 "Return two values (multiple values), being a list of the\n"
1334 "elements before index @var{n} in @var{lst}, and a list of those\n"
1336 #define FUNC_NAME s_scm_srfi1_split_at
1339 /* pre is a list of elements before the i split point, loc is the CDRLOC
1340 of the last cell, ie. where to store to append to it */
1344 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1346 SCM_VALIDATE_CONS (SCM_ARG1
, lst
);
1348 *loc
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
1349 loc
= SCM_CDRLOC (*loc
);
1352 return scm_values (scm_list_2 (pre
, lst
));
1357 SCM_DEFINE (scm_srfi1_split_at_x
, "split-at!", 2, 0, 0,
1359 "Return two values (multiple values), being a list of the\n"
1360 "elements before index @var{n} in @var{lst}, and a list of those\n"
1361 "after. @var{lst} is modified to form those values.")
1362 #define FUNC_NAME s_scm_srfi1_split_at
1368 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1370 SCM_VALIDATE_CONS (SCM_ARG1
, upto
);
1372 loc
= SCM_CDRLOC (upto
);
1373 upto
= SCM_CDR (upto
);
1377 return scm_values (scm_list_2 (lst
, upto
));
1381 SCM_DEFINE (scm_srfi1_take_right
, "take-right", 2, 0, 0,
1383 "Return the a list containing the @var{n} last elements of\n"
1385 #define FUNC_NAME s_scm_srfi1_take_right
1387 SCM tail
= scm_list_tail (lst
, n
);
1388 while (scm_is_pair (tail
))
1390 lst
= SCM_CDR (lst
);
1391 tail
= SCM_CDR (tail
);
1393 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
1400 scm_register_srfi_1 (void)
1402 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1404 (scm_t_extension_init_func
)scm_init_srfi_1
, NULL
);
1408 scm_init_srfi_1 (void)
1410 SCM the_root_module
= scm_lookup_closure_module (SCM_BOOL_F
);
1411 #ifndef SCM_MAGIC_SNARFER
1412 #include "libguile/srfi-1.x"
1414 scm_c_extend_primitive_generic
1415 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "map")),
1416 SCM_VARIABLE_REF (scm_c_lookup ("map")));
1417 scm_c_extend_primitive_generic
1418 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "for-each")),
1419 SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
1422 /* End of srfi-1.c. */