mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
Merge conversion of srfi-1.c to srfi-1.scm
Rewrite the srfi-1 C functions in Scheme and remove srfi-1.c as planned (see the comments at the top of srfi-1.c). The previous C code mutated intermediate results in some cases, even for non-! functions (e.g. set-cdr! to build the result without stack growth or a reverse!); some of the conversions preserve that approach for now. Simple testing via https://github.com/ecraven/r7rs-benchmarks/ didn't reveal any substantial performance regressions. Thanks to David Thompson for reviewing the changes and suggesting improvements.
This commit is contained in:
Rob Browning
commit
bce91cebed
6 changed files with 468 additions and 1020 deletions
|
|
@ -210,7 +210,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \
|
||||||
smob.c \
|
smob.c \
|
||||||
sort.c \
|
sort.c \
|
||||||
srcprop.c \
|
srcprop.c \
|
||||||
srfi-1.c \
|
|
||||||
srfi-4.c \
|
srfi-4.c \
|
||||||
srfi-13.c \
|
srfi-13.c \
|
||||||
srfi-14.c \
|
srfi-14.c \
|
||||||
|
|
@ -324,7 +323,6 @@ DOT_X_FILES = \
|
||||||
smob.x \
|
smob.x \
|
||||||
sort.x \
|
sort.x \
|
||||||
srcprop.x \
|
srcprop.x \
|
||||||
srfi-1.x \
|
|
||||||
srfi-4.x \
|
srfi-4.x \
|
||||||
srfi-13.x \
|
srfi-13.x \
|
||||||
srfi-14.x \
|
srfi-14.x \
|
||||||
|
|
@ -426,7 +424,6 @@ DOT_DOC_FILES = \
|
||||||
smob.doc \
|
smob.doc \
|
||||||
sort.doc \
|
sort.doc \
|
||||||
srcprop.doc \
|
srcprop.doc \
|
||||||
srfi-1.doc \
|
|
||||||
srfi-4.doc \
|
srfi-4.doc \
|
||||||
srfi-13.doc \
|
srfi-13.doc \
|
||||||
srfi-14.doc \
|
srfi-14.doc \
|
||||||
|
|
@ -691,7 +688,6 @@ modinclude_HEADERS = \
|
||||||
socket.h \
|
socket.h \
|
||||||
sort.h \
|
sort.h \
|
||||||
srcprop.h \
|
srcprop.h \
|
||||||
srfi-1.h \
|
|
||||||
srfi-4.h \
|
srfi-4.h \
|
||||||
srfi-13.h \
|
srfi-13.h \
|
||||||
srfi-14.h \
|
srfi-14.h \
|
||||||
|
|
|
||||||
|
|
@ -128,7 +128,6 @@
|
||||||
#include "socket.h"
|
#include "socket.h"
|
||||||
#include "sort.h"
|
#include "sort.h"
|
||||||
#include "srcprop.h"
|
#include "srcprop.h"
|
||||||
#include "srfi-1.h"
|
|
||||||
#include "srfi-13.h"
|
#include "srfi-13.h"
|
||||||
#include "srfi-14.h"
|
#include "srfi-14.h"
|
||||||
#include "srfi-4.h"
|
#include "srfi-4.h"
|
||||||
|
|
@ -377,7 +376,6 @@ scm_i_init_guile (void *base)
|
||||||
scm_register_fdes_finalizers ();
|
scm_register_fdes_finalizers ();
|
||||||
scm_register_foreign ();
|
scm_register_foreign ();
|
||||||
scm_register_foreign_object ();
|
scm_register_foreign_object ();
|
||||||
scm_register_srfi_1 ();
|
|
||||||
scm_register_srfi_60 ();
|
scm_register_srfi_60 ();
|
||||||
scm_register_poll ();
|
scm_register_poll ();
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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
|
|
||||||
<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_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. */
|
|
||||||
|
|
@ -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
|
|
||||||
<https://www.gnu.org/licenses/>. */
|
|
||||||
|
|
||||||
|
|
||||||
#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 */
|
|
||||||
|
|
@ -224,11 +224,6 @@
|
||||||
|
|
||||||
(cond-expand-provide (current-module) '(srfi-1))
|
(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
|
;;; Constructors
|
||||||
|
|
||||||
|
|
@ -262,6 +257,24 @@ INIT-PROC is applied to the indices is not specified."
|
||||||
acc
|
acc
|
||||||
(lp (- n 1) (cons (init-proc (- n 1)) 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)
|
(define (circular-list elt1 . elts)
|
||||||
(set! elts (cons elt1 elts))
|
(set! elts (cons elt1 elts))
|
||||||
(set-cdr! (last-pair elts) elts)
|
(set-cdr! (last-pair elts) elts)
|
||||||
|
|
@ -427,6 +440,88 @@ a list of those after."
|
||||||
|
|
||||||
;;; Miscelleneous: length, append, concatenate, reverse, zip & count
|
;;; 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)
|
(define (zip clist1 . rest)
|
||||||
(let lp ((l (cons clist1 rest)) (acc '()))
|
(let lp ((l (cons clist1 rest)) (acc '()))
|
||||||
(if (any null? l)
|
(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)
|
(values (map first l) (map second l) (map third l) (map fourth l)
|
||||||
(map fifth 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
|
;;; Fold, unfold & map
|
||||||
|
|
||||||
(define fold
|
(define fold
|
||||||
|
|
@ -717,6 +833,117 @@ the list returned."
|
||||||
(apply f l)
|
(apply f l)
|
||||||
(lp (map cdr 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
|
;;; Searching
|
||||||
|
|
||||||
|
|
@ -896,6 +1123,126 @@ CLIST1 ... CLISTN, that satisfies PRED."
|
||||||
(else
|
(else
|
||||||
(lp (map cdr lists) (+ i 1)))))))
|
(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
|
;;; Association lists
|
||||||
|
|
||||||
(define alist-cons acons)
|
(define alist-cons acons)
|
||||||
|
|
@ -1034,18 +1381,32 @@ given REST parameters."
|
||||||
(lp (cdr l) (cons (car l) acc))
|
(lp (cdr l) (cons (car l) acc))
|
||||||
(lp (cdr l) acc)))))
|
(lp (cdr l) acc)))))
|
||||||
|
|
||||||
(define (lset-difference = list1 . rest)
|
(define (lset-difference = lset . removals)
|
||||||
(check-arg procedure? = lset-difference)
|
"Return @var{lst} with any elements in the lists in @var{removals}
|
||||||
(if (null? rest)
|
removed (ie.@: subtracted). For only one @var{lst} argument, just that
|
||||||
list1
|
list is returned.
|
||||||
(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 (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)
|
(define (lset-xor = . rest)
|
||||||
(check-arg procedure? = lset-xor)
|
(check-arg procedure? = lset-xor)
|
||||||
|
|
@ -1083,6 +1444,30 @@ given REST parameters."
|
||||||
(check-arg procedure? = lset-intersection!)
|
(check-arg procedure? = lset-intersection!)
|
||||||
(apply lset-intersection = list1 rest)) ; XXX:optimize
|
(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)
|
(define (lset-xor! = . rest)
|
||||||
(check-arg procedure? = lset-xor!)
|
(check-arg procedure? = lset-xor!)
|
||||||
(apply lset-xor = rest)) ; XXX:optimize
|
(apply lset-xor = rest)) ; XXX:optimize
|
||||||
|
|
|
||||||
|
|
@ -21,6 +21,8 @@
|
||||||
#:use-module (ice-9 copy-tree)
|
#:use-module (ice-9 copy-tree)
|
||||||
#:use-module (srfi srfi-1))
|
#: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)
|
(define (ref-delete x lst . proc)
|
||||||
"Reference implemenation of srfi-1 `delete'."
|
"Reference implemenation of srfi-1 `delete'."
|
||||||
|
|
@ -463,10 +465,10 @@
|
||||||
(pass-if-exception "too many args" exception:wrong-num-args
|
(pass-if-exception "too many args" exception:wrong-num-args
|
||||||
(concatenate-proc '() '()))
|
(concatenate-proc '() '()))
|
||||||
|
|
||||||
(pass-if-exception "number" exception:wrong-type-arg
|
(pass-if-exception "number" '(wrong-type-arg . "Apply to non-list")
|
||||||
(concatenate-proc 123))
|
(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)))
|
(concatenate-proc #(1 2 3)))
|
||||||
|
|
||||||
(pass-if "no lists"
|
(pass-if "no lists"
|
||||||
|
|
@ -1188,18 +1190,18 @@
|
||||||
(pass-if-exception "proc arg count 4" exception:wrong-num-args
|
(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)))
|
(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)))
|
(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)))
|
(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)))
|
(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))
|
(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)))
|
(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)))
|
(fold + 1 '(1 2 3) '(1 2 . 3)))
|
||||||
|
|
||||||
(pass-if (= 6 (fold + 1 '(2) '(3))))
|
(pass-if (= 6 (fold + 1 '(2) '(3))))
|
||||||
|
|
@ -1330,9 +1332,9 @@
|
||||||
(length+))
|
(length+))
|
||||||
(pass-if-exception "too many args" exception:wrong-num-args
|
(pass-if-exception "too many args" exception:wrong-num-args
|
||||||
(length+ 123 456))
|
(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))
|
(length+ 'x))
|
||||||
(pass-if-exception "improper list" exception:wrong-type-arg
|
(pass-if-exception "improper list" list+-bad-arg-exception
|
||||||
(length+ '(x y . z)))
|
(length+ '(x y . z)))
|
||||||
(pass-if (= 0 (length+ '())))
|
(pass-if (= 0 (length+ '())))
|
||||||
(pass-if (= 1 (length+ '(x))))
|
(pass-if (= 1 (length+ '(x))))
|
||||||
|
|
@ -1449,7 +1451,14 @@
|
||||||
(pass-if (equal? '(1 . 2) (list-copy '(1 . 2))))
|
(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) (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) (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
|
;; list-index
|
||||||
|
|
@ -1760,72 +1769,64 @@
|
||||||
(equal? '(1 2) (lset-adjoin = '(2) 1 1))))
|
(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 "called arg order"
|
|
||||||
(let ((good #f))
|
|
||||||
(lset-difference (lambda (x y)
|
|
||||||
(set! good (and (= x 1) (= y 2)))
|
|
||||||
(= x y))
|
|
||||||
'(1) '(2))
|
|
||||||
good)))
|
|
||||||
|
|
||||||
;;
|
|
||||||
;; lset-difference!
|
|
||||||
;;
|
|
||||||
|
|
||||||
(with-test-prefix "lset-difference!"
|
|
||||||
|
|
||||||
(pass-if-exception "proc - num" exception:wrong-type-arg
|
(pass-if-exception "proc - num" exception:wrong-type-arg
|
||||||
(lset-difference! 123 '(4)))
|
(diff 123 '(4)))
|
||||||
(pass-if-exception "proc - list" exception:wrong-type-arg
|
(pass-if-exception "proc - list" exception:wrong-type-arg
|
||||||
(lset-difference! (list 1 2 3) '(4)))
|
(diff (list 1 2 3) '(4)))
|
||||||
|
|
||||||
(pass-if "called arg order"
|
(pass-if "called arg order"
|
||||||
(let ((good #f))
|
(let ((good #f))
|
||||||
(lset-difference! (lambda (x y)
|
(diff (lambda (x y)
|
||||||
(set! good (and (= x 1) (= y 2)))
|
(set! good (and (= x 1) (= y 2)))
|
||||||
(= x y))
|
(= x y))
|
||||||
(list 1) (list 2))
|
(list 1) (list 2))
|
||||||
good))
|
good))
|
||||||
|
|
||||||
(pass-if (equal? '() (lset-difference! = '())))
|
(pass-if (equal? '() (diff = '())))
|
||||||
(pass-if (equal? '(1) (lset-difference! = (list 1))))
|
(pass-if (equal? '(1) (diff = (list 1))))
|
||||||
(pass-if (equal? '(1 2) (lset-difference! = (list 1 2))))
|
(pass-if (equal? '(1 2) (diff = (list 1 2))))
|
||||||
|
|
||||||
(pass-if (equal? '() (lset-difference! = (list ) '(3))))
|
(pass-if (equal? '() (diff = (list ) '(3))))
|
||||||
(pass-if (equal? '() (lset-difference! = (list 3) '(3))))
|
(pass-if (equal? '() (diff = (list 3) '(3))))
|
||||||
(pass-if (equal? '(1) (lset-difference! = (list 1 3) '(3))))
|
(pass-if (equal? '(1) (diff = (list 1 3) '(3))))
|
||||||
(pass-if (equal? '(1) (lset-difference! = (list 3 1) '(3))))
|
(pass-if (equal? '(1) (diff = (list 3 1) '(3))))
|
||||||
(pass-if (equal? '(1) (lset-difference! = (list 1 3 3) '(3))))
|
(pass-if (equal? '(1) (diff = (list 1 3 3) '(3))))
|
||||||
(pass-if (equal? '(1) (lset-difference! = (list 3 1 3) '(3))))
|
(pass-if (equal? '(1) (diff = (list 3 1 3) '(3))))
|
||||||
(pass-if (equal? '(1) (lset-difference! = (list 3 3 1) '(3))))
|
(pass-if (equal? '(1) (diff = (list 3 3 1) '(3))))
|
||||||
|
|
||||||
(pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2 3))))
|
(pass-if (equal? '(1) (diff = (list 1 2 3) '(2 3))))
|
||||||
(pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3 2))))
|
(pass-if (equal? '(1) (diff = (list 1 2 3) '(3 2))))
|
||||||
(pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3) '(2))))
|
(pass-if (equal? '(1) (diff = (list 1 2 3) '(3) '(2))))
|
||||||
(pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3))))
|
(pass-if (equal? '(1) (diff = (list 1 2 3) '(2) '(3))))
|
||||||
(pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(2 3))))
|
(pass-if (equal? '(1) (diff = (list 1 2 3) '(2) '(2 3))))
|
||||||
(pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3 2))))
|
(pass-if (equal? '(1) (diff = (list 1 2 3) '(2) '(3 2))))
|
||||||
|
|
||||||
(pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3) '(3) '(3))))
|
(pass-if (equal? '(1 2) (diff = (list 1 2 3) '(3) '(3))))
|
||||||
(pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2) '(3) '(3))))
|
(pass-if (equal? '(1 2) (diff = (list 1 3 2) '(3) '(3))))
|
||||||
(pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2) '(3) '(3))))
|
(pass-if (equal? '(1 2) (diff = (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) (diff = (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) (diff = (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) (diff = (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 3) (diff = (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) (diff = (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) (diff = (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) (diff = (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) (diff = (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) (diff = (list 3 1 4 2) '(4) '(3))))
|
||||||
(pass-if (equal? '(1 2) (lset-difference! = (list 3 4 1 2) '(4) '(3)))))
|
(pass-if (equal? '(1 2) (diff = (list 3 4 1 2) '(4) '(3)))))
|
||||||
|
|
||||||
|
(with-test-prefix "lset-difference"
|
||||||
|
(test-shared-behavior lset-difference))
|
||||||
|
|
||||||
|
(with-test-prefix "lset-difference!"
|
||||||
|
(test-shared-behavior lset-difference!)))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; lset-diff+intersection
|
;; lset-diff+intersection
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue