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.
47 /* The `(srfi srfi-1)' module. */
48 static SCM srfi1_module
= SCM_BOOL_F
;
50 /* Cache variable NAME in C variable VAR. */
51 #define CACHE_VAR(var, name) \
52 static SCM var = SCM_BOOL_F; \
53 if (scm_is_false (var)) \
55 if (SCM_UNLIKELY (scm_is_false (srfi1_module))) \
56 srfi1_module = scm_c_resolve_module ("srfi srfi-1"); \
58 var = scm_module_variable (srfi1_module, \
59 scm_from_locale_symbol (name)); \
60 if (SCM_UNLIKELY (scm_is_false (var))) \
63 var = SCM_VARIABLE_REF (var); \
67 srfi1_ilength (SCM sx
)
74 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
75 if (!scm_is_pair (hare
)) return -2;
78 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
79 if (!scm_is_pair (hare
)) return -2;
82 /* For every two steps the hare takes, the tortoise takes one. */
83 tortoise
= SCM_CDR(tortoise
);
85 while (! scm_is_eq (hare
, tortoise
));
87 /* If the tortoise ever catches the hare, then the list must contain
93 equal_trampoline (SCM proc
, SCM arg1
, SCM arg2
)
95 return scm_equal_p (arg1
, arg2
);
98 /* list_copy_part() copies the first COUNT cells of LST, puts the result at
99 *dst, and returns the SCM_CDRLOC of the last cell in that new list.
101 This function is designed to be careful about LST possibly having changed
102 in between the caller deciding what to copy, and the copy actually being
103 done here. The COUNT ensures we terminate if LST has become circular,
104 SCM_VALIDATE_CONS guards against a cdr in the list changed to some
109 list_copy_part (SCM lst
, int count
, SCM
*dst
)
110 #define FUNC_NAME "list_copy_part"
113 for ( ; count
> 0; count
--)
115 SCM_VALIDATE_CONS (SCM_ARGn
, lst
);
116 c
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
118 dst
= SCM_CDRLOC (c
);
126 SCM_DEFINE (scm_srfi1_alist_copy
, "alist-copy", 1, 0, 0,
128 "Return a copy of @var{alist}, copying both the pairs comprising\n"
129 "the list and those making the associations.")
130 #define FUNC_NAME s_scm_srfi1_alist_copy
132 SCM ret
, *p
, elem
, c
;
134 /* ret is the list to return. p is where to append to it, initially &ret
135 then SCM_CDRLOC of the last pair. */
139 for ( ; scm_is_pair (alist
); alist
= SCM_CDR (alist
))
141 elem
= SCM_CAR (alist
);
143 /* each element of alist must be a pair */
144 SCM_ASSERT_TYPE (scm_is_pair (elem
), alist
, SCM_ARG1
, FUNC_NAME
,
147 c
= scm_cons (scm_cons (SCM_CAR (elem
), SCM_CDR (elem
)), SCM_EOL
);
152 /* alist must be a proper list */
153 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (alist
), alist
, SCM_ARG1
, FUNC_NAME
,
161 SCM_DEFINE (scm_srfi1_append_reverse
, "append-reverse", 2, 0, 0,
162 (SCM revhead
, SCM tail
),
163 "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
164 "result. This is equivalent to @code{(append (reverse\n"
165 "@var{rev-head}) @var{tail})}, but its implementation is more\n"
169 "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
171 #define FUNC_NAME s_scm_srfi1_append_reverse
173 while (scm_is_pair (revhead
))
175 /* copy first element of revhead onto front of tail */
176 tail
= scm_cons (SCM_CAR (revhead
), tail
);
177 revhead
= SCM_CDR (revhead
);
179 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead
), revhead
, SCM_ARG1
, FUNC_NAME
,
186 SCM_DEFINE (scm_srfi1_append_reverse_x
, "append-reverse!", 2, 0, 0,
187 (SCM revhead
, SCM tail
),
188 "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
189 "result. This is equivalent to @code{(append! (reverse!\n"
190 "@var{rev-head}) @var{tail})}, but its implementation is more\n"
194 "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
197 "@var{rev-head} may be modified in order to produce the result.")
198 #define FUNC_NAME s_scm_srfi1_append_reverse_x
202 while (scm_is_pair (revhead
))
204 /* take the first cons cell from revhead */
206 revhead
= SCM_CDR (revhead
);
208 /* make it the new start of tail, appending the previous */
209 SCM_SETCDR (newtail
, tail
);
212 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead
), revhead
, SCM_ARG1
, FUNC_NAME
,
219 scm_srfi1_break (SCM pred
, SCM lst
)
221 CACHE_VAR (break_proc
, "break");
222 return scm_call_2 (break_proc
, pred
, lst
);
226 scm_srfi1_break_x (SCM pred
, SCM lst
)
228 CACHE_VAR (break_x
, "break!");
229 return scm_call_2 (break_x
, pred
, lst
);
233 scm_srfi1_car_plus_cdr (SCM pair
)
235 CACHE_VAR (car_plus_cdr
, "car+cdr");
236 return scm_call_1 (car_plus_cdr
, pair
);
239 SCM_DEFINE (scm_srfi1_concatenate
, "concatenate", 1, 0, 0,
241 "Construct a list by appending all lists in @var{lstlst}.\n"
243 "@code{concatenate} is the same as @code{(apply append\n"
244 "@var{lstlst})}. It exists because some Scheme implementations\n"
245 "have a limit on the number of arguments a function takes, which\n"
246 "the @code{apply} might exceed. In Guile there is no such\n"
248 #define FUNC_NAME s_scm_srfi1_concatenate
250 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
251 return scm_append (lstlst
);
256 SCM_DEFINE (scm_srfi1_concatenate_x
, "concatenate!", 1, 0, 0,
258 "Construct a list by appending all lists in @var{lstlst}. Those\n"
259 "lists may be modified to produce the result.\n"
261 "@code{concatenate!} is the same as @code{(apply append!\n"
262 "@var{lstlst})}. It exists because some Scheme implementations\n"
263 "have a limit on the number of arguments a function takes, which\n"
264 "the @code{apply} might exceed. In Guile there is no such\n"
266 #define FUNC_NAME s_scm_srfi1_concatenate
268 SCM_VALIDATE_LIST (SCM_ARG1
, lstlst
);
269 return scm_append_x (lstlst
);
274 SCM_DEFINE (scm_srfi1_count
, "count", 2, 0, 1,
275 (SCM pred
, SCM list1
, SCM rest
),
276 "Return a count of the number of times @var{pred} returns true\n"
277 "when called on elements from the given lists.\n"
279 "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
280 "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
281 "corresponding @var{list1} @dots{} @var{lstN}. The first call is\n"
282 "with the first element of each list, the second with the second\n"
283 "element from each, and so on.\n"
285 "Counting stops when the end of the shortest list is reached.\n"
286 "At least one list must be non-circular.")
287 #define FUNC_NAME s_scm_srfi1_count
292 SCM_VALIDATE_REST_ARGUMENT (rest
);
296 if (scm_is_null (rest
))
299 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
301 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
302 count
+= scm_is_true (scm_call_1 (pred
, SCM_CAR (list1
)));
304 /* check below that list1 is a proper list, and done */
309 else if (scm_is_pair (rest
) && scm_is_null (SCM_CDR (rest
)))
314 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
316 list2
= SCM_CAR (rest
);
319 if (! scm_is_pair (list1
))
321 if (! scm_is_pair (list2
))
327 count
+= scm_is_true (scm_call_2
328 (pred
, SCM_CAR (list1
), SCM_CAR (list2
)));
329 list1
= SCM_CDR (list1
);
330 list2
= SCM_CDR (list2
);
335 /* three or more lists */
339 /* vec is the list arguments */
340 vec
= scm_vector (scm_cons (list1
, rest
));
341 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
343 /* args is the argument list to pass to pred, same length as vec,
344 re-used for each call */
345 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
349 /* first elem of each list in vec into args, and step those
350 vec entries onto their next element */
351 for (i
= 0, a
= args
, argnum
= 2;
353 i
++, a
= SCM_CDR (a
), argnum
++)
355 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
356 if (! scm_is_pair (lst
))
357 goto check_lst_and_done
;
358 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for pred */
359 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
362 count
+= scm_is_true (scm_apply (pred
, args
, SCM_EOL
));
367 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
368 return scm_from_long (count
);
373 SCM_DEFINE (scm_srfi1_delete
, "delete", 2, 1, 0,
374 (SCM x
, SCM lst
, SCM pred
),
375 "Return a list containing the elements of @var{lst} but with\n"
376 "those equal to @var{x} deleted. The returned elements will be\n"
377 "in the same order as they were in @var{lst}.\n"
379 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
380 "given. An equality call is made just once for each element,\n"
381 "but the order in which the calls are made on the elements is\n"
384 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
385 "given @var{x} is first. This means for instance elements\n"
386 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
388 "@var{lst} is not modified, but the returned list might share a\n"
389 "common tail with @var{lst}.")
390 #define FUNC_NAME s_scm_srfi1_delete
392 SCM ret
, *p
, keeplst
;
395 if (SCM_UNBNDP (pred
))
396 return scm_delete (x
, lst
);
398 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG3
, FUNC_NAME
);
400 /* ret is the return list being constructed. p is where to append to it,
401 initially &ret then SCM_CDRLOC of the last pair. lst progresses as
402 elements are considered.
404 Elements to be retained are not immediately copied, instead keeplst is
405 the last pair in lst which is to be retained but not yet copied, count
406 is how many from there are wanted. When there's no more deletions, *p
407 can be set to keeplst to share the remainder of the original lst. (The
408 entire original lst if there's no deletions at all.) */
414 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
416 if (scm_is_true (scm_call_2 (pred
, x
, SCM_CAR (lst
))))
418 /* delete this element, so copy those at keeplst */
419 p
= list_copy_part (keeplst
, count
, p
);
420 keeplst
= SCM_CDR (lst
);
425 /* keep this element */
430 /* final retained elements */
433 /* demand that lst was a proper list */
434 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
441 SCM_DEFINE (scm_srfi1_delete_x
, "delete!", 2, 1, 0,
442 (SCM x
, SCM lst
, SCM pred
),
443 "Return a list containing the elements of @var{lst} but with\n"
444 "those equal to @var{x} deleted. The returned elements will be\n"
445 "in the same order as they were in @var{lst}.\n"
447 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
448 "given. An equality call is made just once for each element,\n"
449 "but the order in which the calls are made on the elements is\n"
452 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
453 "given @var{x} is first. This means for instance elements\n"
454 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
456 "@var{lst} may be modified to construct the returned list.")
457 #define FUNC_NAME s_scm_srfi1_delete_x
462 if (SCM_UNBNDP (pred
))
463 return scm_delete_x (x
, lst
);
465 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG3
, FUNC_NAME
);
467 for (prev
= &lst
, walk
= lst
;
469 walk
= SCM_CDR (walk
))
471 if (scm_is_true (scm_call_2 (pred
, x
, SCM_CAR (walk
))))
472 *prev
= SCM_CDR (walk
);
474 prev
= SCM_CDRLOC (walk
);
477 /* demand the input was a proper list */
478 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk
), walk
, SCM_ARG2
, FUNC_NAME
,"list");
484 SCM_DEFINE (scm_srfi1_delete_duplicates
, "delete-duplicates", 1, 1, 0,
486 "Return a list containing the elements of @var{lst} but without\n"
489 "When elements are equal, only the first in @var{lst} is\n"
490 "retained. Equal elements can be anywhere in @var{lst}, they\n"
491 "don't have to be adjacent. The returned list will have the\n"
492 "retained elements in the same order as they were in @var{lst}.\n"
494 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
495 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
496 "being before @var{y} in @var{lst}. A call is made at most once\n"
497 "for each combination, but the sequence of the calls across the\n"
498 "elements is unspecified.\n"
500 "@var{lst} is not modified, but the return might share a common\n"
501 "tail with @var{lst}.\n"
503 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
504 "it must check each element against all those preceding it. For\n"
505 "long lists it is more efficient to sort and then compare only\n"
506 "adjacent elements.")
507 #define FUNC_NAME s_scm_srfi1_delete_duplicates
509 scm_t_trampoline_2 equal_p
;
510 SCM ret
, *p
, keeplst
, item
, l
;
513 /* ret is the new list constructed. p is where to append, initially &ret
514 then SCM_CDRLOC of the last pair. lst is advanced as each element is
517 Elements retained are not immediately appended to ret, instead keeplst
518 is the last pair in lst which is to be kept but is not yet copied.
519 Initially this is the first pair of lst, since the first element is
522 *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
523 the elements retained, making the equality search loop easy.
525 If an item must be deleted, elements from keeplst (inclusive) to lst
526 (exclusive) must be copied and appended to ret. When there's no more
527 deletions, *p is left set to keeplst, so ret shares structure with the
528 original lst. (ret will be the entire original lst if there are no
531 /* skip to end if an empty list (or something invalid) */
534 if (SCM_UNBNDP (pred
))
535 equal_p
= equal_trampoline
;
538 SCM_VALIDATE_PROC (SCM_ARG2
, pred
);
539 equal_p
= scm_call_2
;
546 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
548 item
= SCM_CAR (lst
);
550 /* look for item in "ret" list */
551 for (l
= ret
; scm_is_pair (l
); l
= SCM_CDR (l
))
553 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
555 /* "item" is a duplicate, so copy keeplst onto ret */
557 p
= list_copy_part (keeplst
, count
, p
);
559 keeplst
= SCM_CDR (lst
); /* elem after the one deleted */
565 /* look for item in "keeplst" list
566 be careful traversing, in case nasty code changed the cdrs */
567 for (i
= 0, l
= keeplst
;
568 i
< count
&& scm_is_pair (l
);
569 i
++, l
= SCM_CDR (l
))
570 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
573 /* keep this element */
579 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
581 /* share tail of keeplst items */
589 SCM_DEFINE (scm_srfi1_delete_duplicates_x
, "delete-duplicates!", 1, 1, 0,
591 "Return a list containing the elements of @var{lst} but without\n"
594 "When elements are equal, only the first in @var{lst} is\n"
595 "retained. Equal elements can be anywhere in @var{lst}, they\n"
596 "don't have to be adjacent. The returned list will have the\n"
597 "retained elements in the same order as they were in @var{lst}.\n"
599 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
600 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
601 "being before @var{y} in @var{lst}. A call is made at most once\n"
602 "for each combination, but the sequence of the calls across the\n"
603 "elements is unspecified.\n"
605 "@var{lst} may be modified to construct the returned list.\n"
607 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
608 "it must check each element against all those preceding it. For\n"
609 "long lists it is more efficient to sort and then compare only\n"
610 "adjacent elements.")
611 #define FUNC_NAME s_scm_srfi1_delete_duplicates_x
613 scm_t_trampoline_2 equal_p
;
614 SCM ret
, endret
, item
, l
;
616 /* ret is the return list, constructed from the pairs in lst. endret is
617 the last pair of ret, initially the first pair. lst is advanced as
618 elements are considered. */
620 /* skip to end if an empty list (or something invalid) */
622 if (scm_is_pair (lst
))
624 if (SCM_UNBNDP (pred
))
625 equal_p
= equal_trampoline
;
628 SCM_VALIDATE_PROC (SCM_ARG2
, pred
);
629 equal_p
= scm_call_2
;
634 /* loop over lst elements starting from second */
638 if (! scm_is_pair (lst
))
640 item
= SCM_CAR (lst
);
642 /* is item equal to any element from ret to endret (inclusive)? */
646 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
647 break; /* equal, forget this element */
649 if (scm_is_eq (l
, endret
))
651 /* not equal to any, so append this pair */
652 SCM_SETCDR (endret
, lst
);
660 /* terminate, in case last element was deleted */
661 SCM_SETCDR (endret
, SCM_EOL
);
664 /* demand that lst was a proper list */
665 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
672 SCM_DEFINE (scm_srfi1_drop_right
, "drop-right", 2, 0, 0,
674 "Return a new list containing all except the last @var{n}\n"
675 "elements of @var{lst}.")
676 #define FUNC_NAME s_scm_srfi1_drop_right
678 SCM tail
= scm_list_tail (lst
, n
);
681 while (scm_is_pair (tail
))
683 *rend
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
684 rend
= SCM_CDRLOC (*rend
);
687 tail
= SCM_CDR (tail
);
689 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
695 scm_srfi1_drop_right_x (SCM lst
, SCM n
)
697 CACHE_VAR (drop_right_x
, "drop-right!");
698 return scm_call_2 (drop_right_x
, lst
, n
);
702 scm_srfi1_drop_while (SCM pred
, SCM lst
)
704 CACHE_VAR (drop_while
, "drop-while");
705 return scm_call_2 (drop_while
, pred
, lst
);
709 scm_srfi1_eighth (SCM lst
)
711 CACHE_VAR (eighth
, "eighth");
712 return scm_call_1 (eighth
, lst
);
716 scm_srfi1_fifth (SCM lst
)
718 CACHE_VAR (fifth
, "fifth");
719 return scm_call_1 (fifth
, lst
);
723 SCM_DEFINE (scm_srfi1_filter_map
, "filter-map", 2, 0, 1,
724 (SCM proc
, SCM list1
, SCM rest
),
725 "Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
726 "return a list of the results as per SRFI-1 @code{map}, except\n"
727 "that any @code{#f} results are omitted from the list returned.")
728 #define FUNC_NAME s_scm_srfi1_filter_map
730 SCM ret
, *loc
, elem
, newcell
, lst
;
733 SCM_VALIDATE_REST_ARGUMENT (rest
);
738 if (scm_is_null (rest
))
741 SCM_VALIDATE_PROC (SCM_ARG1
, proc
);
743 for ( ; scm_is_pair (list1
); list1
= SCM_CDR (list1
))
745 elem
= scm_call_1 (proc
, SCM_CAR (list1
));
746 if (scm_is_true (elem
))
748 newcell
= scm_cons (elem
, SCM_EOL
);
750 loc
= SCM_CDRLOC (newcell
);
754 /* check below that list1 is a proper list, and done */
759 else if (scm_is_null (SCM_CDR (rest
)))
762 SCM list2
= SCM_CAR (rest
);
763 SCM_VALIDATE_PROC (SCM_ARG1
, proc
);
767 if (! scm_is_pair (list1
))
769 if (! scm_is_pair (list2
))
773 goto check_lst_and_done
;
775 elem
= scm_call_2 (proc
, SCM_CAR (list1
), SCM_CAR (list2
));
776 if (scm_is_true (elem
))
778 newcell
= scm_cons (elem
, SCM_EOL
);
780 loc
= SCM_CDRLOC (newcell
);
782 list1
= SCM_CDR (list1
);
783 list2
= SCM_CDR (list2
);
788 /* three or more lists */
792 /* vec is the list arguments */
793 vec
= scm_vector (scm_cons (list1
, rest
));
794 len
= SCM_SIMPLE_VECTOR_LENGTH (vec
);
796 /* args is the argument list to pass to proc, same length as vec,
797 re-used for each call */
798 args
= scm_make_list (SCM_I_MAKINUM (len
), SCM_UNDEFINED
);
802 /* first elem of each list in vec into args, and step those
803 vec entries onto their next element */
804 for (i
= 0, a
= args
, argnum
= 2;
806 i
++, a
= SCM_CDR (a
), argnum
++)
808 lst
= SCM_SIMPLE_VECTOR_REF (vec
, i
); /* list argument */
809 if (! scm_is_pair (lst
))
810 goto check_lst_and_done
;
811 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for proc */
812 SCM_SIMPLE_VECTOR_SET (vec
, i
, SCM_CDR (lst
)); /* rest of lst */
815 elem
= scm_apply (proc
, args
, SCM_EOL
);
816 if (scm_is_true (elem
))
818 newcell
= scm_cons (elem
, SCM_EOL
);
820 loc
= SCM_CDRLOC (newcell
);
826 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, argnum
, FUNC_NAME
, "list");
832 SCM_DEFINE (scm_srfi1_find
, "find", 2, 0, 0,
834 "Return the first element of @var{lst} which satisfies the\n"
835 "predicate @var{pred}, or return @code{#f} if no such element is\n"
837 #define FUNC_NAME s_scm_srfi1_find
839 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
841 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
843 SCM elem
= SCM_CAR (lst
);
844 if (scm_is_true (scm_call_1 (pred
, elem
)))
847 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
854 SCM_DEFINE (scm_srfi1_find_tail
, "find-tail", 2, 0, 0,
856 "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
857 "predicate @var{pred}, or return @code{#f} if no such element is\n"
859 #define FUNC_NAME s_scm_srfi1_find_tail
861 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
863 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
864 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (lst
))))
866 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
873 scm_srfi1_fold (SCM proc
, SCM init
, SCM list1
, SCM rest
)
875 CACHE_VAR (fold
, "fold");
876 return scm_apply_3 (fold
, proc
, init
, list1
, rest
);
880 scm_srfi1_last (SCM lst
)
882 CACHE_VAR (last
, "last");
883 return scm_call_1 (last
, lst
);
886 SCM_DEFINE (scm_srfi1_length_plus
, "length+", 1, 0, 0,
888 "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
890 #define FUNC_NAME s_scm_srfi1_length_plus
892 long len
= scm_ilength (lst
);
893 return (len
>= 0 ? SCM_I_MAKINUM (len
) : SCM_BOOL_F
);
899 scm_srfi1_list_index (SCM pred
, SCM list1
, SCM rest
)
901 CACHE_VAR (list_index
, "list-index");
902 return scm_apply_2 (list_index
, pred
, list1
, rest
);
905 /* This routine differs from the core list-copy in allowing improper lists.
906 Maybe the core could allow them similarly. */
908 SCM_DEFINE (scm_srfi1_list_copy
, "list-copy", 1, 0, 0,
910 "Return a copy of the given list @var{lst}.\n"
912 "@var{lst} can be a proper or improper list. And if @var{lst}\n"
913 "is not a pair then it's treated as the final tail of an\n"
914 "improper list and simply returned.")
915 #define FUNC_NAME s_scm_srfi1_list_copy
925 while (scm_is_pair (from_here
))
928 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
930 fill_here
= SCM_CDRLOC (c
);
931 from_here
= SCM_CDR (from_here
);
938 scm_srfi1_list_tabulate (SCM n
, SCM proc
)
940 CACHE_VAR (list_tabulate
, "list-tabulate");
941 return scm_call_2 (list_tabulate
, n
, proc
);
945 scm_srfi1_lset_adjoin (SCM equal
, SCM lst
, SCM rest
)
947 CACHE_VAR (lset_adjoin
, "lset-adjoin");
948 return scm_apply_1 (lset_adjoin
, lst
, rest
);
951 SCM_DEFINE (scm_srfi1_lset_difference_x
, "lset-difference!", 2, 0, 1,
952 (SCM equal
, SCM lst
, SCM rest
),
953 "Return @var{lst} with any elements in the lists in @var{rest}\n"
954 "removed (ie.@: subtracted). For only one @var{lst} argument,\n"
955 "just that list is returned.\n"
957 "The given @var{equal} procedure is used for comparing elements,\n"
958 "called as @code{(@var{equal} elem1 elemN)}. The first argument\n"
959 "is from @var{lst} and the second from one of the subsequent\n"
960 "lists. But exactly which calls are made and in what order is\n"
964 "(lset-difference! eqv? (list 'x 'y)) @result{} (x y)\n"
965 "(lset-difference! eqv? (list 1 2 3) '(3 1)) @result{} (2)\n"
966 "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n"
969 "@code{lset-difference!} may modify @var{lst} to form its\n"
971 #define FUNC_NAME s_scm_srfi1_lset_difference_x
973 SCM ret
, *pos
, elem
, r
, b
;
976 SCM_VALIDATE_PROC (SCM_ARG1
, equal
);
977 SCM_VALIDATE_REST_ARGUMENT (rest
);
981 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
983 elem
= SCM_CAR (lst
);
985 for (r
= rest
, argnum
= SCM_ARG3
;
987 r
= SCM_CDR (r
), argnum
++)
989 for (b
= SCM_CAR (r
); scm_is_pair (b
); b
= SCM_CDR (b
))
990 if (scm_is_true (scm_call_2 (equal
, elem
, SCM_CAR (b
))))
991 goto next_elem
; /* equal to elem, so drop that elem */
993 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b
), b
, argnum
, FUNC_NAME
,"list");
996 /* elem not equal to anything in later lists, so keep it */
998 pos
= SCM_CDRLOC (lst
);
1003 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1011 /* Typechecking for multi-argument MAP and FOR-EACH.
1013 Verify that each element of the vector ARGV, except for the first,
1014 is a list and return minimum length. Attribute errors to WHO,
1015 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
1017 check_map_args (SCM argv
,
1027 for (i
= SCM_SIMPLE_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
1030 elt
= SCM_SIMPLE_VECTOR_REF (argv
, i
);
1032 if (!(scm_is_null (elt
) || scm_is_pair (elt
)))
1033 goto check_map_error
;
1035 elt_len
= srfi1_ilength (elt
);
1037 goto check_map_error
;
1039 if (len
< 0 || (elt_len
>= 0 && elt_len
< len
))
1049 scm_apply_generic (gf
, scm_cons (proc
, args
));
1051 scm_wrong_type_arg (who
, i
+ 2, elt
);
1054 scm_remember_upto_here_1 (argv
);
1059 SCM_GPROC (s_srfi1_map
, "map", 2, 0, 1, scm_srfi1_map
, g_srfi1_map
);
1061 /* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
1062 sequentially, starting with the first element(s). This is used in
1063 the Scheme procedure `map-in-order', which guarantees sequential
1064 behaviour, is implemented using scm_map. If the behaviour changes,
1065 we need to update `map-in-order'.
1069 scm_srfi1_map (SCM proc
, SCM arg1
, SCM args
)
1070 #define FUNC_NAME s_srfi1_map
1076 len
= srfi1_ilength (arg1
);
1077 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
1079 scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_srfi1_map
);
1080 SCM_VALIDATE_REST_ARGUMENT (args
);
1081 if (scm_is_null (args
))
1083 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_srfi1_map
,
1084 proc
, arg1
, SCM_ARG1
, s_srfi1_map
);
1085 SCM_GASSERT2 (len
>= 0, g_srfi1_map
, proc
, arg1
, SCM_ARG2
, s_srfi1_map
);
1086 while (SCM_NIMP (arg1
))
1088 *pres
= scm_list_1 (scm_call_1 (proc
, SCM_CAR (arg1
)));
1089 pres
= SCM_CDRLOC (*pres
);
1090 arg1
= SCM_CDR (arg1
);
1094 if (scm_is_null (SCM_CDR (args
)))
1096 SCM arg2
= SCM_CAR (args
);
1097 int len2
= srfi1_ilength (arg2
);
1098 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_srfi1_map
,
1099 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_map
);
1100 if (len
< 0 || (len2
>= 0 && len2
< len
))
1102 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
1103 && len
>= 0 && len2
>= -1,
1105 scm_cons2 (proc
, arg1
, args
),
1106 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
1110 *pres
= scm_list_1 (scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
1111 pres
= SCM_CDRLOC (*pres
);
1112 arg1
= SCM_CDR (arg1
);
1113 arg2
= SCM_CDR (arg2
);
1118 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
1119 len
= check_map_args (args
, len
, g_srfi1_map
, proc
, arg1
, s_srfi1_map
);
1123 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
1125 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
1126 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
1127 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
1129 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
1130 pres
= SCM_CDRLOC (*pres
);
1137 SCM_REGISTER_PROC (s_srfi1_map_in_order
, "map-in-order", 2, 0, 1, scm_srfi1_map
);
1139 SCM_GPROC (s_srfi1_for_each
, "for-each", 2, 0, 1, scm_srfi1_for_each
, g_srfi1_for_each
);
1142 scm_srfi1_for_each (SCM proc
, SCM arg1
, SCM args
)
1143 #define FUNC_NAME s_srfi1_for_each
1146 len
= srfi1_ilength (arg1
);
1147 SCM_GASSERTn ((scm_is_null (arg1
) || scm_is_pair (arg1
)) && len
>= -1,
1148 g_srfi1_for_each
, scm_cons2 (proc
, arg1
, args
),
1149 SCM_ARG2
, s_srfi1_for_each
);
1150 SCM_VALIDATE_REST_ARGUMENT (args
);
1151 if (scm_is_null (args
))
1153 SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc
)), g_srfi1_for_each
,
1154 proc
, arg1
, SCM_ARG1
, s_srfi1_for_each
);
1155 SCM_GASSERT2 (len
>= 0, g_srfi1_for_each
, proc
, arg1
,
1156 SCM_ARG2
, s_srfi1_map
);
1157 while (SCM_NIMP (arg1
))
1159 scm_call_1 (proc
, SCM_CAR (arg1
));
1160 arg1
= SCM_CDR (arg1
);
1162 return SCM_UNSPECIFIED
;
1164 if (scm_is_null (SCM_CDR (args
)))
1166 SCM arg2
= SCM_CAR (args
);
1167 int len2
= srfi1_ilength (arg2
);
1168 SCM_GASSERTn (scm_is_true (scm_procedure_p (proc
)), g_srfi1_for_each
,
1169 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_for_each
);
1170 if (len
< 0 || (len2
>= 0 && len2
< len
))
1172 SCM_GASSERTn ((scm_is_null (arg2
) || scm_is_pair (arg2
))
1173 && len
>= 0 && len2
>= -1,
1175 scm_cons2 (proc
, arg1
, args
),
1176 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
1180 scm_call_2 (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
1181 arg1
= SCM_CDR (arg1
);
1182 arg2
= SCM_CDR (arg2
);
1185 return SCM_UNSPECIFIED
;
1187 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
1188 len
= check_map_args (args
, len
, g_srfi1_for_each
, proc
, arg1
,
1193 for (i
= SCM_SIMPLE_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
1195 SCM elt
= SCM_SIMPLE_VECTOR_REF (args
, i
);
1196 arg1
= scm_cons (SCM_CAR (elt
), arg1
);
1197 SCM_SIMPLE_VECTOR_SET (args
, i
, SCM_CDR (elt
));
1199 scm_apply (proc
, arg1
, SCM_EOL
);
1202 return SCM_UNSPECIFIED
;
1207 SCM_DEFINE (scm_srfi1_member
, "member", 2, 1, 0,
1208 (SCM x
, SCM lst
, SCM pred
),
1209 "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
1210 "to @var{x}. If @var{x} does not appear in @var{lst}, return\n"
1213 "Equality is determined by @code{equal?}, or by the equality\n"
1214 "predicate @var{=} if given. @var{=} is called @code{(= @var{x}\n"
1215 "elem)}, ie.@: with the given @var{x} first, so for example to\n"
1216 "find the first element greater than 5,\n"
1219 "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
1222 "This version of @code{member} extends the core @code{member} by\n"
1223 "accepting an equality predicate.")
1224 #define FUNC_NAME s_scm_srfi1_member
1226 scm_t_trampoline_2 equal_p
;
1227 SCM_VALIDATE_LIST (2, lst
);
1228 if (SCM_UNBNDP (pred
))
1229 equal_p
= equal_trampoline
;
1232 SCM_VALIDATE_PROC (SCM_ARG3
, pred
);
1233 equal_p
= scm_call_2
;
1235 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
1237 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
1244 SCM_DEFINE (scm_srfi1_assoc
, "assoc", 2, 1, 0,
1245 (SCM key
, SCM alist
, SCM pred
),
1246 "Behaves like @code{assq} but uses third argument @var{pred?}\n"
1247 "for key comparison. If @var{pred?} is not supplied,\n"
1248 "@code{equal?} is used. (Extended from R5RS.)\n")
1249 #define FUNC_NAME s_scm_srfi1_assoc
1252 scm_t_trampoline_2 equal_p
;
1253 if (SCM_UNBNDP (pred
))
1254 equal_p
= equal_trampoline
;
1257 SCM_VALIDATE_PROC (SCM_ARG3
, pred
);
1258 equal_p
= scm_call_2
;
1260 for(; scm_is_pair (ls
); ls
= SCM_CDR (ls
))
1262 SCM tmp
= SCM_CAR (ls
);
1263 SCM_ASSERT_TYPE (scm_is_pair (tmp
), alist
, SCM_ARG2
, FUNC_NAME
,
1264 "association list");
1265 if (scm_is_true (equal_p (pred
, key
, SCM_CAR (tmp
))))
1268 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls
), alist
, SCM_ARG2
, FUNC_NAME
,
1269 "association list");
1276 scm_srfi1_ninth (SCM lst
)
1278 CACHE_VAR (ninth
, "ninth");
1279 return scm_call_1 (ninth
, lst
);
1283 scm_srfi1_not_pair_p (SCM obj
)
1285 CACHE_VAR (not_pair_p
, "not-pair?");
1286 return scm_call_1 (not_pair_p
, obj
);
1289 SCM_DEFINE (scm_srfi1_partition
, "partition", 2, 0, 0,
1290 (SCM pred
, SCM list
),
1291 "Partition the elements of @var{list} with predicate @var{pred}.\n"
1292 "Return two values: the list of elements satifying @var{pred} and\n"
1293 "the list of elements @emph{not} satisfying @var{pred}. The order\n"
1294 "of the output lists follows the order of @var{list}. @var{list}\n"
1295 "is not mutated. One of the output lists may share memory with @var{list}.\n")
1296 #define FUNC_NAME s_scm_srfi1_partition
1298 /* In this implementation, the output lists don't share memory with
1299 list, because it's probably not worth the effort. */
1300 SCM orig_list
= list
;
1301 SCM kept
= scm_cons(SCM_EOL
, SCM_EOL
);
1302 SCM kept_tail
= kept
;
1303 SCM dropped
= scm_cons(SCM_EOL
, SCM_EOL
);
1304 SCM dropped_tail
= dropped
;
1306 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
1308 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR(list
)) {
1311 /* Make sure LIST is not a dotted list. */
1312 SCM_ASSERT (scm_is_pair (list
), orig_list
, SCM_ARG2
, FUNC_NAME
);
1314 elt
= SCM_CAR (list
);
1315 new_tail
= scm_cons (SCM_CAR (list
), SCM_EOL
);
1317 if (scm_is_true (scm_call_1 (pred
, elt
))) {
1318 SCM_SETCDR(kept_tail
, new_tail
);
1319 kept_tail
= new_tail
;
1322 SCM_SETCDR(dropped_tail
, new_tail
);
1323 dropped_tail
= new_tail
;
1326 /* re-use the initial conses for the values list */
1327 SCM_SETCAR(kept
, SCM_CDR(kept
));
1328 SCM_SETCDR(kept
, dropped
);
1329 SCM_SETCAR(dropped
, SCM_CDR(dropped
));
1330 SCM_SETCDR(dropped
, SCM_EOL
);
1331 return scm_values(kept
);
1336 SCM_DEFINE (scm_srfi1_partition_x
, "partition!", 2, 0, 0,
1337 (SCM pred
, SCM lst
),
1338 "Split @var{lst} into those elements which do and don't satisfy\n"
1339 "the predicate @var{pred}.\n"
1341 "The return is two values (@pxref{Multiple Values}), the first\n"
1342 "being a list of all elements from @var{lst} which satisfy\n"
1343 "@var{pred}, the second a list of those which do not.\n"
1345 "The elements in the result lists are in the same order as in\n"
1346 "@var{lst} but the order in which the calls @code{(@var{pred}\n"
1347 "elem)} are made on the list elements is unspecified.\n"
1349 "@var{lst} may be modified to construct the return lists.")
1350 #define FUNC_NAME s_scm_srfi1_partition_x
1352 SCM tlst
, flst
, *tp
, *fp
;
1354 SCM_ASSERT (scm_is_true (scm_procedure_p (pred
)), pred
, SCM_ARG1
, FUNC_NAME
);
1356 /* tlst and flst are the lists of true and false elements. tp and fp are
1357 where to store to append to them, initially &tlst and &flst, then
1358 SCM_CDRLOC of the last pair in the respective lists. */
1365 for ( ; scm_is_pair (lst
); lst
= SCM_CDR (lst
))
1367 if (scm_is_true (scm_call_1 (pred
, SCM_CAR (lst
))))
1370 tp
= SCM_CDRLOC (lst
);
1375 fp
= SCM_CDRLOC (lst
);
1379 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
1381 /* terminate whichever didn't get the last element(s) */
1385 return scm_values (scm_list_2 (tlst
, flst
));
1390 scm_srfi1_reduce (SCM proc
, SCM def
, SCM lst
)
1392 CACHE_VAR (reduce
, "reduce");
1393 return scm_call_3 (reduce
, proc
, def
, lst
);
1397 scm_srfi1_reduce_right (SCM proc
, SCM def
, SCM lst
)
1399 CACHE_VAR (reduce_right
, "reduce-right");
1400 return scm_call_3 (reduce_right
, proc
, def
, lst
);
1403 SCM_DEFINE (scm_srfi1_remove
, "remove", 2, 0, 0,
1404 (SCM pred
, SCM list
),
1405 "Return a list containing all elements from @var{lst} which do\n"
1406 "not satisfy the predicate @var{pred}. The elements in the\n"
1407 "result list have the same order as in @var{lst}. The order in\n"
1408 "which @var{pred} is applied to the list elements is not\n"
1410 #define FUNC_NAME s_scm_srfi1_remove
1415 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
1416 SCM_VALIDATE_LIST (2, list
);
1418 for (prev
= &res
, walk
= list
;
1420 walk
= SCM_CDR (walk
))
1422 if (scm_is_false (scm_call_1 (pred
, SCM_CAR (walk
))))
1424 *prev
= scm_cons (SCM_CAR (walk
), SCM_EOL
);
1425 prev
= SCM_CDRLOC (*prev
);
1434 SCM_DEFINE (scm_srfi1_remove_x
, "remove!", 2, 0, 0,
1435 (SCM pred
, SCM list
),
1436 "Return a list containing all elements from @var{list} which do\n"
1437 "not satisfy the predicate @var{pred}. The elements in the\n"
1438 "result list have the same order as in @var{list}. The order in\n"
1439 "which @var{pred} is applied to the list elements is not\n"
1440 "specified. @var{list} may be modified to build the return\n"
1442 #define FUNC_NAME s_scm_srfi1_remove_x
1446 SCM_VALIDATE_PROC (SCM_ARG1
, pred
);
1447 SCM_VALIDATE_LIST (2, list
);
1449 for (prev
= &list
, walk
= list
;
1451 walk
= SCM_CDR (walk
))
1453 if (scm_is_false (scm_call_1 (pred
, SCM_CAR (walk
))))
1454 prev
= SCM_CDRLOC (walk
);
1456 *prev
= SCM_CDR (walk
);
1465 scm_srfi1_seventh (SCM lst
)
1467 CACHE_VAR (seventh
, "seventh");
1468 return scm_call_1 (seventh
, lst
);
1472 scm_srfi1_sixth (SCM lst
)
1474 CACHE_VAR (sixth
, "sixth");
1475 return scm_call_1 (sixth
, lst
);
1479 scm_srfi1_span (SCM pred
, SCM lst
)
1481 CACHE_VAR (span
, "span");
1482 return scm_call_2 (span
, pred
, lst
);
1486 scm_srfi1_span_x (SCM pred
, SCM lst
)
1488 CACHE_VAR (span_x
, "span!");
1489 return scm_call_2 (span_x
, pred
, lst
);
1492 SCM_DEFINE (scm_srfi1_split_at
, "split-at", 2, 0, 0,
1494 "Return two values (multiple values), being a list of the\n"
1495 "elements before index @var{n} in @var{lst}, and a list of those\n"
1497 #define FUNC_NAME s_scm_srfi1_split_at
1500 /* pre is a list of elements before the i split point, loc is the CDRLOC
1501 of the last cell, ie. where to store to append to it */
1505 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1507 SCM_VALIDATE_CONS (SCM_ARG1
, lst
);
1509 *loc
= scm_cons (SCM_CAR (lst
), SCM_EOL
);
1510 loc
= SCM_CDRLOC (*loc
);
1513 return scm_values (scm_list_2 (pre
, lst
));
1518 SCM_DEFINE (scm_srfi1_split_at_x
, "split-at!", 2, 0, 0,
1520 "Return two values (multiple values), being a list of the\n"
1521 "elements before index @var{n} in @var{lst}, and a list of those\n"
1522 "after. @var{lst} is modified to form those values.")
1523 #define FUNC_NAME s_scm_srfi1_split_at
1529 for (nn
= scm_to_size_t (n
); nn
!= 0; nn
--)
1531 SCM_VALIDATE_CONS (SCM_ARG1
, upto
);
1533 loc
= SCM_CDRLOC (upto
);
1534 upto
= SCM_CDR (upto
);
1538 return scm_values (scm_list_2 (lst
, upto
));
1543 scm_srfi1_take_x (SCM lst
, SCM n
)
1545 CACHE_VAR (take_x
, "take!");
1546 return scm_call_2 (take_x
, lst
, n
);
1549 SCM_DEFINE (scm_srfi1_take_right
, "take-right", 2, 0, 0,
1551 "Return the a list containing the @var{n} last elements of\n"
1553 #define FUNC_NAME s_scm_srfi1_take_right
1555 SCM tail
= scm_list_tail (lst
, n
);
1556 while (scm_is_pair (tail
))
1558 lst
= SCM_CDR (lst
);
1559 tail
= SCM_CDR (tail
);
1561 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail
), tail
, SCM_ARG1
, FUNC_NAME
, "list");
1568 scm_srfi1_take_while (SCM pred
, SCM lst
)
1570 CACHE_VAR (take_while
, "take-while");
1571 return scm_call_2 (take_while
, pred
, lst
);
1575 scm_srfi1_take_while_x (SCM pred
, SCM lst
)
1577 CACHE_VAR (take_while_x
, "take-while!");
1578 return scm_call_2 (take_while_x
, pred
, lst
);
1582 scm_srfi1_tenth (SCM lst
)
1584 CACHE_VAR (tenth
, "tenth");
1585 return scm_call_1 (tenth
, lst
);
1589 scm_srfi1_xcons (SCM d
, SCM a
)
1591 CACHE_VAR (xcons
, "xcons");
1592 return scm_call_2 (xcons
, d
, a
);
1597 scm_register_srfi_1 (void)
1599 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1601 (scm_t_extension_init_func
)scm_init_srfi_1
, NULL
);
1605 scm_init_srfi_1 (void)
1607 SCM the_root_module
= scm_lookup_closure_module (SCM_BOOL_F
);
1608 #ifndef SCM_MAGIC_SNARFER
1609 #include "libguile/srfi-1.x"
1611 scm_c_extend_primitive_generic
1612 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "map")),
1613 SCM_VARIABLE_REF (scm_c_lookup ("map")));
1614 scm_c_extend_primitive_generic
1615 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "for-each")),
1616 SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
1619 /* End of srfi-1.c. */