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

[Rob Browning]

rlb pushed a commit to branch main
in repository guile.

commit 51b7021de184d4a2b737edbef2bd9a8dd7966874
Author: Rob Browning <rlb@defaultvalue.org>
AuthorDate: Sat Jul 20 10:07:59 2024 -0500

    srfi-1 delete-duplicates: move from C to Scheme
    
    * libguile/srfi-1.c (scm_srfi1_delete-duplicates): delete.
    * libguile/srfi-1.h (scm_srfi1_delete-duplicates): delete.
    * module/srfi/srfi-1.scm: add delete-duplicates.
---
 libguile/srfi-1.c      | 138 -------------------------------------------------
 libguile/srfi-1.h      |   2 -
 module/srfi/srfi-1.scm |  46 +++++++++++++++++
 3 files changed, 46 insertions(+), 140 deletions(-)

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index ba48e3425..c3d79e766 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -51,144 +51,6 @@
  * 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_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
-
 
 void
 scm_register_srfi_1 (void)
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index bd230d10f..eb027a0c2 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -24,8 +24,6 @@
 
 #include "libguile/scm.h"
 
-SCM_INTERNAL SCM scm_srfi1_delete_duplicates (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 146912e29..2e083c8aa 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -1170,6 +1170,52 @@ 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.