1 /* srfi-1.c --- SRFI-1 procedures for Guile
3 * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003 Free Software
6 * This library is free software; you can redistribute it and/or
7 * modify it under the terms of the GNU Lesser General Public
8 * License as published by the Free Software Foundation; either
9 * version 2.1 of the License, or (at your option) any later version.
11 * This library is distributed in the hope that it will be useful,
12 * but 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
22 #include <libguile/lang.h>
26 /* The intent of this file is to gradually replace those Scheme
27 * procedures in srfi-1.scm which extends core primitive procedures,
28 * so that using srfi-1 won't have performance penalties.
30 * Please feel free to contribute any new replacements!
34 srfi1_ilength (SCM sx
)
41 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
42 if (!SCM_CONSP (hare
)) return -2;
45 if (SCM_NULL_OR_NIL_P(hare
)) return i
;
46 if (!SCM_CONSP (hare
)) return -2;
49 /* For every two steps the hare takes, the tortoise takes one. */
50 tortoise
= SCM_CDR(tortoise
);
52 while (! SCM_EQ_P (hare
, tortoise
));
54 /* If the tortoise ever catches the hare, then the list must contain
60 equal_trampoline (SCM proc
, SCM arg1
, SCM arg2
)
62 return scm_equal_p (arg1
, arg2
);
66 /* scm_append and scm_append_x don't modify their list argument (only the
67 lists within that list in the case of scm_append_x), hence making them
68 suitable for direct use for concatentate. */
70 SCM_REGISTER_PROC (s_srfi1_concatenate
, "concatenate", 1, 0, 0, scm_append
);
71 SCM_REGISTER_PROC (s_srfi1_concatenate_x
, "concatenate!", 1, 0, 0, scm_append_x
);
74 SCM_DEFINE (scm_srfi1_count
, "count", 2, 0, 1,
75 (SCM pred
, SCM lst1
, SCM rest
),
76 "Return a count of the number of times @var{pred} returns true\n"
77 "when called on elements from the given lists.\n"
79 "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
80 "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
81 "corresponding @var{lst1} @dots{} @var{lstN}. The first call is\n"
82 "with the first element of each list, the second with the second\n"
83 "element from each, and so on.\n"
85 "Counting stops when the end of the shortest list is reached.\n"
86 "At least one list must be non-circular.")
87 #define FUNC_NAME s_scm_srfi1_count
90 SCM_VALIDATE_REST_ARGUMENT (rest
);
97 scm_t_trampoline_1 pred_tramp
;
98 pred_tramp
= scm_trampoline_1 (pred
);
99 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
101 for ( ; SCM_CONSP (lst1
); lst1
= SCM_CDR (lst1
))
102 count
+= scm_is_true (pred_tramp (pred
, SCM_CAR (lst1
)));
105 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst1
), lst1
, SCM_ARG2
, FUNC_NAME
,
108 else if (SCM_CONSP (rest
) && SCM_NULLP (SCM_CDR (rest
)))
111 scm_t_trampoline_2 pred_tramp
;
114 pred_tramp
= scm_trampoline_2 (pred
);
115 SCM_ASSERT (pred_tramp
, pred
, SCM_ARG1
, FUNC_NAME
);
117 lst2
= SCM_CAR (rest
);
120 if (! SCM_CONSP (lst1
))
122 if (! SCM_CONSP (lst2
))
124 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst2
), lst2
, SCM_ARG3
,
128 count
+= scm_is_true (pred_tramp
129 (pred
, SCM_CAR (lst1
), SCM_CAR (lst2
)));
130 lst1
= SCM_CDR (lst1
);
131 lst2
= SCM_CDR (lst2
);
136 /* three or more lists */
137 SCM lstlst
, args
, l
, a
, lst
;
140 /* lstlst is a list of the list arguments */
141 lstlst
= scm_cons (lst1
, rest
);
143 /* args is the argument list to pass to pred, same length as lstlst,
144 re-used for each call */
146 for (l
= lstlst
; SCM_CONSP (l
); l
= SCM_CDR (l
))
147 args
= scm_cons (SCM_BOOL_F
, args
);
151 /* first elem of each list in lstlst into args, and step those
152 lstlst entries onto their next element */
153 for (l
= lstlst
, a
= args
, argnum
= 2;
155 l
= SCM_CDR (l
), a
= SCM_CDR (a
), argnum
++)
157 lst
= SCM_CAR (l
); /* list argument */
158 if (! SCM_CONSP (lst
))
160 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
,
161 argnum
, FUNC_NAME
, "list");
164 SCM_SETCAR (a
, SCM_CAR (lst
)); /* arg for pred */
165 SCM_SETCAR (l
, SCM_CDR (lst
)); /* keep rest of lst */
168 count
+= scm_is_true (scm_apply (pred
, args
, SCM_EOL
));
172 return SCM_MAKINUM (count
);
177 SCM_DEFINE (scm_srfi1_delete
, "delete", 2, 1, 0,
178 (SCM x
, SCM lst
, SCM pred
),
179 "Return a list containing the elements of @var{lst} but with\n"
180 "those equal to @var{x} deleted. The returned elements will be\n"
181 "in the same order as they were in @var{lst}.\n"
183 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
184 "given. An equality call is made just once for each element,\n"
185 "but the order in which the calls are made on the elements is\n"
188 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
189 "given @var{x} is first. This means for instance elements\n"
190 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
192 "@var{lst} is not modified, but the returned list might share a\n"
193 "common tail with @var{lst}.")
194 #define FUNC_NAME s_scm_srfi1_delete
196 scm_t_trampoline_2 equal_p
;
197 SCM ret
, *p
, keeplst
;
199 if (SCM_UNBNDP (pred
))
200 return scm_delete (x
, lst
);
202 equal_p
= scm_trampoline_2 (pred
);
203 SCM_ASSERT (equal_p
, pred
, SCM_ARG3
, FUNC_NAME
);
205 /* ret is the return list being constructed. p is where to append to it,
206 initially &ret then SCM_CDRLOC of the last pair. lst progresses as
207 elements are considered.
209 Elements to be retained are not immediately copied, instead keeplst is
210 the last pair in lst which is to be retained but not yet copied. When
211 there's no more deletions, *p can be set to keeplst to share the
212 remainder of the original lst. (The entire original lst if there's no
213 deletions at all.) */
219 for ( ; SCM_CONSP (lst
); lst
= SCM_CDR (lst
))
221 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (lst
))))
223 /* delete this element, so copy from keeplst (inclusive) to lst
224 (exclusive) onto ret */
225 while (! SCM_EQ_P (keeplst
, lst
))
227 SCM c
= scm_cons (SCM_CAR (keeplst
), SCM_EOL
);
230 keeplst
= SCM_CDR (keeplst
);
233 keeplst
= SCM_CDR (lst
);
237 /* final retained elements */
240 /* demand that lst was a proper list */
241 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG2
, FUNC_NAME
, "list");
248 SCM_DEFINE (scm_srfi1_delete_x
, "delete!", 2, 1, 0,
249 (SCM x
, SCM lst
, SCM pred
),
250 "Return a list containing the elements of @var{lst} but with\n"
251 "those equal to @var{x} deleted. The returned elements will be\n"
252 "in the same order as they were in @var{lst}.\n"
254 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
255 "given. An equality call is made just once for each element,\n"
256 "but the order in which the calls are made on the elements is\n"
259 "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
260 "given @var{x} is first. This means for instance elements\n"
261 "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
263 "@var{lst} may be modified to construct the returned list.")
264 #define FUNC_NAME s_scm_srfi1_delete_x
266 scm_t_trampoline_2 equal_p
;
270 if (SCM_UNBNDP (pred
))
271 return scm_delete_x (x
, lst
);
273 equal_p
= scm_trampoline_2 (pred
);
274 SCM_ASSERT (equal_p
, pred
, SCM_ARG3
, FUNC_NAME
);
276 for (prev
= &lst
, walk
= lst
;
278 walk
= SCM_CDR (walk
))
280 if (scm_is_true (equal_p (pred
, x
, SCM_CAR (walk
))))
281 *prev
= SCM_CDR (walk
);
283 prev
= SCM_CDRLOC (walk
);
286 /* demand the input was a proper list */
287 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk
), walk
, SCM_ARG2
, FUNC_NAME
,"list");
293 SCM_DEFINE (scm_srfi1_delete_duplicates
, "delete-duplicates", 1, 1, 0,
295 "Return a list containing the elements of @var{lst} but without\n"
298 "When elements are equal, only the first in @var{lst} is\n"
299 "retained. Equal elements can be anywhere in @var{lst}, they\n"
300 "don't have to be adjacent. The returned list will have the\n"
301 "retained elements in the same order as they were in @var{lst}.\n"
303 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
304 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
305 "being before @var{y} in @var{lst}. A call is made at most once\n"
306 "for each combination, but the sequence of the calls across the\n"
307 "elements is unspecified.\n"
309 "@var{lst} is not modified, but the return might share a common\n"
310 "tail with @var{lst}.\n"
312 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
313 "it must check each element against all those preceding it. For\n"
314 "long lists it is more efficient to sort and then compare only\n"
315 "adjacent elements.")
316 #define FUNC_NAME s_scm_srfi1_delete_duplicates
318 scm_t_trampoline_2 equal_p
;
319 SCM ret
, *p
, keeplst
, item
, l
;
321 /* ret is the new list constructed. p is where to append, initially &ret
322 then SCM_CDRLOC of the last pair. lst is advanced as each element is
325 Elements retained are not immediately appended to ret, instead keeplst
326 is the last pair in lst which is to be kept but is not yet copied.
327 Initially this is the first pair of lst, since the first element is
330 *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
331 the elements retained, making the equality search loop easy.
333 If an item must be deleted, elements from keeplst (inclusive) to lst
334 (exclusive) must be copied and appended to ret. When there's no more
335 deletions, *p is left set to keeplst, so ret shares structure with the
336 original lst. (ret will be the entire original lst if there are no
339 /* skip to end if an empty list (or something invalid) */
343 if (SCM_UNBNDP (pred
))
344 equal_p
= equal_trampoline
;
347 equal_p
= scm_trampoline_2 (pred
);
348 SCM_ASSERT (equal_p
, pred
, SCM_ARG2
, FUNC_NAME
);
354 /* loop over lst elements starting from second */
358 if (! SCM_CONSP (lst
))
360 item
= SCM_CAR (lst
);
362 /* loop searching ret upto lst */
363 for (l
= ret
; ! SCM_EQ_P (l
, lst
); l
= SCM_CDR (l
))
365 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
367 /* duplicate, don't want this element, so copy keeplst
368 (inclusive) to lst (exclusive) onto ret */
369 while (! SCM_EQ_P (keeplst
, lst
))
371 SCM c
= scm_cons (SCM_CAR (keeplst
), SCM_EOL
);
374 keeplst
= SCM_CDR (keeplst
);
377 keeplst
= SCM_CDR (lst
); /* elem after the one deleted */
385 /* demand that lst was a proper list */
386 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
393 SCM_DEFINE (scm_srfi1_delete_duplicates_x
, "delete-duplicates!", 1, 1, 0,
395 "Return a list containing the elements of @var{lst} but without\n"
398 "When elements are equal, only the first in @var{lst} is\n"
399 "retained. Equal elements can be anywhere in @var{lst}, they\n"
400 "don't have to be adjacent. The returned list will have the\n"
401 "retained elements in the same order as they were in @var{lst}.\n"
403 "Equality is determined by @var{pred}, or @code{equal?} if not\n"
404 "given. Calls @code{(pred x y)} are made with element @var{x}\n"
405 "being before @var{y} in @var{lst}. A call is made at most once\n"
406 "for each combination, but the sequence of the calls across the\n"
407 "elements is unspecified.\n"
409 "@var{lst} may be modified to construct the returned list.\n"
411 "In the worst case, this is an @math{O(N^2)} algorithm because\n"
412 "it must check each element against all those preceding it. For\n"
413 "long lists it is more efficient to sort and then compare only\n"
414 "adjacent elements.")
415 #define FUNC_NAME s_scm_srfi1_delete_duplicates_x
417 scm_t_trampoline_2 equal_p
;
418 SCM ret
, endret
, item
, l
;
420 /* ret is the return list, constructed from the pairs in lst. endret is
421 the last pair of ret, initially the first pair. lst is advanced as
422 elements are considered. */
424 /* skip to end if an empty list (or something invalid) */
428 if (SCM_UNBNDP (pred
))
429 equal_p
= equal_trampoline
;
432 equal_p
= scm_trampoline_2 (pred
);
433 SCM_ASSERT (equal_p
, pred
, SCM_ARG2
, FUNC_NAME
);
438 /* loop over lst elements starting from second */
442 if (! SCM_CONSP (lst
))
444 item
= SCM_CAR (lst
);
446 /* is item equal to any element from ret to endret (inclusive)? */
450 if (scm_is_true (equal_p (pred
, SCM_CAR (l
), item
)))
451 break; /* equal, forget this element */
453 if (SCM_EQ_P (l
, endret
))
455 /* not equal to any, so append this pair */
456 SCM_SETCDR (endret
, lst
);
464 /* terminate, in case last element was deleted */
465 SCM_SETCDR (endret
, SCM_EOL
);
468 /* demand that lst was a proper list */
469 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst
), lst
, SCM_ARG1
, FUNC_NAME
, "list");
476 SCM_DEFINE (scm_srfi1_length_plus
, "length+", 1, 0, 0,
478 "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
480 #define FUNC_NAME s_scm_srfi1_length_plus
482 long len
= scm_ilength (lst
);
483 return (len
>= 0 ? SCM_MAKINUM (len
) : SCM_BOOL_F
);
488 /* This routine differs from the core list-copy in allowing improper lists.
489 Maybe the core could allow them similarly. */
491 SCM_DEFINE (scm_srfi1_list_copy
, "list-copy", 1, 0, 0,
493 "Return a copy of the given list @var{lst}.\n"
495 "@var{lst} can be a proper or improper list. And if @var{lst}\n"
496 "is not a pair then it's treated as the final tail of an\n"
497 "improper list and simply returned.")
498 #define FUNC_NAME s_scm_srfi1_list_copy
508 while (SCM_CONSP (from_here
))
511 c
= scm_cons (SCM_CAR (from_here
), SCM_CDR (from_here
));
513 fill_here
= SCM_CDRLOC (c
);
514 from_here
= SCM_CDR (from_here
);
521 /* Typechecking for multi-argument MAP and FOR-EACH.
523 Verify that each element of the vector ARGV, except for the first,
524 is a list and return minimum length. Attribute errors to WHO,
525 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
527 check_map_args (SCM argv
,
534 SCM
const *ve
= SCM_VELTS (argv
);
537 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
541 if (!(SCM_NULLP (ve
[i
]) || SCM_CONSP (ve
[i
])))
545 scm_apply_generic (gf
, scm_cons (proc
, args
));
547 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
550 elt_len
= srfi1_ilength (ve
[i
]);
552 goto check_map_error
;
554 if (len
< 0 || (elt_len
>= 0 && elt_len
< len
))
559 goto check_map_error
;
561 scm_remember_upto_here_1 (argv
);
566 SCM_GPROC (s_srfi1_map
, "map", 2, 0, 1, scm_srfi1_map
, g_srfi1_map
);
568 /* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
569 sequentially, starting with the first element(s). This is used in
570 the Scheme procedure `map-in-order', which guarantees sequential
571 behaviour, is implemented using scm_map. If the behaviour changes,
572 we need to update `map-in-order'.
576 scm_srfi1_map (SCM proc
, SCM arg1
, SCM args
)
577 #define FUNC_NAME s_srfi1_map
582 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
584 len
= srfi1_ilength (arg1
);
585 SCM_GASSERTn ((SCM_NULLP (arg1
) || SCM_CONSP (arg1
)) && len
>= -1,
587 scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_srfi1_map
);
588 SCM_VALIDATE_REST_ARGUMENT (args
);
589 if (SCM_NULLP (args
))
591 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
592 SCM_GASSERT2 (call
, g_srfi1_map
, proc
, arg1
, SCM_ARG1
, s_srfi1_map
);
593 SCM_GASSERT2 (len
>= 0, g_srfi1_map
, proc
, arg1
, SCM_ARG2
, s_srfi1_map
);
594 while (SCM_NIMP (arg1
))
596 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
597 pres
= SCM_CDRLOC (*pres
);
598 arg1
= SCM_CDR (arg1
);
602 if (SCM_NULLP (SCM_CDR (args
)))
604 SCM arg2
= SCM_CAR (args
);
605 int len2
= srfi1_ilength (arg2
);
606 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
607 SCM_GASSERTn (call
, g_srfi1_map
,
608 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_map
);
609 if (len
< 0 || (len2
>= 0 && len2
< len
))
611 SCM_GASSERTn ((SCM_NULLP (arg2
) || SCM_CONSP (arg2
))
612 && len
>= 0 && len2
>= -1,
614 scm_cons2 (proc
, arg1
, args
),
615 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
619 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
620 pres
= SCM_CDRLOC (*pres
);
621 arg1
= SCM_CDR (arg1
);
622 arg2
= SCM_CDR (arg2
);
627 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
628 ve
= SCM_VELTS (args
);
629 len
= check_map_args (args
, len
, g_srfi1_map
, proc
, arg1
, s_srfi1_map
);
633 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
635 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
636 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
638 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
639 pres
= SCM_CDRLOC (*pres
);
646 SCM_REGISTER_PROC (s_srfi1_map_in_order
, "map-in-order", 2, 0, 1, scm_srfi1_map
);
648 SCM_GPROC (s_srfi1_for_each
, "for-each", 2, 0, 1, scm_srfi1_for_each
, g_srfi1_for_each
);
651 scm_srfi1_for_each (SCM proc
, SCM arg1
, SCM args
)
652 #define FUNC_NAME s_srfi1_for_each
654 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
656 len
= srfi1_ilength (arg1
);
657 SCM_GASSERTn ((SCM_NULLP (arg1
) || SCM_CONSP (arg1
)) && len
>= -1,
658 g_srfi1_for_each
, scm_cons2 (proc
, arg1
, args
),
659 SCM_ARG2
, s_srfi1_for_each
);
660 SCM_VALIDATE_REST_ARGUMENT (args
);
661 if (SCM_NULLP (args
))
663 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
664 SCM_GASSERT2 (call
, g_srfi1_for_each
, proc
, arg1
,
665 SCM_ARG1
, s_srfi1_for_each
);
666 SCM_GASSERT2 (len
>= 0, g_srfi1_for_each
, proc
, arg1
,
667 SCM_ARG2
, s_srfi1_map
);
668 while (SCM_NIMP (arg1
))
670 call (proc
, SCM_CAR (arg1
));
671 arg1
= SCM_CDR (arg1
);
673 return SCM_UNSPECIFIED
;
675 if (SCM_NULLP (SCM_CDR (args
)))
677 SCM arg2
= SCM_CAR (args
);
678 int len2
= srfi1_ilength (arg2
);
679 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
680 SCM_GASSERTn (call
, g_srfi1_for_each
,
681 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_srfi1_for_each
);
682 if (len
< 0 || (len2
>= 0 && len2
< len
))
684 SCM_GASSERTn ((SCM_NULLP (arg2
) || SCM_CONSP (arg2
))
685 && len
>= 0 && len2
>= -1,
687 scm_cons2 (proc
, arg1
, args
),
688 len2
>= 0 ? SCM_ARG2
: SCM_ARG3
,
692 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
693 arg1
= SCM_CDR (arg1
);
694 arg2
= SCM_CDR (arg2
);
697 return SCM_UNSPECIFIED
;
699 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
700 ve
= SCM_VELTS (args
);
701 len
= check_map_args (args
, len
, g_srfi1_for_each
, proc
, arg1
,
706 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
708 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
709 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
711 scm_apply (proc
, arg1
, SCM_EOL
);
714 return SCM_UNSPECIFIED
;
719 SCM_DEFINE (scm_srfi1_member
, "member", 2, 1, 0,
720 (SCM x
, SCM lst
, SCM pred
),
721 "Return the first sublist of @var{lst} whose car is\n"
722 "@var{equal?} to @var{x} where the sublists of @var{lst} are\n"
723 "the non-empty lists returned by @code{(list-tail @var{lst}\n"
724 "@var{k})} for @var{k} less than the length of @var{lst}. If\n"
725 "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n"
726 "empty list) is returned. If optional third argument @var{equal?}\n"
727 "isn't given, @code{equal?} is used for comparison.\n"
728 "(Extended from R5RS.)\n")
729 #define FUNC_NAME s_scm_srfi1_member
731 scm_t_trampoline_2 equal_p
;
732 SCM_VALIDATE_LIST (2, lst
);
733 if (SCM_UNBNDP (pred
))
734 equal_p
= equal_trampoline
;
737 equal_p
= scm_trampoline_2 (pred
);
738 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
740 for (; !SCM_NULL_OR_NIL_P (lst
); lst
= SCM_CDR (lst
))
742 if (scm_is_true (equal_p (pred
, SCM_CAR (lst
), x
)))
749 SCM_DEFINE (scm_srfi1_assoc
, "assoc", 2, 1, 0,
750 (SCM key
, SCM alist
, SCM pred
),
751 "Behaves like @code{assq} but uses third argument @var{pred?}\n"
752 "for key comparison. If @var{pred?} is not supplied,\n"
753 "@code{equal?} is used. (Extended from R5RS.)\n")
754 #define FUNC_NAME s_scm_srfi1_assoc
757 scm_t_trampoline_2 equal_p
;
758 if (SCM_UNBNDP (pred
))
759 equal_p
= equal_trampoline
;
762 equal_p
= scm_trampoline_2 (pred
);
763 SCM_ASSERT (equal_p
, pred
, 3, FUNC_NAME
);
765 for(; SCM_CONSP (ls
); ls
= SCM_CDR (ls
))
767 SCM tmp
= SCM_CAR (ls
);
768 SCM_ASSERT_TYPE (SCM_CONSP (tmp
), alist
, SCM_ARG2
, FUNC_NAME
,
770 if (scm_is_true (equal_p (pred
, SCM_CAR (tmp
), key
)))
773 SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls
), alist
, SCM_ARG2
, FUNC_NAME
,
779 SCM_DEFINE (scm_srfi1_partition
, "partition", 2, 0, 0,
780 (SCM pred
, SCM list
),
781 "Partition the elements of @var{list} with predicate @var{pred}.\n"
782 "Return two values: the list of elements satifying @var{pred} and\n"
783 "the list of elements @emph{not} satisfying @var{pred}. The order\n"
784 "of the output lists follows the order of @var{list}. @var{list}\n"
785 "is not mutated. One of the output lists may share memory with @var{list}.\n")
786 #define FUNC_NAME s_scm_srfi1_partition
788 /* In this implementation, the output lists don't share memory with
789 list, because it's probably not worth the effort. */
790 scm_t_trampoline_1 call
= scm_trampoline_1(pred
);
791 SCM kept
= scm_cons(SCM_EOL
, SCM_EOL
);
792 SCM kept_tail
= kept
;
793 SCM dropped
= scm_cons(SCM_EOL
, SCM_EOL
);
794 SCM dropped_tail
= dropped
;
796 SCM_ASSERT(call
, pred
, 2, FUNC_NAME
);
798 for (; !SCM_NULL_OR_NIL_P (list
); list
= SCM_CDR(list
)) {
799 SCM elt
= SCM_CAR(list
);
800 SCM new_tail
= scm_cons(SCM_CAR(list
), SCM_EOL
);
801 if (scm_is_true (call (pred
, elt
))) {
802 SCM_SETCDR(kept_tail
, new_tail
);
803 kept_tail
= new_tail
;
806 SCM_SETCDR(dropped_tail
, new_tail
);
807 dropped_tail
= new_tail
;
810 /* re-use the initial conses for the values list */
811 SCM_SETCAR(kept
, SCM_CDR(kept
));
812 SCM_SETCDR(kept
, dropped
);
813 SCM_SETCAR(dropped
, SCM_CDR(dropped
));
814 SCM_SETCDR(dropped
, SCM_EOL
);
815 return scm_values(kept
);
820 scm_init_srfi_1 (void)
822 SCM the_root_module
= scm_lookup_closure_module (SCM_BOOL_F
);
823 #ifndef SCM_MAGIC_SNARFER
824 #include "srfi/srfi-1.x"
826 scm_c_extend_primitive_generic
827 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "map")),
828 SCM_VARIABLE_REF (scm_c_lookup ("map")));
829 scm_c_extend_primitive_generic
830 (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module
, "for-each")),
831 SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
834 /* End of srfi-1.c. */