mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 15:00:21 +02:00
Code Activity

(scm_srfi1_delete, scm_srfi1_delete_x,

Browse source 
scm_srfi1_delete_duplicates, scm_srfi1_delete_duplicates_x): New
functions.  scm_srfi1_delete_x is derived from scm_delete_x.
This commit is contained in:
Kevin Ryde 2003-07-08 00:09:17 +00:00
parent 7a7b738455
commit d0a634de7d
1 changed files with 308 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

315
srfi/srfi-1.c
View file

@ -1,6 +1,7 @@
/* srfi-1.c --- SRFI-1 procedures for Guile
*
* Copyright (C) 2002, 2003 Free Software Foundation, Inc.
* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003 Free Software
* Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@ -55,6 +56,312 @@ srfi1_ilength (SCM sx)
return -1;
}
static SCM
equal_trampoline (SCM proc, SCM arg1, SCM arg2)
{
return scm_equal_p (arg1, arg2);
}
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_t_trampoline_2 equal_p;
SCM ret, *p, keeplst;
if (SCM_UNBNDP (pred))
return scm_delete (x, lst);
equal_p = scm_trampoline_2 (pred);
SCM_ASSERT (equal_p, 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. When
there's no more deletions, *p can be set to keeplst to share the
remainder of the original lst. (The entire original lst if there's no
deletions at all.) */
keeplst = lst;
ret = SCM_EOL;
p = &ret;
for ( ; SCM_CONSP (lst); lst = SCM_CDR (lst))
{
if (! SCM_FALSEP (equal_p (pred, x, SCM_CAR (lst))))
{
/* delete this element, so copy from keeplst (inclusive) to lst
(exclusive) onto ret */
while (! SCM_EQ_P (keeplst, lst))
{
SCM c = scm_cons (SCM_CAR (keeplst), SCM_EOL);
*p = c;
p = SCM_CDRLOC (c);
keeplst = SCM_CDR (keeplst);
}
keeplst = SCM_CDR (lst);
}
}
/* 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_t_trampoline_2 equal_p;
SCM walk;
SCM *prev;
if (SCM_UNBNDP (pred))
return scm_delete_x (x, lst);
equal_p = scm_trampoline_2 (pred);
SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME);
for (prev = &lst, walk = lst;
SCM_CONSP (walk);
walk = SCM_CDR (walk))
{
if (! SCM_FALSEP (equal_p (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;
/* 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 = lst;
if (SCM_CONSP (lst))
{
if (SCM_UNBNDP (pred))
equal_p = equal_trampoline;
else
{
equal_p = scm_trampoline_2 (pred);
SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME);
}
keeplst = lst;
p = &ret;
/* loop over lst elements starting from second */
for (;;)
{
lst = SCM_CDR (lst);
if (! SCM_CONSP (lst))
break;
item = SCM_CAR (lst);
/* loop searching ret upto lst */
for (l = ret; ! SCM_EQ_P (l, lst); l = SCM_CDR (l))
{
if (! SCM_FALSEP (equal_p (pred, SCM_CAR (l), item)))
{
/* duplicate, don't want this element, so copy keeplst
(inclusive) to lst (exclusive) onto ret */
while (! SCM_EQ_P (keeplst, lst))
{
SCM c = scm_cons (SCM_CAR (keeplst), SCM_EOL);
*p = c;
p = SCM_CDRLOC (c);
keeplst = SCM_CDR (keeplst);
}
keeplst = SCM_CDR (lst); /* elem after the one deleted */
*p = keeplst;
break;
}
}
}
}
/* 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_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_CONSP (lst))
{
if (SCM_UNBNDP (pred))
equal_p = equal_trampoline;
else
{
equal_p = scm_trampoline_2 (pred);
SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME);
}
endret = ret;
/* loop over lst elements starting from second */
for (;;)
{
lst = SCM_CDR (lst);
if (! SCM_CONSP (lst))
break;
item = SCM_CAR (lst);
/* is item equal to any element from ret to endret (inclusive)? */
l = ret;
for (;;)
{
if (! SCM_FALSEP (equal_p (pred, SCM_CAR (l), item)))
break; /* equal, forget this element */
if (SCM_EQ_P (l, endret))
{
/* not equal to any, so append this pair */
SCM_SETCDR (endret, lst);
endret = lst;
break;
}
l = SCM_CDR (l);
}
}
/* terminate, in case last element was deleted */
SCM_SETCDR (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
/* Typechecking for multi-argument MAP and FOR-EACH.
Verify that each element of the vector ARGV, except for the first,
@ -253,12 +560,6 @@ scm_srfi1_for_each (SCM proc, SCM arg1, SCM args)
#undef FUNC_NAME
static SCM
equal_trampoline (SCM proc, SCM arg1, SCM arg2)
{
return scm_equal_p (arg1, arg2);
}
SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0,
(SCM x, SCM lst, SCM pred),
"Return the first sublist of @var{lst} whose car is\n"