diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index ce97abad7..0890acc18 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -210,7 +210,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \
smob.c \
sort.c \
srcprop.c \
- srfi-1.c \
srfi-4.c \
srfi-13.c \
srfi-14.c \
@@ -324,7 +323,6 @@ DOT_X_FILES = \
smob.x \
sort.x \
srcprop.x \
- srfi-1.x \
srfi-4.x \
srfi-13.x \
srfi-14.x \
@@ -426,7 +424,6 @@ DOT_DOC_FILES = \
smob.doc \
sort.doc \
srcprop.doc \
- srfi-1.doc \
srfi-4.doc \
srfi-13.doc \
srfi-14.doc \
@@ -691,7 +688,6 @@ modinclude_HEADERS = \
socket.h \
sort.h \
srcprop.h \
- srfi-1.h \
srfi-4.h \
srfi-13.h \
srfi-14.h \
diff --git a/libguile/init.c b/libguile/init.c
index 4022728f9..4a3903a2c 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -128,7 +128,6 @@
#include "socket.h"
#include "sort.h"
#include "srcprop.h"
-#include "srfi-1.h"
#include "srfi-13.h"
#include "srfi-14.h"
#include "srfi-4.h"
@@ -377,7 +376,6 @@ scm_i_init_guile (void *base)
scm_register_fdes_finalizers ();
scm_register_foreign ();
scm_register_foreign_object ();
- scm_register_srfi_1 ();
scm_register_srfi_60 ();
scm_register_poll ();
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
deleted file mode 100644
index b18ba41c7..000000000
--- a/libguile/srfi-1.c
+++ /dev/null
@@ -1,885 +0,0 @@
-/* srfi-1.c --- SRFI-1 procedures for Guile
-
- Copyright 1995-1997,2000-2003,2005-2006,2008-2011,2013-2014,2018,2020
- 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
- . */
-
-
-
-
-#ifdef HAVE_CONFIG_H
-# include
-#endif
-
-#include
-
-#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
-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_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_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. */
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
deleted file mode 100644
index 9dafb9c0d..000000000
--- a/libguile/srfi-1.h
+++ /dev/null
@@ -1,47 +0,0 @@
-/* srfi-1.h --- SRFI-1 procedures for Guile
- Copyright 2002-2003,2005-2006,2010-2011,2018,2020
- 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
- . */
-
-
-#ifndef SCM_SRFI_1_H
-#define SCM_SRFI_1_H
-
-#include "libguile/scm.h"
-
-SCM_INTERNAL SCM scm_srfi1_append_reverse (SCM revhead, SCM tail);
-SCM_INTERNAL SCM scm_srfi1_append_reverse_x (SCM revhead, SCM tail);
-SCM_INTERNAL SCM scm_srfi1_concatenate (SCM lstlst);
-SCM_INTERNAL SCM scm_srfi1_concatenate_x (SCM lstlst);
-SCM_INTERNAL SCM scm_srfi1_count (SCM pred, SCM list1, SCM rest);
-SCM_INTERNAL SCM scm_srfi1_delete (SCM x, SCM lst, SCM pred);
-SCM_INTERNAL SCM scm_srfi1_delete_x (SCM x, SCM lst, SCM pred);
-SCM_INTERNAL SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred);
-SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred);
-SCM_INTERNAL SCM scm_srfi1_length_plus (SCM lst);
-SCM_INTERNAL SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest);
-SCM_INTERNAL SCM scm_srfi1_list_copy (SCM lst);
-SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list);
-SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list);
-SCM_INTERNAL SCM scm_srfi1_remove (SCM pred, SCM list);
-SCM_INTERNAL SCM scm_srfi1_remove_x (SCM pred, SCM list);
-
-SCM_INTERNAL void scm_register_srfi_1 (void);
-SCM_INTERNAL void scm_init_srfi_1 (void);
-
-#endif /* SCM_SRFI_1_H */
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 57f9058b6..b46f7be5f 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -224,11 +224,6 @@
(cond-expand-provide (current-module) '(srfi-1))
-;; Load the compiled primitives from the shared library.
-;;
-(load-extension (string-append "libguile-" (effective-version))
- "scm_init_srfi_1")
-
;;; Constructors
@@ -262,6 +257,24 @@ INIT-PROC is applied to the indices is not specified."
acc
(lp (- n 1) (cons (init-proc (- n 1)) acc)))))
+(define (list-copy lst)
+ "Return a copy of the given list @var{lst}.
+@var{lst} can be a proper or improper list. And if @var{lst} is not a
+pair then it's treated as the final tail of an improper list and simply
+returned."
+ ;; This routine differs from the core list-copy in allowing improper
+ ;; lists. Maybe the core could allow them too.
+ (if (not (pair? lst))
+ lst
+ (let ((result (cons (car lst) (cdr lst))))
+ (let lp ((tail result))
+ (let ((next (cdr tail)))
+ (if (pair? next)
+ (begin
+ (set-cdr! tail (cons (car next) (cdr next)))
+ (lp next))
+ result))))))
+
(define (circular-list elt1 . elts)
(set! elts (cons elt1 elts))
(set-cdr! (last-pair elts) elts)
@@ -427,6 +440,88 @@ a list of those after."
;;; Miscelleneous: length, append, concatenate, reverse, zip & count
+(define (length+ lst)
+ "Return the length of @var{lst}, or @code{#f} if @var{lst} is circular."
+ (let lp ((tortoise lst)
+ (hare lst)
+ (i 0))
+ (if (not-pair? hare)
+ (if (null? hare)
+ i
+ (scm-error 'wrong-type-arg "length+"
+ "Argument not a proper or circular list: ~s"
+ (list lst) (list lst)))
+ (let ((hare (cdr hare)))
+ (if (not-pair? hare)
+ (if (null? hare)
+ (1+ i)
+ (scm-error 'wrong-type-arg "length+"
+ "Argument not a proper or circular list: ~s"
+ (list lst) (list lst)))
+ (let ((tortoise (cdr tortoise))
+ (hare (cdr hare)))
+ (if (eq? hare tortoise)
+ #f
+ (lp tortoise hare (+ i 2)))))))))
+
+(define (concatenate lists)
+ "Construct a list by appending all lists in @var{lists}.
+
+@code{concatenate} is the same as @code{(apply append @var{lists})}.
+It exists because some Scheme implementations have a limit on the number
+of arguments a function takes, which the @code{apply} might exceed. In
+Guile there is no such limit."
+ (apply append lists))
+
+(define (concatenate! lists)
+ "Construct a list by appending all lists in @var{lists}. Those
+lists may be modified to produce the result.
+
+@code{concatenate!} is the same as @code{(apply append! @var{lists})}.
+It exists because some Scheme implementations have a limit on the number
+of arguments a function takes, which the @code{apply} might exceed. In
+Guile there is no such limit."
+ (apply append! lists))
+
+(define (append-reverse rev-head tail)
+ "Reverse @var{rev-head}, append @var{tail} to it, and return the
+result. This is equivalent to @code{(append (reverse @var{rev-head})
+@var{tail})}, but its implementation is more efficient.
+
+@example
+(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)
+@end example"
+ (let lp ((rh rev-head)
+ (result tail))
+ (if (pair? rh)
+ (lp (cdr rh) (cons (car rh) result))
+ (begin
+ (unless (null? rh)
+ (wrong-type-arg 'append-reverse rev-head))
+ result))))
+
+(define (append-reverse! rev-head tail)
+ "Reverse @var{rev-head}, append @var{tail} to it, and return the
+result. This is equivalent to @code{(append! (reverse! @var{rev-head})
+@var{tail})}, but its implementation is more efficient.
+
+@example
+(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)
+@end example
+
+@var{rev-head} may be modified in order to produce the result."
+ (let lp ((rh rev-head)
+ (result tail))
+ (if (pair? rh)
+ (let ((next rh)
+ (rh (cdr rh)))
+ (set-cdr! next result)
+ (lp rh next))
+ (begin
+ (unless (null? rh)
+ (wrong-type-arg 'append-reverse! rev-head))
+ result))))
+
(define (zip clist1 . rest)
(let lp ((l (cons clist1 rest)) (acc '()))
(if (any null? l)
@@ -446,6 +541,27 @@ a list of those after."
(values (map first l) (map second l) (map third l) (map fourth l)
(map fifth l)))
+(define count
+ (case-lambda
+ ((pred lst)
+ (let lp ((lst lst) (c 0))
+ (if (null? lst)
+ c
+ (lp (cdr lst) (if (pred (car lst)) (1+ c) c)))))
+ ((pred l1 l2)
+ (let lp ((l1 l1) (l2 l2) (c 0))
+ (if (or (null? l1) (null? l2))
+ c
+ (lp (cdr l1) (cdr l2)
+ (if (pred (car l1) (car l2)) (1+ c) c)))))
+ ((pred lst . lists)
+ (let lp ((lst lst) (lists lists) (c 0))
+ (if (or (null? lst) (any null? lists))
+ c
+ (lp (cdr lst)
+ (map cdr lists)
+ (if (apply pred (car lst) (map car lists)) (1+ c) c)))))))
+
;;; Fold, unfold & map
(define fold
@@ -717,6 +833,117 @@ the list returned."
(apply f l)
(lp (map cdr l)))))))
+
+;;; Filtering & partitioning
+
+(define (partition pred lst)
+ "Partition the elements of @var{list} with predicate @var{pred}.
+Return two values: the list of elements satisfying @var{pred} and the
+list of elements @emph{not} satisfying @var{pred}. The order of the
+output lists follows the order of @var{list}. @var{list} is not
+mutated. One of the output lists may share memory with @var{list}."
+ (let ((matches (list #f))
+ (mismatches (list #f)))
+ (let lp ((lst lst)
+ (matches-end matches)
+ (mismatches-end mismatches))
+ (if (null? lst)
+ (values (cdr matches) (cdr mismatches))
+ (let ((x (car lst)))
+ (if (pred x)
+ (begin
+ (set-cdr! matches-end (list x))
+ (lp (cdr lst) (cdr matches-end) mismatches-end))
+ (begin
+ (set-cdr! mismatches-end (list x))
+ (lp (cdr lst) matches-end (cdr mismatches-end)))))))))
+
+(define (list-prefix-and-tail lst stop)
+ (when (eq? lst stop)
+ (error "Prefix cannot be empty"))
+ (let ((rl (list (car lst))))
+ (let lp ((lst (cdr lst)) (tail rl))
+ (if (eq? lst stop)
+ (values rl tail)
+ (let ((new-tail (list (car lst))))
+ (set-cdr! tail new-tail)
+ (lp (cdr lst) new-tail))))))
+
+(define (remove pred lst)
+ "Return a list containing all elements from @var{list} which do not
+satisfy the predicate @var{pred}. The elements in the result list have
+the same order as in @var{list}. The order in which @var{pred} is
+applied to the list elements is not specified, and the result may share
+a common tail with @{list}."
+ ;; Traverse the lst, keeping the tail of it, in which we have yet to
+ ;; find a duplicate, in last-kept. Share that tail with the result
+ ;; (possibly the entire original lst). Build the result by
+ ;; destructively appending unique values to its tail, and henever we
+ ;; find a duplicate, copy the pending last-kept prefix into the result
+ ;; and move last-kept forward to the current position in lst.
+ (if (null? lst)
+ lst
+ (let ((result (list #f)))
+ (let lp ((lst lst)
+ (last-kept lst)
+ (tail result))
+ (if (null? lst)
+ (begin
+ (set-cdr! tail last-kept)
+ (cdr result))
+ (let ((item (car lst)))
+ (if (pred item)
+ (if (eq? last-kept lst)
+ (lp (cdr lst) (cdr lst) tail)
+ (call-with-values
+ (lambda () (list-prefix-and-tail last-kept lst))
+ (lambda (prefix new-tail)
+ (set-cdr! tail prefix)
+ (lp (cdr lst) (cdr lst) new-tail))))
+ (lp (cdr lst) last-kept tail))))))))
+
+(define (partition! pred lst)
+ "Partition the elements of @var{list} with predicate @var{pred}.
+Return two values: the list of elements satisfying @var{pred} and the
+list of elements @emph{not} satisfying @var{pred}. The order of the
+output lists follows the order of @var{list}. @var{list} is not
+mutated. @var{lst} may be modified to construct the return lists."
+ (let ((matches (cons #f lst))
+ (mismatches (list #f)))
+ (let lp ((matches-next matches)
+ (mismatches-end mismatches))
+ (let ((next (cdr matches-next)))
+ (if (null? next)
+ (values (cdr matches) (cdr mismatches))
+ (let ((x (car next)))
+ (if (pred x)
+ (lp (cdr matches-next) mismatches-end)
+ (begin
+ (set-cdr! matches-next (cdr next))
+ (set-cdr! mismatches-end (list x))
+ (lp matches-next (cdr mismatches-end))))))))))
+
+(define (remove! pred lst)
+ "Return a list containing all elements from @var{list} which do not
+satisfy the predicate @var{pred}. The elements in the result list have
+the same order as in @var{list}. The order in which @var{pred} is
+applied to the list elements is not specified. @var{list} may be
+modified to build the return list."
+ (cond
+ ((null? lst) lst)
+ ((pred (car lst)) (remove! pred (cdr lst)))
+ (else
+ (let lp ((prev lst))
+ (let ((next (cdr prev)))
+ (if (null? next)
+ lst
+ (let ((x (car next)))
+ (if (pred x)
+ (begin
+ (set-cdr! prev (cdr next))
+ (lp prev))
+ (lp next)))))))))
+
;;; Searching
@@ -896,6 +1123,126 @@ CLIST1 ... CLISTN, that satisfies PRED."
(else
(lp (map cdr lists) (+ i 1)))))))
+;;; Deletion
+
+(define* (delete x lst #:optional (pred equal?))
+ "Return a list containing the elements of @var{lst} but with
+those equal to @var{x} deleted. The returned elements will be in the
+same order as they were in @var{lst}.
+
+Equality is determined by @var{pred}, or @code{equal?} if not given. An
+equality call is made just once for each element, but the order in which
+the calls are made on the elements is unspecified.
+
+The equality calls are always @code{(pred x elem)}, ie.@: the given
+@var{x} is first. This means for instance elements greater than 5 can
+be deleted with @code{(delete 5 lst <)}.
+
+@var{lst} is not modified, but the returned list might share a common
+tail with @var{lst}."
+ (remove (lambda (elem) (pred x elem)) lst))
+
+(define (member-before x lst stop =)
+ (cond
+ ((null? lst) #f)
+ ((eq? lst stop) #f)
+ ((= (car lst) x) #t)
+ (else (member-before x (cdr lst) stop =))))
+
+(define* (delete! x lst #:optional (pred equal?))
+ "Return a list containing the elements of @var{lst} but with
+those equal to @var{x} deleted. The returned elements will be in the
+same order as they were in @var{lst}.
+
+Equality is determined by @var{pred}, or @code{equal?} if not given. An
+equality call is made just once for each element, but the order in which
+the calls are made on the elements is unspecified.
+
+The equality calls are always @code{(pred x elem)}, ie.@: the given
+@var{x} is first. This means for instance elements greater than 5 can
+be deleted with @code{(delete 5 lst <)}.
+
+@var{lst} may be modified to construct the returned list."
+ (remove! (lambda (elem) (pred x elem)) lst))
+
+(define* (delete-duplicates lst #:optional (= equal?))
+ "Return a list containing the elements of @var{lst} but without
+duplicates.
+
+When elements are equal, only the first in @var{lst} is retained. Equal
+elements can be anywhere in @var{lst}, they don't have to be adjacent.
+The returned list will have the retained elements in the same order as
+they were in @var{lst}.
+
+Equality is determined by @var{pred}, or @code{equal?} if not given.
+Calls @code{(pred x y)} are made with element @var{x} being before
+@var{y} in @var{lst}. A call is made at most once for each combination,
+but the sequence of the calls across the elements is unspecified.
+
+@var{lst} is not modified, but the return might share a common tail with
+@var{lst}.
+
+In the worst case, this is an @math{O(N^2)} algorithm because it must
+check each element against all those preceding it. For long lists it is
+more efficient to sort and then compare only adjacent elements."
+ ;; Same implementation as remove (see comments there), except that the
+ ;; predicate checks for duplicates in both last-seen and the pending
+ ;; result.
+ (if (null? lst)
+ lst
+ (let ((result (list #f)))
+ (let lp ((lst lst)
+ (last-kept lst)
+ (tail result))
+ (if (null? lst)
+ (begin
+ (set-cdr! tail last-kept)
+ (cdr result))
+ (let ((item (car lst)))
+ (if (or (member item (cdr result) (lambda (x y) (= y x)))
+ (member-before item last-kept lst =))
+ (if (eq? last-kept lst)
+ (lp (cdr lst) (cdr lst) tail)
+ (call-with-values
+ (lambda () (list-prefix-and-tail last-kept lst))
+ (lambda (prefix new-tail)
+ (set-cdr! tail prefix)
+ (lp (cdr lst) (cdr lst) new-tail))))
+ ;; unique, keep
+ (lp (cdr lst) last-kept tail))))))))
+
+(define* (delete-duplicates! lst #:optional (= equal?))
+ "Return a list containing the elements of @var{lst} but without
+duplicates.
+
+When elements are equal, only the first in @var{lst} is retained. Equal
+elements can be anywhere in @var{lst}, they don't have to be adjacent.
+The returned list will have the retained elements in the same order as
+they were in @var{lst}.
+
+Equality is determined by @var{=}, or @code{equal?} if not given.
+Calls @code{(= x y)} are made with element @var{x} being before
+@var{y} in @var{lst}. A call is made at most once for each combination,
+but the sequence of the calls across the elements is unspecified.
+
+@var{lst} is not modified, but the return might share a common tail with
+@var{lst}.
+
+In the worst case, this is an @math{O(N^2)} algorithm because it must
+check each element against all those preceding it. For long lists it is
+more efficient to sort and then compare only adjacent elements."
+ (if (null? lst)
+ lst
+ (let lp ((tail lst))
+ (let ((next (cdr tail)))
+ (if (null? next)
+ lst
+ (if (member-before (car next) lst next =)
+ (begin
+ (set-cdr! tail (cdr next))
+ (lp tail))
+ (lp next)))))))
+
;;; Association lists
(define alist-cons acons)
@@ -1034,18 +1381,32 @@ given REST parameters."
(lp (cdr l) (cons (car l) acc))
(lp (cdr l) acc)))))
-(define (lset-difference = list1 . rest)
- (check-arg procedure? = lset-difference)
- (if (null? rest)
- list1
- (let lp ((l list1) (acc '()))
- (if (null? l)
- (reverse! acc)
- (if (any (lambda (ll) (member (car l) ll =)) rest)
- (lp (cdr l) acc)
- (lp (cdr l) (cons (car l) acc)))))))
+(define (lset-difference = lset . removals)
+ "Return @var{lst} with any elements in the lists in @var{removals}
+removed (ie.@: subtracted). For only one @var{lst} argument, just that
+list is returned.
-;(define (fold kons knil list1 . rest)
+The given @var{equal} procedure is used for comparing elements, called
+as @code{(@var{equal} elem1 elemN)}. The first argument is from
+@var{lst} and the second from one of the subsequent lists. But exactly
+which calls are made and in what order is unspecified.
+
+@example
+(lset-difference eqv? (list 'x 'y)) @result{} (x y)
+(lset-difference eqv? (list 1 2 3) '(3 1)) @result{} (2)
+(lset-difference eqv? (list 1 2 3) '(3) '(2)) @result{} (1)
+@end example
+
+The result may share a common tail with @var{lset}."
+ ;; REVIEW: if we think they're actually going to be sets, i.e. no
+ ;; duplicates, then might it be better to just reduce via per-set
+ ;; delete -- more transient allocation but maybe a lot less work?
+ (check-arg procedure? = lset-difference)
+ (cond
+ ((null? lset) lset)
+ ((null? removals) lset)
+ (else (remove (lambda (x) (any (lambda (s) (member x s =)) removals))
+ lset))))
(define (lset-xor = . rest)
(check-arg procedure? = lset-xor)
@@ -1083,6 +1444,30 @@ given REST parameters."
(check-arg procedure? = lset-intersection!)
(apply lset-intersection = list1 rest)) ; XXX:optimize
+(define (lset-difference! = lset . removals)
+ "Return @var{lst} with any elements in the lists in @var{removals}
+removed (ie.@: subtracted). For only one @var{lst} argument, just that
+list is returned.
+
+The given @var{equal} procedure is used for comparing elements, called
+as @code{(@var{equal} elem1 elemN)}. The first argument is from
+@var{lst} and the second from one of the subsequent lists. But exactly
+which calls are made and in what order is unspecified.
+
+@example
+(lset-difference! eqv? (list 'x 'y)) @result{} (x y)
+(lset-difference! eqv? (list 1 2 3) '(3 1)) @result{} (2)
+(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)
+@end example
+
+@code{lset-difference!} may modify @var{lst} to form its result."
+ (check-arg procedure? = lset-intersection!)
+ (cond
+ ((null? lset) lset)
+ ((null? removals) lset)
+ (else (remove! (lambda (x) (any (lambda (s) (member x s =)) removals))
+ lset))))
+
(define (lset-xor! = . rest)
(check-arg procedure? = lset-xor!)
(apply lset-xor = rest)) ; XXX:optimize
diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index dc3e47f50..558934df4 100644
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -21,6 +21,8 @@
#:use-module (ice-9 copy-tree)
#:use-module (srfi srfi-1))
+(define list+-bad-arg-exception
+ '(wrong-type-arg . "^Argument not a proper or circular list"))
(define (ref-delete x lst . proc)
"Reference implemenation of srfi-1 `delete'."
@@ -463,10 +465,10 @@
(pass-if-exception "too many args" exception:wrong-num-args
(concatenate-proc '() '()))
- (pass-if-exception "number" exception:wrong-type-arg
+ (pass-if-exception "number" '(wrong-type-arg . "Apply to non-list")
(concatenate-proc 123))
- (pass-if-exception "vector" exception:wrong-type-arg
+ (pass-if-exception "vector" '(wrong-type-arg . "Apply to non-list")
(concatenate-proc #(1 2 3)))
(pass-if "no lists"
@@ -1188,18 +1190,18 @@
(pass-if-exception "proc arg count 4" exception:wrong-num-args
(fold (lambda (x y z prev) x) 1 '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper first 1" exception:wrong-type-arg
+ (pass-if-exception "improper first 1" list+-bad-arg-exception
(fold + 1 1 '(1 2 3)))
- (pass-if-exception "improper first 2" exception:wrong-type-arg
+ (pass-if-exception "improper first 2" list+-bad-arg-exception
(fold + 1 '(1 . 2) '(1 2 3)))
- (pass-if-exception "improper first 3" exception:wrong-type-arg
+ (pass-if-exception "improper first 3" list+-bad-arg-exception
(fold + 1 '(1 2 . 3) '(1 2 3)))
- (pass-if-exception "improper second 1" exception:wrong-type-arg
+ (pass-if-exception "improper second 1" list+-bad-arg-exception
(fold + 1 '(1 2 3) 1))
- (pass-if-exception "improper second 2" exception:wrong-type-arg
+ (pass-if-exception "improper second 2" list+-bad-arg-exception
(fold + 1 '(1 2 3) '(1 . 2)))
- (pass-if-exception "improper second 3" exception:wrong-type-arg
+ (pass-if-exception "improper second 3" list+-bad-arg-exception
(fold + 1 '(1 2 3) '(1 2 . 3)))
(pass-if (= 6 (fold + 1 '(2) '(3))))
@@ -1330,9 +1332,9 @@
(length+))
(pass-if-exception "too many args" exception:wrong-num-args
(length+ 123 456))
- (pass-if-exception "not a pair" exception:wrong-type-arg
+ (pass-if-exception "not a pair" list+-bad-arg-exception
(length+ 'x))
- (pass-if-exception "improper list" exception:wrong-type-arg
+ (pass-if-exception "improper list" list+-bad-arg-exception
(length+ '(x y . z)))
(pass-if (= 0 (length+ '())))
(pass-if (= 1 (length+ '(x))))
@@ -1449,7 +1451,14 @@
(pass-if (equal? '(1 . 2) (list-copy '(1 . 2))))
(pass-if (equal? '(1 2 . 3) (list-copy '(1 2 . 3))))
(pass-if (equal? '(1 2 3 . 4) (list-copy '(1 2 3 . 4))))
- (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5)))))
+ (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5))))
+
+ (let ((src (list 1 2 3 4 5)))
+ (define (find-pair? p lst)
+ (let lp ((lst lst))
+ (and (pair? lst) (or (eq? p lst) (lp (cdr lst))))))
+ (pair-for-each (lambda (p) (pass-if (not (find-pair? p src))))
+ (list-copy src))))
;;
;; list-index
@@ -1760,72 +1769,64 @@
(equal? '(1 2) (lset-adjoin = '(2) 1 1))))
;;
-;; lset-difference
+;; lset-difference and lset-difference!
;;
-(with-test-prefix "lset-difference"
+(begin
+ (define (test-shared-behavior diff)
+ (pass-if-exception "proc - num" exception:wrong-type-arg
+ (diff 123 '(4)))
+ (pass-if-exception "proc - list" exception:wrong-type-arg
+ (diff (list 1 2 3) '(4)))
- (pass-if "called arg order"
- (let ((good #f))
- (lset-difference (lambda (x y)
- (set! good (and (= x 1) (= y 2)))
- (= x y))
- '(1) '(2))
- good)))
+ (pass-if "called arg order"
+ (let ((good #f))
+ (diff (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ (list 1) (list 2))
+ good))
-;;
-;; lset-difference!
-;;
+ (pass-if (equal? '() (diff = '())))
+ (pass-if (equal? '(1) (diff = (list 1))))
+ (pass-if (equal? '(1 2) (diff = (list 1 2))))
-(with-test-prefix "lset-difference!"
+ (pass-if (equal? '() (diff = (list ) '(3))))
+ (pass-if (equal? '() (diff = (list 3) '(3))))
+ (pass-if (equal? '(1) (diff = (list 1 3) '(3))))
+ (pass-if (equal? '(1) (diff = (list 3 1) '(3))))
+ (pass-if (equal? '(1) (diff = (list 1 3 3) '(3))))
+ (pass-if (equal? '(1) (diff = (list 3 1 3) '(3))))
+ (pass-if (equal? '(1) (diff = (list 3 3 1) '(3))))
- (pass-if-exception "proc - num" exception:wrong-type-arg
- (lset-difference! 123 '(4)))
- (pass-if-exception "proc - list" exception:wrong-type-arg
- (lset-difference! (list 1 2 3) '(4)))
+ (pass-if (equal? '(1) (diff = (list 1 2 3) '(2 3))))
+ (pass-if (equal? '(1) (diff = (list 1 2 3) '(3 2))))
+ (pass-if (equal? '(1) (diff = (list 1 2 3) '(3) '(2))))
+ (pass-if (equal? '(1) (diff = (list 1 2 3) '(2) '(3))))
+ (pass-if (equal? '(1) (diff = (list 1 2 3) '(2) '(2 3))))
+ (pass-if (equal? '(1) (diff = (list 1 2 3) '(2) '(3 2))))
- (pass-if "called arg order"
- (let ((good #f))
- (lset-difference! (lambda (x y)
- (set! good (and (= x 1) (= y 2)))
- (= x y))
- (list 1) (list 2))
- good))
+ (pass-if (equal? '(1 2) (diff = (list 1 2 3) '(3) '(3))))
+ (pass-if (equal? '(1 2) (diff = (list 1 3 2) '(3) '(3))))
+ (pass-if (equal? '(1 2) (diff = (list 3 1 2) '(3) '(3))))
- (pass-if (equal? '() (lset-difference! = '())))
- (pass-if (equal? '(1) (lset-difference! = (list 1))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 1 2))))
+ (pass-if (equal? '(1 2 3) (diff = (list 1 2 3 4) '(4))))
+ (pass-if (equal? '(1 2 3) (diff = (list 1 2 4 3) '(4))))
+ (pass-if (equal? '(1 2 3) (diff = (list 1 4 2 3) '(4))))
+ (pass-if (equal? '(1 2 3) (diff = (list 4 1 2 3) '(4))))
- (pass-if (equal? '() (lset-difference! = (list ) '(3))))
- (pass-if (equal? '() (lset-difference! = (list 3) '(3))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 3) '(3))))
- (pass-if (equal? '(1) (lset-difference! = (list 3 1) '(3))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 3 3) '(3))))
- (pass-if (equal? '(1) (lset-difference! = (list 3 1 3) '(3))))
- (pass-if (equal? '(1) (lset-difference! = (list 3 3 1) '(3))))
+ (pass-if (equal? '(1 2) (diff = (list 1 2 3 4) '(4) '(3))))
+ (pass-if (equal? '(1 2) (diff = (list 1 3 2 4) '(4) '(3))))
+ (pass-if (equal? '(1 2) (diff = (list 3 1 2 4) '(4) '(3))))
+ (pass-if (equal? '(1 2) (diff = (list 1 3 4 2) '(4) '(3))))
+ (pass-if (equal? '(1 2) (diff = (list 3 1 4 2) '(4) '(3))))
+ (pass-if (equal? '(1 2) (diff = (list 3 4 1 2) '(4) '(3)))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2 3))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3 2))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3) '(2))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(2 3))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3 2))))
+ (with-test-prefix "lset-difference"
+ (test-shared-behavior lset-difference))
- (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3) '(3) '(3))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2) '(3) '(3))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2) '(3) '(3))))
-
- (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 3 4) '(4))))
- (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 4 3) '(4))))
- (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 4 2 3) '(4))))
- (pass-if (equal? '(1 2 3) (lset-difference! = (list 4 1 2 3) '(4))))
-
- (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3 4) '(4) '(3))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2 4) '(4) '(3))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2 4) '(4) '(3))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 4 2) '(4) '(3))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 4 2) '(4) '(3))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 3 4 1 2) '(4) '(3)))))
+ (with-test-prefix "lset-difference!"
+ (test-shared-behavior lset-difference!)))
;;
;; lset-diff+intersection