mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

srfi-1 delete-duplicates!: move from C to Scheme

Browse source 
* libguile/srfi-1.c (scm_srfi1_delete-duplicates_x): delete.
* libguile/srfi-1.h (scm_srfi1_delete-duplicates_x): delete.
* module/srfi/srfi-1.scm: add delete-duplicates!.
This commit is contained in:
Rob Browning 2024-07-18 03:23:27 -05:00
parent 51e15d448f
commit a94b4406b7
3 changed files with 39 additions and 84 deletions
Download patch file Download diff file Expand all files Collapse all files

83
libguile/srfi-1.c
View file

@ -189,89 +189,6 @@ SCM_DEFINE (scm_srfi1_delete_duplicates, "delete-duplicates", 1, 1, 0,
} }
#undef FUNC_NAME #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
void void
scm_register_srfi_1 (void) scm_register_srfi_1 (void)

1
libguile/srfi-1.h
View file

@ -25,7 +25,6 @@
#include "libguile/scm.h" #include "libguile/scm.h"
SCM_INTERNAL SCM scm_srfi1_delete_duplicates (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 void scm_register_srfi_1 (void); SCM_INTERNAL void scm_register_srfi_1 (void);
SCM_INTERNAL void scm_init_srfi_1 (void); SCM_INTERNAL void scm_init_srfi_1 (void);

39
module/srfi/srfi-1.scm
View file

@ -1147,6 +1147,13 @@ be deleted with @code{(delete 5 lst <)}.
tail with @var{lst}." tail with @var{lst}."
(remove (lambda (elem) (pred x elem)) 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?)) (define* (delete! x lst #:optional (pred equal?))
"Return a list containing the elements of @var{lst} but with "Return a list containing the elements of @var{lst} but with
those equal to @var{x} deleted. The returned elements will be in the those equal to @var{x} deleted. The returned elements will be in the
@ -1163,6 +1170,38 @@ be deleted with @code{(delete 5 lst <)}.
@var{lst} may be modified to construct the returned list." @var{lst} may be modified to construct the returned list."
(remove! (lambda (elem) (pred x elem)) lst)) (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{=}, 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)