/* srfi-1.c --- SRFI-1 procedures for Guile
*
- * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003 Free Software
- * Foundation, Inc.
- *
+ * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006, 2008
+ * Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
#include <libguile.h>
#include <libguile/lang.h>
do {
if (SCM_NULL_OR_NIL_P(hare)) return i;
- if (!SCM_CONSP (hare)) return -2;
+ if (!scm_is_pair (hare)) return -2;
hare = SCM_CDR(hare);
i++;
if (SCM_NULL_OR_NIL_P(hare)) return i;
- if (!SCM_CONSP (hare)) return -2;
+ if (!scm_is_pair (hare)) return -2;
hare = SCM_CDR(hare);
i++;
/* For every two steps the hare takes, the tortoise takes one. */
return scm_equal_p (arg1, arg2);
}
+/* list_copy_part() copies the first COUNT cells of LST, puts the result at
+ *dst, and returns the SCM_CDRLOC of the last cell in that new list.
+
+ This function is designed to be careful about LST possibly having changed
+ in between the caller deciding what to copy, and the copy actually being
+ done here. The COUNT ensures we terminate if LST has become circular,
+ SCM_VALIDATE_CONS guards against a cdr in the list changed to some
+ non-pair object. */
+
+#include <stdio.h>
+static SCM *
+list_copy_part (SCM lst, int count, SCM *dst)
+#define FUNC_NAME "list_copy_part"
+{
+ SCM c;
+ for ( ; count > 0; count--)
+ {
+ SCM_VALIDATE_CONS (SCM_ARGn, lst);
+ c = scm_cons (SCM_CAR (lst), SCM_EOL);
+ *dst = c;
+ dst = SCM_CDRLOC (c);
+ lst = SCM_CDR (lst);
+ }
+ return dst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_alist_copy, "alist-copy", 1, 0, 0,
+ (SCM alist),
+ "Return a copy of @var{alist}, copying both the pairs comprising\n"
+ "the list and those making the associations.")
+#define FUNC_NAME s_scm_srfi1_alist_copy
+{
+ SCM ret, *p, elem, c;
+
+ /* ret is the list to return. p is where to append to it, initially &ret
+ then SCM_CDRLOC of the last pair. */
+ ret = SCM_EOL;
+ p = &ret;
+
+ for ( ; scm_is_pair (alist); alist = SCM_CDR (alist))
+ {
+ elem = SCM_CAR (alist);
+
+ /* each element of alist must be a pair */
+ SCM_ASSERT_TYPE (scm_is_pair (elem), alist, SCM_ARG1, FUNC_NAME,
+ "association list");
+
+ c = scm_cons (scm_cons (SCM_CAR (elem), SCM_CDR (elem)), SCM_EOL);
+ *p = c;
+ p = SCM_CDRLOC (c);
+ }
+
+ /* alist must be a proper list */
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (alist), alist, SCM_ARG1, FUNC_NAME,
+ "association list");
+ return ret;
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_srfi1_append_reverse, "append-reverse", 2, 0, 0,
+ (SCM revhead, SCM tail),
+ "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
+ "result. This is equivalent to @code{(append (reverse\n"
+ "@var{rev-head}) @var{tail})}, but its implementation is more\n"
+ "efficient.\n"
+ "\n"
+ "@example\n"
+ "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi1_append_reverse
+{
+ while (scm_is_pair (revhead))
+ {
+ /* copy first element of revhead onto front of tail */
+ tail = scm_cons (SCM_CAR (revhead), tail);
+ revhead = SCM_CDR (revhead);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
+ "list");
+ return tail;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_append_reverse_x, "append-reverse!", 2, 0, 0,
+ (SCM revhead, SCM tail),
+ "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
+ "result. This is equivalent to @code{(append! (reverse!\n"
+ "@var{rev-head}) @var{tail})}, but its implementation is more\n"
+ "efficient.\n"
+ "\n"
+ "@example\n"
+ "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
+ "@end example\n"
+ "\n"
+ "@var{rev-head} may be modified in order to produce the result.")
+#define FUNC_NAME s_scm_srfi1_append_reverse_x
+{
+ SCM newtail;
+
+ while (scm_is_pair (revhead))
+ {
+ /* take the first cons cell from revhead */
+ newtail = revhead;
+ revhead = SCM_CDR (revhead);
+
+ /* make it the new start of tail, appending the previous */
+ SCM_SETCDR (newtail, tail);
+ tail = newtail;
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
+ "list");
+ return tail;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_break, "break", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return two values, the longest initial prefix of @var{lst}\n"
+ "whose elements all fail the predicate @var{pred}, and the\n"
+ "remainder of @var{lst}.\n"
+ "\n"
+ "Note that the name @code{break} conflicts with the @code{break}\n"
+ "binding established by @code{while}. Applications wanting to\n"
+ "use @code{break} from within a @code{while} loop will need to\n"
+ "make a new define under a different name.")
+#define FUNC_NAME s_scm_srfi1_break
+{
+ scm_t_trampoline_1 pred_tramp;
+ SCM ret, *p;
+
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ ret = SCM_EOL;
+ p = &ret;
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ SCM elem = SCM_CAR (lst);
+ if (scm_is_true (pred_tramp (pred, elem)))
+ goto done;
+
+ /* want this elem, tack it onto the end of ret */
+ *p = scm_cons (elem, SCM_EOL);
+ p = SCM_CDRLOC (*p);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ done:
+ return scm_values (scm_list_2 (ret, lst));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_break_x, "break!", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return two values, the longest initial prefix of @var{lst}\n"
+ "whose elements all fail the predicate @var{pred}, and the\n"
+ "remainder of @var{lst}. @var{lst} may be modified to form the\n"
+ "return.")
+#define FUNC_NAME s_scm_srfi1_break_x
+{
+ SCM upto, *p;
+ scm_t_trampoline_1 pred_tramp;
+
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ p = &lst;
+ for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
+ {
+ if (scm_is_true (pred_tramp (pred, SCM_CAR (upto))))
+ goto done;
+
+ /* want this element */
+ p = SCM_CDRLOC (upto);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ done:
+ *p = SCM_EOL;
+ return scm_values (scm_list_2 (lst, upto));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_car_plus_cdr, "car+cdr", 1, 0, 0,
+ (SCM pair),
+ "Return two values, the @sc{car} and the @sc{cdr} of @var{pair}.")
+#define FUNC_NAME s_scm_srfi1_car_plus_cdr
+{
+ SCM_VALIDATE_CONS (SCM_ARG1, pair);
+ return scm_values (scm_list_2 (SCM_CAR (pair), SCM_CDR (pair)));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0,
+ (SCM lstlst),
+ "Construct a list by appending all lists in @var{lstlst}.\n"
+ "\n"
+ "@code{concatenate} is the same as @code{(apply append\n"
+ "@var{lstlst})}. It exists because some Scheme implementations\n"
+ "have a limit on the number of arguments a function takes, which\n"
+ "the @code{apply} might exceed. In Guile there is no such\n"
+ "limit.")
+#define FUNC_NAME s_scm_srfi1_concatenate
+{
+ SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
+ return scm_append (lstlst);
+}
+#undef FUNC_NAME
-/* scm_append and scm_append_x don't modify their list argument (only the
- lists within that list in the case of scm_append_x), hence making them
- suitable for direct use for concatentate. */
-SCM_REGISTER_PROC (s_srfi1_concatenate, "concatenate", 1, 0, 0, scm_append);
-SCM_REGISTER_PROC (s_srfi1_concatenate_x, "concatenate!", 1, 0, 0, scm_append_x);
+SCM_DEFINE (scm_srfi1_concatenate_x, "concatenate!", 1, 0, 0,
+ (SCM lstlst),
+ "Construct a list by appending all lists in @var{lstlst}. Those\n"
+ "lists may be modified to produce the result.\n"
+ "\n"
+ "@code{concatenate!} is the same as @code{(apply append!\n"
+ "@var{lstlst})}. It exists because some Scheme implementations\n"
+ "have a limit on the number of arguments a function takes, which\n"
+ "the @code{apply} might exceed. In Guile there is no such\n"
+ "limit.")
+#define FUNC_NAME s_scm_srfi1_concatenate
+{
+ SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
+ return scm_append_x (lstlst);
+}
+#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1,
#define FUNC_NAME s_scm_srfi1_count
{
long count;
+ SCM lst;
+ int argnum;
SCM_VALIDATE_REST_ARGUMENT (rest);
count = 0;
- if (SCM_NULLP (rest))
+ if (scm_is_null (rest))
{
/* one list */
scm_t_trampoline_1 pred_tramp;
pred_tramp = scm_trampoline_1 (pred);
SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
- for ( ; SCM_CONSP (list1); list1 = SCM_CDR (list1))
+ for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
count += scm_is_true (pred_tramp (pred, SCM_CAR (list1)));
- end_lst1:
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (list1), list1, SCM_ARG2, FUNC_NAME,
- "list");
+ /* check below that list1 is a proper list, and done */
+ end_list1:
+ lst = list1;
+ argnum = 2;
}
- else if (SCM_CONSP (rest) && SCM_NULLP (SCM_CDR (rest)))
+ else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
{
/* two lists */
scm_t_trampoline_2 pred_tramp;
list2 = SCM_CAR (rest);
for (;;)
{
- if (! SCM_CONSP (list1))
- goto end_lst1;
- if (! SCM_CONSP (list2))
+ if (! scm_is_pair (list1))
+ goto end_list1;
+ if (! scm_is_pair (list2))
{
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (list2), list2, SCM_ARG3,
- FUNC_NAME, "list");
+ lst = list2;
+ argnum = 3;
break;
}
count += scm_is_true (pred_tramp
else
{
/* three or more lists */
- SCM lstlst, args, l, a, lst;
- int argnum;
+ SCM vec, args, a;
+ size_t len, i;
- /* lstlst is a list of the list arguments */
- lstlst = scm_cons (list1, rest);
+ /* vec is the list arguments */
+ vec = scm_vector (scm_cons (list1, rest));
+ len = SCM_SIMPLE_VECTOR_LENGTH (vec);
- /* args is the argument list to pass to pred, same length as lstlst,
+ /* args is the argument list to pass to pred, same length as vec,
re-used for each call */
- args = SCM_EOL;
- for (l = lstlst; SCM_CONSP (l); l = SCM_CDR (l))
- args = scm_cons (SCM_BOOL_F, args);
+ args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
for (;;)
{
- /* first elem of each list in lstlst into args, and step those
- lstlst entries onto their next element */
- for (l = lstlst, a = args, argnum = 2;
- SCM_CONSP (l);
- l = SCM_CDR (l), a = SCM_CDR (a), argnum++)
+ /* first elem of each list in vec into args, and step those
+ vec entries onto their next element */
+ for (i = 0, a = args, argnum = 2;
+ i < len;
+ i++, a = SCM_CDR (a), argnum++)
{
- lst = SCM_CAR (l); /* list argument */
- if (! SCM_CONSP (lst))
- {
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst,
- argnum, FUNC_NAME, "list");
- goto done;
- }
+ lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
+ if (! scm_is_pair (lst))
+ goto check_lst_and_done;
SCM_SETCAR (a, SCM_CAR (lst)); /* arg for pred */
- SCM_SETCAR (l, SCM_CDR (lst)); /* keep rest of lst */
+ SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
}
count += scm_is_true (scm_apply (pred, args, SCM_EOL));
}
}
- done:
+
+ check_lst_and_done:
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
return scm_from_long (count);
}
#undef FUNC_NAME
{
scm_t_trampoline_2 equal_p;
SCM ret, *p, keeplst;
+ int count;
if (SCM_UNBNDP (pred))
return scm_delete (x, lst);
elements are considered.
Elements to be retained are not immediately copied, instead keeplst is
- the last pair in lst which is to be retained but not yet copied. When
- there's no more deletions, *p can be set to keeplst to share the
- remainder of the original lst. (The entire original lst if there's no
- deletions at all.) */
+ the last pair in lst which is to be retained but not yet copied, count
+ is how many from there are wanted. When there's no more deletions, *p
+ can be set to keeplst to share the remainder of the original lst. (The
+ entire original lst if there's no deletions at all.) */
keeplst = lst;
- ret = SCM_EOL;
+ count = 0;
p = &ret;
- for ( ; SCM_CONSP (lst); lst = SCM_CDR (lst))
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
{
if (scm_is_true (equal_p (pred, x, SCM_CAR (lst))))
{
- /* delete this element, so copy from keeplst (inclusive) to lst
- (exclusive) onto ret */
- while (! scm_is_eq (keeplst, lst))
- {
- SCM c = scm_cons (SCM_CAR (keeplst), SCM_EOL);
- *p = c;
- p = SCM_CDRLOC (c);
- keeplst = SCM_CDR (keeplst);
- }
-
+ /* delete this element, so copy those at keeplst */
+ p = list_copy_part (keeplst, count, p);
keeplst = SCM_CDR (lst);
+ count = 0;
+ }
+ else
+ {
+ /* keep this element */
+ count++;
}
}
SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME);
for (prev = &lst, walk = lst;
- SCM_CONSP (walk);
+ scm_is_pair (walk);
walk = SCM_CDR (walk))
{
if (scm_is_true (equal_p (pred, x, SCM_CAR (walk))))
{
scm_t_trampoline_2 equal_p;
SCM ret, *p, keeplst, item, l;
+ int count, i;
/* ret is the new list constructed. p is where to append, initially &ret
then SCM_CDRLOC of the last pair. lst is advanced as each element is
deletions.) */
/* skip to end if an empty list (or something invalid) */
- ret = lst;
- if (SCM_CONSP (lst))
+ ret = SCM_EOL;
+
+ if (SCM_UNBNDP (pred))
+ equal_p = equal_trampoline;
+ else
{
- if (SCM_UNBNDP (pred))
- equal_p = equal_trampoline;
- else
- {
- equal_p = scm_trampoline_2 (pred);
- SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME);
- }
+ equal_p = scm_trampoline_2 (pred);
+ SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME);
+ }
- keeplst = lst;
- p = &ret;
+ keeplst = lst;
+ count = 0;
+ p = &ret;
- /* loop over lst elements starting from second */
- for (;;)
- {
- lst = SCM_CDR (lst);
- if (! SCM_CONSP (lst))
- break;
- item = SCM_CAR (lst);
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ item = SCM_CAR (lst);
- /* loop searching ret upto lst */
- for (l = ret; ! scm_is_eq (l, lst); l = SCM_CDR (l))
+ /* look for item in "ret" list */
+ for (l = ret; scm_is_pair (l); l = SCM_CDR (l))
+ {
+ if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
{
- if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
- {
- /* duplicate, don't want this element, so copy keeplst
- (inclusive) to lst (exclusive) onto ret */
- while (! scm_is_eq (keeplst, lst))
- {
- SCM c = scm_cons (SCM_CAR (keeplst), SCM_EOL);
- *p = c;
- p = SCM_CDRLOC (c);
- keeplst = SCM_CDR (keeplst);
- }
-
- keeplst = SCM_CDR (lst); /* elem after the one deleted */
- *p = keeplst;
- break;
- }
+ /* "item" is a duplicate, so copy keeplst onto ret */
+ duplicate:
+ p = list_copy_part (keeplst, count, p);
+
+ keeplst = SCM_CDR (lst); /* elem after the one deleted */
+ count = 0;
+ goto next_elem;
}
}
- }
- /* demand that lst was a proper list */
+ /* look for item in "keeplst" list
+ be careful traversing, in case nasty code changed the cdrs */
+ for (i = 0, l = keeplst;
+ i < count && scm_is_pair (l);
+ i++, l = SCM_CDR (l))
+ if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
+ goto duplicate;
+
+ /* keep this element */
+ count++;
+
+ next_elem:
+ ;
+ }
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list");
+ /* share tail of keeplst items */
+ *p = keeplst;
+
return ret;
}
#undef FUNC_NAME
/* skip to end if an empty list (or something invalid) */
ret = lst;
- if (SCM_CONSP (lst))
+ if (scm_is_pair (lst))
{
if (SCM_UNBNDP (pred))
equal_p = equal_trampoline;
for (;;)
{
lst = SCM_CDR (lst);
- if (! SCM_CONSP (lst))
+ if (! scm_is_pair (lst))
break;
item = SCM_CAR (lst);
#undef FUNC_NAME
-SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
- (SCM lst),
- "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
- "circular.")
-#define FUNC_NAME s_scm_srfi1_length_plus
+SCM_DEFINE (scm_srfi1_drop_right, "drop-right", 2, 0, 0,
+ (SCM lst, SCM n),
+ "Return a new list containing all except the last @var{n}\n"
+ "elements of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_drop_right
{
- long len = scm_ilength (lst);
- return (len >= 0 ? SCM_I_MAKINUM (len) : SCM_BOOL_F);
+ SCM tail = scm_list_tail (lst, n);
+ SCM ret = SCM_EOL;
+ SCM *rend = &ret;
+ while (scm_is_pair (tail))
+ {
+ *rend = scm_cons (SCM_CAR (lst), SCM_EOL);
+ rend = SCM_CDRLOC (*rend);
+
+ lst = SCM_CDR (lst);
+ tail = SCM_CDR (tail);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
+ return ret;
}
#undef FUNC_NAME
-/* This routine differs from the core list-copy in allowing improper lists.
- Maybe the core could allow them similarly. */
-
-SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0,
- (SCM lst),
- "Return a copy of the given list @var{lst}.\n"
- "\n"
- "@var{lst} can be a proper or improper list. And if @var{lst}\n"
- "is not a pair then it's treated as the final tail of an\n"
- "improper list and simply returned.")
-#define FUNC_NAME s_scm_srfi1_list_copy
+SCM_DEFINE (scm_srfi1_drop_right_x, "drop-right!", 2, 0, 0,
+ (SCM lst, SCM n),
+ "Return the a list containing the @var{n} last elements of\n"
+ "@var{lst}. @var{lst} may be modified to build the return.")
+#define FUNC_NAME s_scm_srfi1_drop_right_x
{
- SCM newlst;
- SCM * fill_here;
- SCM from_here;
+ SCM tail, *p;
- newlst = lst;
- fill_here = &newlst;
- from_here = lst;
+ if (scm_is_eq (n, SCM_INUM0))
+ return lst;
- while (SCM_CONSP (from_here))
- {
- SCM c;
- c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
- *fill_here = c;
- fill_here = SCM_CDRLOC (c);
- from_here = SCM_CDR (from_here);
- }
- return newlst;
+ tail = scm_list_tail (lst, n);
+ p = &lst;
+
+ /* p and tail work along the list, p being the cdrloc of the cell n steps
+ behind tail */
+ for ( ; scm_is_pair (tail); tail = SCM_CDR (tail))
+ p = SCM_CDRLOC (*p);
+
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
+
+ *p = SCM_EOL;
+ return lst;
}
#undef FUNC_NAME
-/* Typechecking for multi-argument MAP and FOR-EACH.
-
- Verify that each element of the vector ARGV, except for the first,
- is a list and return minimum length. Attribute errors to WHO,
- and claim that the i'th element of ARGV is WHO's i+2'th argument. */
-static inline int
-check_map_args (SCM argv,
- long len,
- SCM gf,
- SCM proc,
- SCM args,
- const char *who)
+SCM_DEFINE (scm_srfi1_drop_while, "drop-while", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Drop the longest initial prefix of @var{lst} whose elements all\n"
+ "satisfy the predicate @var{pred}.")
+#define FUNC_NAME s_scm_srfi1_drop_while
{
- long i;
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
- for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (argv, i);
- long elt_len;
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ if (scm_is_false (pred_tramp (pred, SCM_CAR (lst))))
+ goto done;
- if (!(SCM_NULLP (elt) || SCM_CONSP (elt)))
- {
- check_map_error:
- if (gf)
- scm_apply_generic (gf, scm_cons (proc, args));
- else
- scm_wrong_type_arg (who, i + 2, elt);
- }
-
- elt_len = srfi1_ilength (elt);
- if (elt_len < -1)
- goto check_map_error;
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+ done:
+ return lst;
+}
+#undef FUNC_NAME
- if (len < 0 || (elt_len >= 0 && elt_len < len))
- len = elt_len;
- }
- if (len < 0)
- /* i == 0 */
- goto check_map_error;
-
- scm_remember_upto_here_1 (argv);
- return len;
+
+SCM_DEFINE (scm_srfi1_eighth, "eighth", 1, 0, 0,
+ (SCM lst),
+ "Return the eighth element of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_eighth
+{
+ return scm_list_ref (lst, SCM_I_MAKINUM (7));
}
+#undef FUNC_NAME
-SCM_GPROC (s_srfi1_map, "map", 2, 0, 1, scm_srfi1_map, g_srfi1_map);
+SCM_DEFINE (scm_srfi1_fifth, "fifth", 1, 0, 0,
+ (SCM lst),
+ "Return the fifth element of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_fifth
+{
+ return scm_list_ref (lst, SCM_I_MAKINUM (4));
+}
+#undef FUNC_NAME
-/* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
- sequentially, starting with the first element(s). This is used in
- the Scheme procedure `map-in-order', which guarantees sequential
- behaviour, is implemented using scm_map. If the behaviour changes,
- we need to update `map-in-order'.
-*/
-SCM
-scm_srfi1_map (SCM proc, SCM arg1, SCM args)
-#define FUNC_NAME s_srfi1_map
+SCM_DEFINE (scm_srfi1_filter_map, "filter-map", 2, 0, 1,
+ (SCM proc, SCM list1, SCM rest),
+ "Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
+ "return a list of the results as per SRFI-1 @code{map}, except\n"
+ "that any @code{#f} results are omitted from the list returned.")
+#define FUNC_NAME s_scm_srfi1_filter_map
{
- long i, len;
- SCM res = SCM_EOL;
- SCM *pres = &res;
+ SCM ret, *loc, elem, newcell, lst;
+ int argnum;
- len = srfi1_ilength (arg1);
- SCM_GASSERTn ((SCM_NULLP (arg1) || SCM_CONSP (arg1)) && len >= -1,
- g_srfi1_map,
- scm_cons2 (proc, arg1, args), SCM_ARG2, s_srfi1_map);
- SCM_VALIDATE_REST_ARGUMENT (args);
- if (SCM_NULLP (args))
- {
- scm_t_trampoline_1 call = scm_trampoline_1 (proc);
- SCM_GASSERT2 (call, g_srfi1_map, proc, arg1, SCM_ARG1, s_srfi1_map);
- SCM_GASSERT2 (len >= 0, g_srfi1_map, proc, arg1, SCM_ARG2, s_srfi1_map);
- while (SCM_NIMP (arg1))
- {
- *pres = scm_list_1 (call (proc, SCM_CAR (arg1)));
- pres = SCM_CDRLOC (*pres);
- arg1 = SCM_CDR (arg1);
- }
- return res;
- }
- if (SCM_NULLP (SCM_CDR (args)))
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ ret = SCM_EOL;
+ loc = &ret;
+
+ if (scm_is_null (rest))
{
- SCM arg2 = SCM_CAR (args);
+ /* one list */
+ scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
+ {
+ elem = proc_tramp (proc, SCM_CAR (list1));
+ if (scm_is_true (elem))
+ {
+ newcell = scm_cons (elem, SCM_EOL);
+ *loc = newcell;
+ loc = SCM_CDRLOC (newcell);
+ }
+ }
+
+ /* check below that list1 is a proper list, and done */
+ end_list1:
+ lst = list1;
+ argnum = 2;
+ }
+ else if (scm_is_null (SCM_CDR (rest)))
+ {
+ /* two lists */
+ scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
+ SCM list2 = SCM_CAR (rest);
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+ for (;;)
+ {
+ if (! scm_is_pair (list1))
+ goto end_list1;
+ if (! scm_is_pair (list2))
+ {
+ lst = list2;
+ argnum = 3;
+ goto check_lst_and_done;
+ }
+ elem = proc_tramp (proc, SCM_CAR (list1), SCM_CAR (list2));
+ if (scm_is_true (elem))
+ {
+ newcell = scm_cons (elem, SCM_EOL);
+ *loc = newcell;
+ loc = SCM_CDRLOC (newcell);
+ }
+ list1 = SCM_CDR (list1);
+ list2 = SCM_CDR (list2);
+ }
+ }
+ else
+ {
+ /* three or more lists */
+ SCM vec, args, a;
+ size_t len, i;
+
+ /* vec is the list arguments */
+ vec = scm_vector (scm_cons (list1, rest));
+ len = SCM_SIMPLE_VECTOR_LENGTH (vec);
+
+ /* args is the argument list to pass to proc, same length as vec,
+ re-used for each call */
+ args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
+
+ for (;;)
+ {
+ /* first elem of each list in vec into args, and step those
+ vec entries onto their next element */
+ for (i = 0, a = args, argnum = 2;
+ i < len;
+ i++, a = SCM_CDR (a), argnum++)
+ {
+ lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
+ if (! scm_is_pair (lst))
+ goto check_lst_and_done;
+ SCM_SETCAR (a, SCM_CAR (lst)); /* arg for proc */
+ SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
+ }
+
+ elem = scm_apply (proc, args, SCM_EOL);
+ if (scm_is_true (elem))
+ {
+ newcell = scm_cons (elem, SCM_EOL);
+ *loc = newcell;
+ loc = SCM_CDRLOC (newcell);
+ }
+ }
+ }
+
+ check_lst_and_done:
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_find, "find", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return the first element of @var{lst} which satisfies the\n"
+ "predicate @var{pred}, or return @code{#f} if no such element is\n"
+ "found.")
+#define FUNC_NAME s_scm_srfi1_find
+{
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ SCM elem = SCM_CAR (lst);
+ if (scm_is_true (pred_tramp (pred, elem)))
+ return elem;
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
+ "predicate @var{pred}, or return @code{#f} if no such element is\n"
+ "found.")
+#define FUNC_NAME s_scm_srfi1_find_tail
+{
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ if (scm_is_true (pred_tramp (pred, SCM_CAR (lst))))
+ return lst;
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_fold, "fold", 3, 0, 1,
+ (SCM proc, SCM init, SCM list1, SCM rest),
+ "Apply @var{proc} to the elements of @var{lst1} @dots{}\n"
+ "@var{lstN} to build a result, and return that result.\n"
+ "\n"
+ "Each @var{proc} call is @code{(@var{proc} @var{elem1} @dots{}\n"
+ "@var{elemN} @var{previous})}, where @var{elem1} is from\n"
+ "@var{lst1}, through @var{elemN} from @var{lstN}.\n"
+ "@var{previous} is the return from the previous call to\n"
+ "@var{proc}, or the given @var{init} for the first call. If any\n"
+ "list is empty, just @var{init} is returned.\n"
+ "\n"
+ "@code{fold} works through the list elements from first to last.\n"
+ "The following shows a list reversal and the calls it makes,\n"
+ "\n"
+ "@example\n"
+ "(fold cons '() '(1 2 3))\n"
+ "\n"
+ "(cons 1 '())\n"
+ "(cons 2 '(1))\n"
+ "(cons 3 '(2 1)\n"
+ "@result{} (3 2 1)\n"
+ "@end example\n"
+ "\n"
+ "If @var{lst1} through @var{lstN} have different lengths,\n"
+ "@code{fold} stops when the end of the shortest is reached.\n"
+ "Ie.@: elements past the length of the shortest are ignored in\n"
+ "the other @var{lst}s. At least one @var{lst} must be\n"
+ "non-circular.\n"
+ "\n"
+ "The way @code{fold} builds a result from iterating is quite\n"
+ "general, it can do more than other iterations like say\n"
+ "@code{map} or @code{filter}. The following for example removes\n"
+ "adjacent duplicate elements from a list,\n"
+ "\n"
+ "@example\n"
+ "(define (delete-adjacent-duplicates lst)\n"
+ " (fold-right (lambda (elem ret)\n"
+ " (if (equal? elem (first ret))\n"
+ " ret\n"
+ " (cons elem ret)))\n"
+ " (list (last lst))\n"
+ " lst))\n"
+ "(delete-adjacent-duplicates '(1 2 3 3 4 4 4 5))\n"
+ "@result{} (1 2 3 4 5)\n"
+ "@end example\n"
+ "\n"
+ "Clearly the same sort of thing can be done with a\n"
+ "@code{for-each} and a variable in which to build the result,\n"
+ "but a self-contained @var{proc} can be re-used in multiple\n"
+ "contexts, where a @code{for-each} would have to be written out\n"
+ "each time.")
+#define FUNC_NAME s_scm_srfi1_fold
+{
+ SCM lst;
+ int argnum;
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ if (scm_is_null (rest))
+ {
+ /* one list */
+ scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
+ init = proc_tramp (proc, SCM_CAR (list1), init);
+
+ /* check below that list1 is a proper list, and done */
+ lst = list1;
+ argnum = 2;
+ }
+ else
+ {
+ /* two or more lists */
+ SCM vec, args, a;
+ size_t len, i;
+
+ /* vec is the list arguments */
+ vec = scm_vector (scm_cons (list1, rest));
+ len = SCM_SIMPLE_VECTOR_LENGTH (vec);
+
+ /* args is the argument list to pass to proc, same length as vec,
+ re-used for each call */
+ args = scm_make_list (SCM_I_MAKINUM (len+1), SCM_UNDEFINED);
+
+ for (;;)
+ {
+ /* first elem of each list in vec into args, and step those
+ vec entries onto their next element */
+ for (i = 0, a = args, argnum = 2;
+ i < len;
+ i++, a = SCM_CDR (a), argnum++)
+ {
+ lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
+ if (! scm_is_pair (lst))
+ goto check_lst_and_done;
+ SCM_SETCAR (a, SCM_CAR (lst)); /* arg for proc */
+ SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
+ }
+ SCM_SETCAR (a, init);
+
+ init = scm_apply (proc, args, SCM_EOL);
+ }
+ }
+
+ check_lst_and_done:
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
+ return init;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_last, "last", 1, 0, 0,
+ (SCM lst),
+ "Like @code{cons}, but with interchanged arguments. Useful\n"
+ "mostly when passed to higher-order procedures.")
+#define FUNC_NAME s_scm_srfi1_last
+{
+ SCM pair = scm_last_pair (lst);
+ /* scm_last_pair returns SCM_EOL for an empty list */
+ SCM_VALIDATE_CONS (SCM_ARG1, pair);
+ return SCM_CAR (pair);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
+ (SCM lst),
+ "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
+ "circular.")
+#define FUNC_NAME s_scm_srfi1_length_plus
+{
+ long len = scm_ilength (lst);
+ return (len >= 0 ? SCM_I_MAKINUM (len) : SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_list_index, "list-index", 2, 0, 1,
+ (SCM pred, SCM list1, SCM rest),
+ "Return the index of the first set of elements, one from each of\n"
+ "@var{lst1}@dots{}@var{lstN}, which satisfies @var{pred}.\n"
+ "\n"
+ "@var{pred} is called as @code{(@var{pred} elem1 @dots{}\n"
+ "elemN)}. Searching stops when the end of the shortest\n"
+ "@var{lst} is reached. The return index starts from 0 for the\n"
+ "first set of elements. If no set of elements pass then the\n"
+ "return is @code{#f}.\n"
+ "\n"
+ "@example\n"
+ "(list-index odd? '(2 4 6 9)) @result{} 3\n"
+ "(list-index = '(1 2 3) '(3 1 2)) @result{} #f\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi1_list_index
+{
+ long n = 0;
+ SCM lst;
+ int argnum;
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ if (scm_is_null (rest))
+ {
+ /* one list */
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (list1); n++, list1 = SCM_CDR (list1))
+ if (scm_is_true (pred_tramp (pred, SCM_CAR (list1))))
+ return SCM_I_MAKINUM (n);
+
+ /* not found, check below that list1 is a proper list */
+ end_list1:
+ lst = list1;
+ argnum = 2;
+ }
+ else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
+ {
+ /* two lists */
+ SCM list2 = SCM_CAR (rest);
+ scm_t_trampoline_2 pred_tramp = scm_trampoline_2 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ for ( ; ; n++)
+ {
+ if (! scm_is_pair (list1))
+ goto end_list1;
+ if (! scm_is_pair (list2))
+ {
+ lst = list2;
+ argnum = 3;
+ break;
+ }
+ if (scm_is_true (pred_tramp (pred,
+ SCM_CAR (list1), SCM_CAR (list2))))
+ return SCM_I_MAKINUM (n);
+
+ list1 = SCM_CDR (list1);
+ list2 = SCM_CDR (list2);
+ }
+ }
+ else
+ {
+ /* three or more lists */
+ SCM vec, args, a;
+ size_t len, i;
+
+ /* vec is the list arguments */
+ vec = scm_vector (scm_cons (list1, rest));
+ len = SCM_SIMPLE_VECTOR_LENGTH (vec);
+
+ /* args is the argument list to pass to pred, same length as vec,
+ re-used for each call */
+ args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
+
+ for ( ; ; n++)
+ {
+ /* first elem of each list in vec into args, and step those
+ vec entries onto their next element */
+ for (i = 0, a = args, argnum = 2;
+ i < len;
+ i++, a = SCM_CDR (a), argnum++)
+ {
+ lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
+ if (! scm_is_pair (lst))
+ goto not_found_check_lst;
+ SCM_SETCAR (a, SCM_CAR (lst)); /* arg for pred */
+ SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
+ }
+
+ if (scm_is_true (scm_apply (pred, args, SCM_EOL)))
+ return SCM_I_MAKINUM (n);
+ }
+ }
+
+ not_found_check_lst:
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+/* This routine differs from the core list-copy in allowing improper lists.
+ Maybe the core could allow them similarly. */
+
+SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0,
+ (SCM lst),
+ "Return a copy of the given list @var{lst}.\n"
+ "\n"
+ "@var{lst} can be a proper or improper list. And if @var{lst}\n"
+ "is not a pair then it's treated as the final tail of an\n"
+ "improper list and simply returned.")
+#define FUNC_NAME s_scm_srfi1_list_copy
+{
+ SCM newlst;
+ SCM * fill_here;
+ SCM from_here;
+
+ newlst = lst;
+ fill_here = &newlst;
+ from_here = lst;
+
+ while (scm_is_pair (from_here))
+ {
+ SCM c;
+ c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
+ *fill_here = c;
+ fill_here = SCM_CDRLOC (c);
+ from_here = SCM_CDR (from_here);
+ }
+ return newlst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_list_tabulate, "list-tabulate", 2, 0, 0,
+ (SCM n, SCM proc),
+ "Return an @var{n}-element list, where each list element is\n"
+ "produced by applying the procedure @var{init-proc} to the\n"
+ "corresponding list index. The order in which @var{init-proc}\n"
+ "is applied to the indices is not specified.")
+#define FUNC_NAME s_scm_srfi1_list_tabulate
+{
+ long i, nn;
+ scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
+ SCM ret = SCM_EOL;
+
+ nn = scm_to_signed_integer (n, 0, LONG_MAX);
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG2, FUNC_NAME);
+
+ for (i = nn-1; i >= 0; i--)
+ ret = scm_cons (proc_tramp (proc, scm_from_long (i)), ret);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_lset_adjoin, "lset-adjoin", 2, 0, 1,
+ (SCM equal, SCM lst, SCM rest),
+ "Add to @var{list} any of the given @var{elem}s not already in\n"
+ "the list. @var{elem}s are @code{cons}ed onto the start of\n"
+ "@var{list} (so the return shares a common tail with\n"
+ "@var{list}), but the order they're added is unspecified.\n"
+ "\n"
+ "The given @var{=} procedure is used for comparing elements,\n"
+ "called as @code{(@var{=} listelem elem)}, ie.@: the second\n"
+ "argument is one of the given @var{elem} parameters.\n"
+ "\n"
+ "@example\n"
+ "(lset-adjoin eqv? '(1 2 3) 4 1 5) @result{} (5 4 1 2 3)\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi1_lset_adjoin
+{
+ scm_t_trampoline_2 equal_tramp;
+ SCM l, elem;
+
+ equal_tramp = scm_trampoline_2 (equal);
+ SCM_ASSERT (equal_tramp, equal, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ /* It's not clear if duplicates among the `rest' elements are meant to be
+ cast out. The spec says `=' is called as (= list-elem rest-elem),
+ suggesting perhaps not, but the reference implementation shows the
+ "list" at each stage as including those "rest" elements already added.
+ The latter corresponds to what's described for lset-union, so that's
+ what's done here. */
+
+ for ( ; scm_is_pair (rest); rest = SCM_CDR (rest))
+ {
+ elem = SCM_CAR (rest);
+
+ for (l = lst; scm_is_pair (l); l = SCM_CDR (l))
+ if (scm_is_true (equal_tramp (equal, SCM_CAR (l), elem)))
+ goto next_elem; /* elem already in lst, don't add */
+
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(l), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ /* elem is not equal to anything already in lst, add it */
+ lst = scm_cons (elem, lst);
+
+ next_elem:
+ ;
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1,
+ (SCM equal, SCM lst, SCM rest),
+ "Return @var{lst} with any elements in the lists in @var{rest}\n"
+ "removed (ie.@: subtracted). For only one @var{lst} argument,\n"
+ "just that list is returned.\n"
+ "\n"
+ "The given @var{equal} procedure is used for comparing elements,\n"
+ "called as @code{(@var{equal} elem1 elemN)}. The first argument\n"
+ "is from @var{lst} and the second from one of the subsequent\n"
+ "lists. But exactly which calls are made and in what order is\n"
+ "unspecified.\n"
+ "\n"
+ "@example\n"
+ "(lset-difference! eqv? (list 'x 'y)) @result{} (x y)\n"
+ "(lset-difference! eqv? (list 1 2 3) '(3 1)) @result{} (2)\n"
+ "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n"
+ "@end example\n"
+ "\n"
+ "@code{lset-difference!} may modify @var{lst} to form its\n"
+ "result.")
+#define FUNC_NAME s_scm_srfi1_lset_difference_x
+{
+ scm_t_trampoline_2 equal_tramp = scm_trampoline_2 (equal);
+ SCM ret, *pos, elem, r, b;
+ int argnum;
+
+ SCM_ASSERT (equal_tramp, equal, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ ret = SCM_EOL;
+ pos = &ret;
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ elem = SCM_CAR (lst);
+
+ for (r = rest, argnum = SCM_ARG3;
+ scm_is_pair (r);
+ r = SCM_CDR (r), argnum++)
+ {
+ for (b = SCM_CAR (r); scm_is_pair (b); b = SCM_CDR (b))
+ if (scm_is_true (equal_tramp (equal, elem, SCM_CAR (b))))
+ goto next_elem; /* equal to elem, so drop that elem */
+
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b), b, argnum, FUNC_NAME,"list");
+ }
+
+ /* elem not equal to anything in later lists, so keep it */
+ *pos = lst;
+ pos = SCM_CDRLOC (lst);
+
+ next_elem:
+ ;
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ *pos = SCM_EOL;
+ return ret;
+}
+#undef FUNC_NAME
+
+
+/* Typechecking for multi-argument MAP and FOR-EACH.
+
+ Verify that each element of the vector ARGV, except for the first,
+ is a list and return minimum length. Attribute errors to WHO,
+ and claim that the i'th element of ARGV is WHO's i+2'th argument. */
+static inline int
+check_map_args (SCM argv,
+ long len,
+ SCM gf,
+ SCM proc,
+ SCM args,
+ const char *who)
+{
+ long i;
+ SCM elt;
+
+ for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
+ {
+ long elt_len;
+ elt = SCM_SIMPLE_VECTOR_REF (argv, i);
+
+ if (!(scm_is_null (elt) || scm_is_pair (elt)))
+ goto check_map_error;
+
+ elt_len = srfi1_ilength (elt);
+ if (elt_len < -1)
+ goto check_map_error;
+
+ if (len < 0 || (elt_len >= 0 && elt_len < len))
+ len = elt_len;
+ }
+
+ if (len < 0)
+ {
+ /* i == 0 */
+ elt = SCM_EOL;
+ check_map_error:
+ if (gf)
+ scm_apply_generic (gf, scm_cons (proc, args));
+ else
+ scm_wrong_type_arg (who, i + 2, elt);
+ }
+
+ scm_remember_upto_here_1 (argv);
+ return len;
+}
+
+
+SCM_GPROC (s_srfi1_map, "map", 2, 0, 1, scm_srfi1_map, g_srfi1_map);
+
+/* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
+ sequentially, starting with the first element(s). This is used in
+ the Scheme procedure `map-in-order', which guarantees sequential
+ behaviour, is implemented using scm_map. If the behaviour changes,
+ we need to update `map-in-order'.
+*/
+
+SCM
+scm_srfi1_map (SCM proc, SCM arg1, SCM args)
+#define FUNC_NAME s_srfi1_map
+{
+ long i, len;
+ SCM res = SCM_EOL;
+ SCM *pres = &res;
+
+ len = srfi1_ilength (arg1);
+ SCM_GASSERTn ((scm_is_null (arg1) || scm_is_pair (arg1)) && len >= -1,
+ g_srfi1_map,
+ scm_cons2 (proc, arg1, args), SCM_ARG2, s_srfi1_map);
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ if (scm_is_null (args))
+ {
+ scm_t_trampoline_1 call = scm_trampoline_1 (proc);
+ SCM_GASSERT2 (call, g_srfi1_map, proc, arg1, SCM_ARG1, s_srfi1_map);
+ SCM_GASSERT2 (len >= 0, g_srfi1_map, proc, arg1, SCM_ARG2, s_srfi1_map);
+ while (SCM_NIMP (arg1))
+ {
+ *pres = scm_list_1 (call (proc, SCM_CAR (arg1)));
+ pres = SCM_CDRLOC (*pres);
+ arg1 = SCM_CDR (arg1);
+ }
+ return res;
+ }
+ if (scm_is_null (SCM_CDR (args)))
+ {
+ SCM arg2 = SCM_CAR (args);
int len2 = srfi1_ilength (arg2);
scm_t_trampoline_2 call = scm_trampoline_2 (proc);
SCM_GASSERTn (call, g_srfi1_map,
scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_map);
if (len < 0 || (len2 >= 0 && len2 < len))
len = len2;
- SCM_GASSERTn ((SCM_NULLP (arg2) || SCM_CONSP (arg2))
+ SCM_GASSERTn ((scm_is_null (arg2) || scm_is_pair (arg2))
&& len >= 0 && len2 >= -1,
g_srfi1_map,
scm_cons2 (proc, arg1, args),
{
long i, len;
len = srfi1_ilength (arg1);
- SCM_GASSERTn ((SCM_NULLP (arg1) || SCM_CONSP (arg1)) && len >= -1,
+ SCM_GASSERTn ((scm_is_null (arg1) || scm_is_pair (arg1)) && len >= -1,
g_srfi1_for_each, scm_cons2 (proc, arg1, args),
SCM_ARG2, s_srfi1_for_each);
SCM_VALIDATE_REST_ARGUMENT (args);
- if (SCM_NULLP (args))
+ if (scm_is_null (args))
{
scm_t_trampoline_1 call = scm_trampoline_1 (proc);
SCM_GASSERT2 (call, g_srfi1_for_each, proc, arg1,
}
return SCM_UNSPECIFIED;
}
- if (SCM_NULLP (SCM_CDR (args)))
+ if (scm_is_null (SCM_CDR (args)))
{
SCM arg2 = SCM_CAR (args);
int len2 = srfi1_ilength (arg2);
scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_for_each);
if (len < 0 || (len2 >= 0 && len2 < len))
len = len2;
- SCM_GASSERTn ((SCM_NULLP (arg2) || SCM_CONSP (arg2))
+ SCM_GASSERTn ((scm_is_null (arg2) || scm_is_pair (arg2))
&& len >= 0 && len2 >= -1,
g_srfi1_for_each,
scm_cons2 (proc, arg1, args),
equal_p = scm_trampoline_2 (pred);
SCM_ASSERT (equal_p, pred, 3, FUNC_NAME);
}
- for(; SCM_CONSP (ls); ls = SCM_CDR (ls))
+ for(; scm_is_pair (ls); ls = SCM_CDR (ls))
{
SCM tmp = SCM_CAR (ls);
- SCM_ASSERT_TYPE (SCM_CONSP (tmp), alist, SCM_ARG2, FUNC_NAME,
+ SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
"association list");
- if (scm_is_true (equal_p (pred, SCM_CAR (tmp), key)))
+ if (scm_is_true (equal_p (pred, key, SCM_CAR (tmp))))
return tmp;
}
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
}
#undef FUNC_NAME
+
+SCM_DEFINE (scm_srfi1_ninth, "ninth", 1, 0, 0,
+ (SCM lst),
+ "Return the ninth element of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_ninth
+{
+ return scm_list_ref (lst, scm_from_int (8));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_not_pair_p, "not-pair?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} is @var{obj} is not a pair, @code{#f}\n"
+ "otherwise.\n"
+ "\n"
+ "This is shorthand notation @code{(not (pair? @var{obj}))} and\n"
+ "is supposed to be used for end-of-list checking in contexts\n"
+ "where dotted lists are allowed.")
+#define FUNC_NAME s_scm_srfi1_not_pair_p
+{
+ return scm_from_bool (! scm_is_pair (obj));
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
(SCM pred, SCM list),
"Partition the elements of @var{list} with predicate @var{pred}.\n"
/* In this implementation, the output lists don't share memory with
list, because it's probably not worth the effort. */
scm_t_trampoline_1 call = scm_trampoline_1(pred);
+ SCM orig_list = list;
SCM kept = scm_cons(SCM_EOL, SCM_EOL);
SCM kept_tail = kept;
SCM dropped = scm_cons(SCM_EOL, SCM_EOL);
SCM_ASSERT(call, pred, 2, FUNC_NAME);
for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) {
- SCM elt = SCM_CAR(list);
- SCM new_tail = scm_cons(SCM_CAR(list), SCM_EOL);
+ SCM elt, new_tail;
+
+ /* Make sure LIST is not a dotted list. */
+ SCM_ASSERT (scm_is_pair (list), orig_list, SCM_ARG2, FUNC_NAME);
+
+ elt = SCM_CAR (list);
+ new_tail = scm_cons (SCM_CAR (list), SCM_EOL);
+
if (scm_is_true (call (pred, elt))) {
SCM_SETCDR(kept_tail, new_tail);
kept_tail = new_tail;
}
#undef FUNC_NAME
+
+SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Split @var{lst} into those elements which do and don't satisfy\n"
+ "the predicate @var{pred}.\n"
+ "\n"
+ "The return is two values (@pxref{Multiple Values}), the first\n"
+ "being a list of all elements from @var{lst} which satisfy\n"
+ "@var{pred}, the second a list of those which do not.\n"
+ "\n"
+ "The elements in the result lists are in the same order as in\n"
+ "@var{lst} but the order in which the calls @code{(@var{pred}\n"
+ "elem)} are made on the list elements is unspecified.\n"
+ "\n"
+ "@var{lst} may be modified to construct the return lists.")
+#define FUNC_NAME s_scm_srfi1_partition_x
+{
+ SCM tlst, flst, *tp, *fp;
+ scm_t_trampoline_1 pred_tramp;
+
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ /* tlst and flst are the lists of true and false elements. tp and fp are
+ where to store to append to them, initially &tlst and &flst, then
+ SCM_CDRLOC of the last pair in the respective lists. */
+
+ tlst = SCM_EOL;
+ flst = SCM_EOL;
+ tp = &tlst;
+ fp = &flst;
+
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ if (scm_is_true (pred_tramp (pred, SCM_CAR (lst))))
+ {
+ *tp = lst;
+ tp = SCM_CDRLOC (lst);
+ }
+ else
+ {
+ *fp = lst;
+ fp = SCM_CDRLOC (lst);
+ }
+ }
+
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ /* terminate whichever didn't get the last element(s) */
+ *tp = SCM_EOL;
+ *fp = SCM_EOL;
+
+ return scm_values (scm_list_2 (tlst, flst));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_reduce, "reduce", 3, 0, 0,
+ (SCM proc, SCM def, SCM lst),
+ "@code{reduce} is a variant of @code{fold}, where the first call\n"
+ "to @var{proc} is on two elements from @var{lst}, rather than\n"
+ "one element and a given initial value.\n"
+ "\n"
+ "If @var{lst} is empty, @code{reduce} returns @var{def} (this is\n"
+ "the only use for @var{def}). If @var{lst} has just one element\n"
+ "then that's the return value. Otherwise @var{proc} is called\n"
+ "on the elements of @var{lst}.\n"
+ "\n"
+ "Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
+ "@var{previous})}, where @var{elem} is from @var{lst} (the\n"
+ "second and subsequent elements of @var{lst}), and\n"
+ "@var{previous} is the return from the previous call to\n"
+ "@var{proc}. The first element of @var{lst} is the\n"
+ "@var{previous} for the first call to @var{proc}.\n"
+ "\n"
+ "For example, the following adds a list of numbers, the calls\n"
+ "made to @code{+} are shown. (Of course @code{+} accepts\n"
+ "multiple arguments and can add a list directly, with\n"
+ "@code{apply}.)\n"
+ "\n"
+ "@example\n"
+ "(reduce + 0 '(5 6 7)) @result{} 18\n"
+ "\n"
+ "(+ 6 5) @result{} 11\n"
+ "(+ 7 11) @result{} 18\n"
+ "@end example\n"
+ "\n"
+ "@code{reduce} can be used instead of @code{fold} where the\n"
+ "@var{init} value is an ``identity'', meaning a value which\n"
+ "under @var{proc} doesn't change the result, in this case 0 is\n"
+ "an identity since @code{(+ 5 0)} is just 5. @code{reduce}\n"
+ "avoids that unnecessary call.")
+#define FUNC_NAME s_scm_srfi1_reduce
+{
+ scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
+ SCM ret;
+
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+ ret = def; /* if lst is empty */
+ if (scm_is_pair (lst))
+ {
+ ret = SCM_CAR (lst); /* if lst has one element */
+
+ for (lst = SCM_CDR (lst); scm_is_pair (lst); lst = SCM_CDR (lst))
+ ret = proc_tramp (proc, SCM_CAR (lst), ret);
+ }
+
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG3, FUNC_NAME, "list");
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_reduce_right, "reduce-right", 3, 0, 0,
+ (SCM proc, SCM def, SCM lst),
+ "@code{reduce-right} is a variant of @code{fold-right}, where\n"
+ "the first call to @var{proc} is on two elements from @var{lst},\n"
+ "rather than one element and a given initial value.\n"
+ "\n"
+ "If @var{lst} is empty, @code{reduce-right} returns @var{def}\n"
+ "(this is the only use for @var{def}). If @var{lst} has just\n"
+ "one element then that's the return value. Otherwise @var{proc}\n"
+ "is called on the elements of @var{lst}.\n"
+ "\n"
+ "Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
+ "@var{previous})}, where @var{elem} is from @var{lst} (the\n"
+ "second last and then working back to the first element of\n"
+ "@var{lst}), and @var{previous} is the return from the previous\n"
+ "call to @var{proc}. The last element of @var{lst} is the\n"
+ "@var{previous} for the first call to @var{proc}.\n"
+ "\n"
+ "For example, the following adds a list of numbers, the calls\n"
+ "made to @code{+} are shown. (Of course @code{+} accepts\n"
+ "multiple arguments and can add a list directly, with\n"
+ "@code{apply}.)\n"
+ "\n"
+ "@example\n"
+ "(reduce-right + 0 '(5 6 7)) @result{} 18\n"
+ "\n"
+ "(+ 6 7) @result{} 13\n"
+ "(+ 5 13) @result{} 18\n"
+ "@end example\n"
+ "\n"
+ "@code{reduce-right} can be used instead of @code{fold-right}\n"
+ "where the @var{init} value is an ``identity'', meaning a value\n"
+ "which under @var{proc} doesn't change the result, in this case\n"
+ "0 is an identity since @code{(+ 7 0)} is just 5.\n"
+ "@code{reduce-right} avoids that unnecessary call.\n"
+ "\n"
+ "@code{reduce} should be preferred over @code{reduce-right} if\n"
+ "the order of processing doesn't matter, or can be arranged\n"
+ "either way, since @code{reduce} is a little more efficient.")
+#define FUNC_NAME s_scm_srfi1_reduce_right
+{
+ /* To work backwards across a list requires either repeatedly traversing
+ to get each previous element, or using some memory for a reversed or
+ random-access form. Repeated traversal might not be too terrible, but
+ is of course quadratic complexity and hence to be avoided in case LST
+ is long. A vector is preferred over a reversed list since it's more
+ compact and is less work for the gc to collect. */
+
+ scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
+ SCM ret, vec;
+ long len, i;
+
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+ if (SCM_NULL_OR_NIL_P (lst))
+ return def;
+
+ vec = scm_vector (lst);
+ len = SCM_SIMPLE_VECTOR_LENGTH (vec);
+
+ ret = SCM_SIMPLE_VECTOR_REF (vec, len-1);
+ for (i = len-2; i >= 0; i--)
+ ret = proc_tramp (proc, SCM_SIMPLE_VECTOR_REF (vec, i), ret);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_remove, "remove", 2, 0, 0,
+ (SCM pred, SCM list),
+ "Return a list containing all elements from @var{lst} which do\n"
+ "not satisfy the predicate @var{pred}. The elements in the\n"
+ "result list have the same order as in @var{lst}. The order in\n"
+ "which @var{pred} is applied to the list elements is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_srfi1_remove
+{
+ scm_t_trampoline_1 call = scm_trampoline_1 (pred);
+ SCM walk;
+ SCM *prev;
+ SCM res = SCM_EOL;
+ SCM_ASSERT (call, pred, 1, FUNC_NAME);
+ SCM_VALIDATE_LIST (2, list);
+
+ for (prev = &res, walk = list;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_false (call (pred, SCM_CAR (walk))))
+ {
+ *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
+ prev = SCM_CDRLOC (*prev);
+ }
+ }
+
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
+ (SCM pred, SCM list),
+ "Return a list containing all elements from @var{list} which do\n"
+ "not satisfy the predicate @var{pred}. The elements in the\n"
+ "result list have the same order as in @var{list}. The order in\n"
+ "which @var{pred} is applied to the list elements is not\n"
+ "specified. @var{list} may be modified to build the return\n"
+ "list.")
+#define FUNC_NAME s_scm_srfi1_remove_x
+{
+ scm_t_trampoline_1 call = scm_trampoline_1 (pred);
+ SCM walk;
+ SCM *prev;
+ SCM_ASSERT (call, pred, 1, FUNC_NAME);
+ SCM_VALIDATE_LIST (2, list);
+
+ for (prev = &list, walk = list;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_false (call (pred, SCM_CAR (walk))))
+ prev = SCM_CDRLOC (walk);
+ else
+ *prev = SCM_CDR (walk);
+ }
+
+ return list;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_seventh, "seventh", 1, 0, 0,
+ (SCM lst),
+ "Return the seventh element of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_seventh
+{
+ return scm_list_ref (lst, scm_from_int (6));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_sixth, "sixth", 1, 0, 0,
+ (SCM lst),
+ "Return the sixth element of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_sixth
+{
+ return scm_list_ref (lst, scm_from_int (5));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_span, "span", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return two values, the longest initial prefix of @var{lst}\n"
+ "whose elements all satisfy the predicate @var{pred}, and the\n"
+ "remainder of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_span
+{
+ scm_t_trampoline_1 pred_tramp;
+ SCM ret, *p;
+
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ ret = SCM_EOL;
+ p = &ret;
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ SCM elem = SCM_CAR (lst);
+ if (scm_is_false (pred_tramp (pred, elem)))
+ goto done;
+
+ /* want this elem, tack it onto the end of ret */
+ *p = scm_cons (elem, SCM_EOL);
+ p = SCM_CDRLOC (*p);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ done:
+ return scm_values (scm_list_2 (ret, lst));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_span_x, "span!", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return two values, the longest initial prefix of @var{lst}\n"
+ "whose elements all satisfy the predicate @var{pred}, and the\n"
+ "remainder of @var{lst}. @var{lst} may be modified to form the\n"
+ "return.")
+#define FUNC_NAME s_scm_srfi1_span_x
+{
+ SCM upto, *p;
+ scm_t_trampoline_1 pred_tramp;
+
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ p = &lst;
+ for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
+ {
+ if (scm_is_false (pred_tramp (pred, SCM_CAR (upto))))
+ goto done;
+
+ /* want this element */
+ p = SCM_CDRLOC (upto);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ done:
+ *p = SCM_EOL;
+ return scm_values (scm_list_2 (lst, upto));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_split_at, "split-at", 2, 0, 0,
+ (SCM lst, SCM n),
+ "Return two values (multiple values), being a list of the\n"
+ "elements before index @var{n} in @var{lst}, and a list of those\n"
+ "after.")
+#define FUNC_NAME s_scm_srfi1_split_at
+{
+ size_t nn;
+ /* pre is a list of elements before the i split point, loc is the CDRLOC
+ of the last cell, ie. where to store to append to it */
+ SCM pre = SCM_EOL;
+ SCM *loc = ⪯
+
+ for (nn = scm_to_size_t (n); nn != 0; nn--)
+ {
+ SCM_VALIDATE_CONS (SCM_ARG1, lst);
+
+ *loc = scm_cons (SCM_CAR (lst), SCM_EOL);
+ loc = SCM_CDRLOC (*loc);
+ lst = SCM_CDR(lst);
+ }
+ return scm_values (scm_list_2 (pre, lst));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_split_at_x, "split-at!", 2, 0, 0,
+ (SCM lst, SCM n),
+ "Return two values (multiple values), being a list of the\n"
+ "elements before index @var{n} in @var{lst}, and a list of those\n"
+ "after. @var{lst} is modified to form those values.")
+#define FUNC_NAME s_scm_srfi1_split_at
+{
+ size_t nn;
+ SCM upto = lst;
+ SCM *loc = &lst;
+
+ for (nn = scm_to_size_t (n); nn != 0; nn--)
+ {
+ SCM_VALIDATE_CONS (SCM_ARG1, upto);
+
+ loc = SCM_CDRLOC (upto);
+ upto = SCM_CDR (upto);
+ }
+
+ *loc = SCM_EOL;
+ return scm_values (scm_list_2 (lst, upto));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_take_x, "take!", 2, 0, 0,
+ (SCM lst, SCM n),
+ "Return a list containing the first @var{n} elements of\n"
+ "@var{lst}.")
+#define FUNC_NAME s_scm_srfi1_take_x
+{
+ long nn;
+ SCM pos;
+
+ nn = scm_to_signed_integer (n, 0, LONG_MAX);
+ if (nn == 0)
+ return SCM_EOL;
+
+ pos = scm_list_tail (lst, scm_from_long (nn - 1));
+
+ /* Must have at least one cell left, mustn't have reached the end of an
+ n-1 element list. SCM_VALIDATE_CONS here gives the same error as
+ scm_list_tail does on say an n-2 element list, though perhaps a range
+ error would make more sense (for both). */
+ SCM_VALIDATE_CONS (SCM_ARG1, pos);
+
+ SCM_SETCDR (pos, SCM_EOL);
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0,
+ (SCM lst, SCM n),
+ "Return the a list containing the @var{n} last elements of\n"
+ "@var{lst}.")
+#define FUNC_NAME s_scm_srfi1_take_right
+{
+ SCM tail = scm_list_tail (lst, n);
+ while (scm_is_pair (tail))
+ {
+ lst = SCM_CDR (lst);
+ tail = SCM_CDR (tail);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_take_while, "take-while", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return a new list which is the longest initial prefix of\n"
+ "@var{lst} whose elements all satisfy the predicate @var{pred}.")
+#define FUNC_NAME s_scm_srfi1_take_while
+{
+ scm_t_trampoline_1 pred_tramp;
+ SCM ret, *p;
+
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ ret = SCM_EOL;
+ p = &ret;
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ SCM elem = SCM_CAR (lst);
+ if (scm_is_false (pred_tramp (pred, elem)))
+ goto done;
+
+ /* want this elem, tack it onto the end of ret */
+ *p = scm_cons (elem, SCM_EOL);
+ p = SCM_CDRLOC (*p);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ done:
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_take_while_x, "take-while!", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return the longest initial prefix of @var{lst} whose elements\n"
+ "all satisfy the predicate @var{pred}. @var{lst} may be\n"
+ "modified to form the return.")
+#define FUNC_NAME s_scm_srfi1_take_while_x
+{
+ SCM upto, *p;
+ scm_t_trampoline_1 pred_tramp;
+
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ p = &lst;
+ for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
+ {
+ if (scm_is_false (pred_tramp (pred, SCM_CAR (upto))))
+ goto done;
+
+ /* want this element */
+ p = SCM_CDRLOC (upto);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ done:
+ *p = SCM_EOL;
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_tenth, "tenth", 1, 0, 0,
+ (SCM lst),
+ "Return the tenth element of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_tenth
+{
+ return scm_list_ref (lst, scm_from_int (9));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_xcons, "xcons", 2, 0, 0,
+ (SCM d, SCM a),
+ "Like @code{cons}, but with interchanged arguments. Useful\n"
+ "mostly when passed to higher-order procedures.")
+#define FUNC_NAME s_scm_srfi1_xcons
+{
+ return scm_cons (a, d);
+}
+#undef FUNC_NAME
+
+
void
scm_init_srfi_1 (void)
{