[Guile-commits] 02/17: srfi-1 remove: move from C to Scheme

[Rob Browning]

rlb pushed a commit to branch main
in repository guile.

commit 03d4a3b5df6c59f620b5576ef37794daa84ffae7
Author: Rob Browning <rlb@defaultvalue.org>
AuthorDate: Sat Jul 20 15:53:00 2024 -0500

    srfi-1 remove: move from C to Scheme
    
    The Scheme implementation is an adapted version of the approach used by
    delete-duplicates, which allows sharing any common tail.
    
    * libguile/srfi-1.c (scm_srfi1_remove): delete.
    * libguile/srfi-1.h (scm_srfi1_remove): delete.
    * module/srfi/srfi-1.scm: add remove.
---
 libguile/srfi-1.c      | 31 -------------------------------
 libguile/srfi-1.h      |  1 -
 module/srfi/srfi-1.scm | 47 +++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 47 insertions(+), 32 deletions(-)

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index bb7930cc0..2ea915e8f 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -772,37 +772,6 @@ SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0,
 }
 #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"
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index 20cb478b4..61d479864 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -37,7 +37,6 @@ 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_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);
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 89090af89..313227ad4 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -736,6 +736,53 @@ the list returned."
          (lp (map cdr l)))))))
 
 
+;;; Filtering & partitioning
+
+(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))))))))
+
+
 ;;; Searching
 
 (define (find pred lst)