[Guile-commits] 14/17: srfi-1 delete-duplicates!: move from C to Scheme

[Rob Browning]

rlb pushed a commit to branch main
in repository guile.

commit a94b4406b76082d2a98842a404b7a068729dcf58
Author: Rob Browning <rlb@defaultvalue.org>
AuthorDate: Thu Jul 18 03:23:27 2024 -0500

    srfi-1 delete-duplicates!: move from C to Scheme
    
    * 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!.
---
 libguile/srfi-1.c      | 83 --------------------------------------------------
 libguile/srfi-1.h      |  1 -
 module/srfi/srfi-1.scm | 39 ++++++++++++++++++++++++
 3 files changed, 39 insertions(+), 84 deletions(-)

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 56e12296b..ba48e3425 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -189,89 +189,6 @@ SCM_DEFINE (scm_srfi1_delete_duplicates, 
"delete-duplicates", 1, 1, 0,
 }
 #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
 scm_register_srfi_1 (void)
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index 1e906424d..bd230d10f 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -25,7 +25,6 @@
 #include "libguile/scm.h"
 
 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_init_srfi_1 (void);
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 793185e1d..146912e29 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -1147,6 +1147,13 @@ be deleted with @code{(delete 5 lst <)}.
 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
@@ -1163,6 +1170,38 @@ 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{=}, 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)