summaryrefslogtreecommitdiff
path: root/libguile/srfi-1.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/srfi-1.c')
-rw-r--r--libguile/srfi-1.c957
1 files changed, 957 insertions, 0 deletions
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
new file mode 100644
index 000000000..ca812935a
--- /dev/null
+++ b/libguile/srfi-1.c
@@ -0,0 +1,957 @@
+/* srfi-1.c --- SRFI-1 procedures for Guile
+
+ Copyright 1995-1997,2000-2003,2005-2006,2008-2011,2013-2014,2018
+ Free Software Foundation, Inc.
+
+ This file is part of Guile.
+
+ Guile 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 version 3 of the License, or
+ (at your option) any later version.
+
+ Guile is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
+ License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with Guile. If not, see
+ <https://www.gnu.org/licenses/>. */
+
+
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdarg.h>
+
+#include "boolean.h"
+#include "eq.h"
+#include "eval.h"
+#include "extensions.h"
+#include "gsubr.h"
+#include "list.h"
+#include "pairs.h"
+#include "procs.h"
+#include "values.h"
+#include "vectors.h"
+#include "version.h"
+
+#include "srfi-1.h"
+
+
+/* The intent of this file was to gradually replace those Scheme
+ * procedures in srfi-1.scm that extend core primitive procedures,
+ * so that using srfi-1 wouldn't have performance penalties.
+ *
+ * However, we now prefer to write these procedures in Scheme, let the compiler
+ * optimize them, and have the VM execute them efficiently.
+ */
+
+
+static SCM
+equal_trampoline (SCM proc, SCM arg1, SCM arg2)
+{
+ 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_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_mutable_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_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_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_x
+{
+ SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
+ return scm_append_x (lstlst);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1,
+ (SCM pred, SCM list1, SCM rest),
+ "Return a count of the number of times @var{pred} returns true\n"
+ "when called on elements from the given lists.\n"
+ "\n"
+ "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
+ "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
+ "corresponding @var{list1} @dots{} @var{lstN}. The first call is\n"
+ "with the first element of each list, the second with the second\n"
+ "element from each, and so on.\n"
+ "\n"
+ "Counting stops when the end of the shortest list is reached.\n"
+ "At least one list must be non-circular.")
+#define FUNC_NAME s_scm_srfi1_count
+{
+ long count;
+ SCM lst;
+ int argnum;
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ count = 0;
+
+ if (scm_is_null (rest))
+ {
+ /* one list */
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
+ count += scm_is_true (scm_call_1 (pred, SCM_CAR (list1)));
+
+ /* check below that list1 is a proper list, and done */
+ end_list1:
+ lst = list1;
+ argnum = 2;
+ }
+ else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
+ {
+ /* two lists */
+ SCM list2;
+
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
+
+ list2 = SCM_CAR (rest);
+ for (;;)
+ {
+ if (! scm_is_pair (list1))
+ goto end_list1;
+ if (! scm_is_pair (list2))
+ {
+ lst = list2;
+ argnum = 3;
+ break;
+ }
+ count += scm_is_true (scm_call_2
+ (pred, SCM_CAR (list1), SCM_CAR (list2)));
+ 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 (;;)
+ {
+ /* 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 pred */
+ SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
+ }
+
+ count += scm_is_true (scm_apply_0 (pred, args));
+ }
+ }
+
+ 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_DEFINE (scm_srfi1_delete, "delete", 2, 1, 0,
+ (SCM x, SCM lst, SCM pred),
+ "Return a list containing the elements of @var{lst} but with\n"
+ "those equal to @var{x} deleted. The returned elements will be\n"
+ "in the same order as they were in @var{lst}.\n"
+ "\n"
+ "Equality is determined by @var{pred}, or @code{equal?} if not\n"
+ "given. An equality call is made just once for each element,\n"
+ "but the order in which the calls are made on the elements is\n"
+ "unspecified.\n"
+ "\n"
+ "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
+ "given @var{x} is first. This means for instance elements\n"
+ "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
+ "\n"
+ "@var{lst} is not modified, but the returned list might share a\n"
+ "common tail with @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_delete
+{
+ SCM ret, *p, keeplst;
+ int count;
+
+ if (SCM_UNBNDP (pred))
+ return scm_delete (x, lst);
+
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG3, FUNC_NAME);
+
+ /* ret is the return list being constructed. p is where to append to it,
+ initially &ret then SCM_CDRLOC of the last pair. lst progresses as
+ 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, 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;
+ count = 0;
+ p = &ret;
+
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ if (scm_is_true (scm_call_2 (pred, x, SCM_CAR (lst))))
+ {
+ /* 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++;
+ }
+ }
+
+ /* final retained elements */
+ *p = keeplst;
+
+ /* demand that lst was a proper list */
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_delete_x, "delete!", 2, 1, 0,
+ (SCM x, SCM lst, SCM pred),
+ "Return a list containing the elements of @var{lst} but with\n"
+ "those equal to @var{x} deleted. The returned elements will be\n"
+ "in the same order as they were in @var{lst}.\n"
+ "\n"
+ "Equality is determined by @var{pred}, or @code{equal?} if not\n"
+ "given. An equality call is made just once for each element,\n"
+ "but the order in which the calls are made on the elements is\n"
+ "unspecified.\n"
+ "\n"
+ "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
+ "given @var{x} is first. This means for instance elements\n"
+ "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
+ "\n"
+ "@var{lst} may be modified to construct the returned list.")
+#define FUNC_NAME s_scm_srfi1_delete_x
+{
+ SCM walk;
+ SCM *prev;
+
+ if (SCM_UNBNDP (pred))
+ return scm_delete_x (x, lst);
+
+ SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG3, FUNC_NAME);
+
+ for (prev = &lst, walk = lst;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_true (scm_call_2 (pred, x, SCM_CAR (walk))))
+ *prev = SCM_CDR (walk);
+ else
+ prev = SCM_CDRLOC (walk);
+ }
+
+ /* demand the input was a proper list */
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk), walk, SCM_ARG2, FUNC_NAME,"list");
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_delete_duplicates, "delete-duplicates", 1, 1, 0,
+ (SCM lst, SCM pred),
+ "Return a list containing the elements of @var{lst} but without\n"
+ "duplicates.\n"
+ "\n"
+ "When elements are equal, only the first in @var{lst} is\n"
+ "retained. Equal elements can be anywhere in @var{lst}, they\n"
+ "don't have to be adjacent. The returned list will have the\n"
+ "retained elements in the same order as they were in @var{lst}.\n"
+ "\n"
+ "Equality is determined by @var{pred}, or @code{equal?} if not\n"
+ "given. Calls @code{(pred x y)} are made with element @var{x}\n"
+ "being before @var{y} in @var{lst}. A call is made at most once\n"
+ "for each combination, but the sequence of the calls across the\n"
+ "elements is unspecified.\n"
+ "\n"
+ "@var{lst} is not modified, but the return might share a common\n"
+ "tail with @var{lst}.\n"
+ "\n"
+ "In the worst case, this is an @math{O(N^2)} algorithm because\n"
+ "it must check each element against all those preceding it. For\n"
+ "long lists it is more efficient to sort and then compare only\n"
+ "adjacent elements.")
+#define FUNC_NAME s_scm_srfi1_delete_duplicates
+{
+ 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
+ considered.
+
+ Elements retained are not immediately appended to ret, instead keeplst
+ is the last pair in lst which is to be kept but is not yet copied.
+ Initially this is the first pair of lst, since the first element is
+ always retained.
+
+ *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
+ the elements retained, making the equality search loop easy.
+
+ If an item must be deleted, elements from keeplst (inclusive) to lst
+ (exclusive) must be copied and appended to ret. When there's no more
+ deletions, *p is left set to keeplst, so ret shares structure with the
+ original lst. (ret will be the entire original lst if there are no
+ deletions.) */
+
+ /* skip to end if an empty list (or something invalid) */
+ ret = SCM_EOL;
+
+ if (SCM_UNBNDP (pred))
+ equal_p = equal_trampoline;
+ else
+ {
+ SCM_VALIDATE_PROC (SCM_ARG2, pred);
+ equal_p = scm_call_2;
+ }
+
+ keeplst = lst;
+ count = 0;
+ p = &ret;
+
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ item = SCM_CAR (lst);
+
+ /* 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)))
+ {
+ /* "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;
+ }
+ }
+
+ /* 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
+
+
+SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0,
+ (SCM lst, SCM pred),
+ "Return a list containing the elements of @var{lst} but without\n"
+ "duplicates.\n"
+ "\n"
+ "When elements are equal, only the first in @var{lst} is\n"
+ "retained. Equal elements can be anywhere in @var{lst}, they\n"
+ "don't have to be adjacent. The returned list will have the\n"
+ "retained elements in the same order as they were in @var{lst}.\n"
+ "\n"
+ "Equality is determined by @var{pred}, or @code{equal?} if not\n"
+ "given. Calls @code{(pred x y)} are made with element @var{x}\n"
+ "being before @var{y} in @var{lst}. A call is made at most once\n"
+ "for each combination, but the sequence of the calls across the\n"
+ "elements is unspecified.\n"
+ "\n"
+ "@var{lst} may be modified to construct the returned list.\n"
+ "\n"
+ "In the worst case, this is an @math{O(N^2)} algorithm because\n"
+ "it must check each element against all those preceding it. For\n"
+ "long lists it is more efficient to sort and then compare only\n"
+ "adjacent elements.")
+#define FUNC_NAME s_scm_srfi1_delete_duplicates_x
+{
+ scm_t_trampoline_2 equal_p;
+ SCM ret, endret, item, l;
+
+ /* ret is the return list, constructed from the pairs in lst. endret is
+ the last pair of ret, initially the first pair. lst is advanced as
+ elements are considered. */
+
+ /* skip to end if an empty list (or something invalid) */
+ ret = lst;
+ if (scm_is_pair (lst))
+ {
+ if (SCM_UNBNDP (pred))
+ equal_p = equal_trampoline;
+ else
+ {
+ SCM_VALIDATE_PROC (SCM_ARG2, pred);
+ equal_p = scm_call_2;
+ }
+
+ endret = ret;
+
+ /* loop over lst elements starting from second */
+ for (;;)
+ {
+ lst = SCM_CDR (lst);
+ if (! scm_is_pair (lst))
+ break;
+ item = SCM_CAR (lst);
+
+ /* is item equal to any element from ret to endret (inclusive)? */
+ l = ret;
+ for (;;)
+ {
+ if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
+ break; /* equal, forget this element */
+
+ if (scm_is_eq (l, endret))
+ {
+ /* not equal to any, so append this pair */
+ scm_set_cdr_x (endret, lst);
+ endret = lst;
+ break;
+ }
+ l = SCM_CDR (l);
+ }
+ }
+
+ /* terminate, in case last element was deleted */
+ scm_set_cdr_x (endret, SCM_EOL);
+ }
+
+ /* demand that lst was a proper list */
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, 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_VALIDATE_PROC (SCM_ARG1, pred);
+
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ SCM elem = SCM_CAR (lst);
+ if (scm_is_true (scm_call_1 (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_VALIDATE_PROC (SCM_ARG1, pred);
+
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ if (scm_is_true (scm_call_1 (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_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
+{
+ size_t i = 0;
+ SCM tortoise = lst;
+ SCM hare = lst;
+
+ do
+ {
+ if (!scm_is_pair (hare))
+ {
+ if (SCM_NULL_OR_NIL_P (hare))
+ return scm_from_size_t (i);
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, lst,
+ "proper or circular list");
+ }
+ hare = SCM_CDR (hare);
+ i++;
+ if (!scm_is_pair (hare))
+ {
+ if (SCM_NULL_OR_NIL_P (hare))
+ return scm_from_size_t (i);
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, lst,
+ "proper or circular list");
+ }
+ hare = SCM_CDR (hare);
+ i++;
+ /* For every two steps the hare takes, the tortoise takes one. */
+ tortoise = SCM_CDR (tortoise);
+ }
+ while (!scm_is_eq (hare, tortoise));
+
+ /* If the tortoise ever catches the hare, then the list must contain
+ a cycle. */
+ 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_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 ret, *pos, elem, r, b;
+ int argnum;
+
+ SCM_VALIDATE_PROC (SCM_ARG1, equal);
+ 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 (scm_call_2 (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
+
+
+SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
+ (SCM key, SCM alist, SCM pred),
+ "Behaves like @code{assq} but uses third argument @var{pred}\n"
+ "for key comparison. If @var{pred} is not supplied,\n"
+ "@code{equal?} is used. (Extended from R5RS.)\n")
+#define FUNC_NAME s_scm_srfi1_assoc
+{
+ SCM ls = alist;
+ scm_t_trampoline_2 equal_p;
+ if (SCM_UNBNDP (pred))
+ equal_p = equal_trampoline;
+ else
+ {
+ SCM_VALIDATE_PROC (SCM_ARG3, pred);
+ equal_p = scm_call_2;
+ }
+ for(; scm_is_pair (ls); ls = SCM_CDR (ls))
+ {
+ SCM tmp = SCM_CAR (ls);
+ SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
+ "association list");
+ 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,
+ "association list");
+ return SCM_BOOL_F;
+}
+#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"
+ "Return two values: the list of elements satisfying @var{pred} and\n"
+ "the list of elements @emph{not} satisfying @var{pred}. The order\n"
+ "of the output lists follows the order of @var{list}. @var{list}\n"
+ "is not mutated. One of the output lists may share memory with @var{list}.\n")
+#define FUNC_NAME s_scm_srfi1_partition
+{
+ /* In this implementation, the output lists don't share memory with
+ list, because it's probably not worth the effort. */
+ 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 dropped_tail = dropped;
+
+ SCM_VALIDATE_PROC (SCM_ARG1, pred);
+
+ for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) {
+ 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 (scm_call_1 (pred, elt))) {
+ SCM_SETCDR(kept_tail, new_tail);
+ kept_tail = new_tail;
+ }
+ else {
+ SCM_SETCDR(dropped_tail, new_tail);
+ dropped_tail = new_tail;
+ }
+ }
+ return scm_values_2 (SCM_CDR (kept), SCM_CDR (dropped));
+}
+#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_ASSERT (scm_is_true (scm_procedure_p (pred)), 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 (scm_call_1 (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_2 (tlst, flst);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_srfi1_remove, "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.")
+#define FUNC_NAME s_scm_srfi1_remove
+{
+ SCM walk;
+ SCM *prev;
+ SCM res = SCM_EOL;
+ SCM_VALIDATE_PROC (SCM_ARG1, pred);
+ SCM_VALIDATE_LIST (2, list);
+
+ for (prev = &res, walk = list;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_false (scm_call_1 (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 walk;
+ SCM *prev;
+ SCM_VALIDATE_PROC (SCM_ARG1, pred);
+ SCM_VALIDATE_LIST (2, list);
+
+ for (prev = &list, walk = list;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_false (scm_call_1 (pred, SCM_CAR (walk))))
+ prev = SCM_CDRLOC (walk);
+ else
+ *prev = SCM_CDR (walk);
+ }
+
+ return list;
+}
+#undef FUNC_NAME
+
+
+void
+scm_register_srfi_1 (void)
+{
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_srfi_1",
+ (scm_t_extension_init_func)scm_init_srfi_1, NULL);
+}
+
+void
+scm_init_srfi_1 (void)
+{
+#ifndef SCM_MAGIC_SNARFER
+#include "srfi-1.x"
+#endif
+}
+
+/* End of srfi-1.c. */