[Guile-commits] 10/17: srfi-1 partition: move from C to Scheme

[Rob Browning]

rlb pushed a commit to branch main
in repository guile.

commit 925faf1f01106e468dde78c453595575904bc158
Author: Rob Browning <rlb@defaultvalue.org>
AuthorDate: Wed Jul 17 22:12:22 2024 -0500

    srfi-1 partition: move from C to Scheme
    
    * libguile/srfi-1.c (scm_srfi1_partition): delete.
    * libguile/srfi-1.h (scm_srfi1_partition): delete.
    * module/srfi/srfi-1.scm: add partition.
---
 libguile/srfi-1.c      | 42 ------------------------------------------
 libguile/srfi-1.h      |  1 -
 module/srfi/srfi-1.scm | 22 ++++++++++++++++++++++
 3 files changed, 22 insertions(+), 43 deletions(-)

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index aaa156d3e..e79492f65 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -331,48 +331,6 @@ SCM_DEFINE (scm_srfi1_lset_difference_x, 
"lset-difference!", 2, 0, 1,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
-           (SCM pred, SCM list),
-           "Partition the elements of @var{list} with predicate @var{pred}.\n"
-           "Return two values: the list of elements satisfying @var{pred} 
and\n"
-           "the list of elements @emph{not} satisfying @var{pred}.  The 
order\n"
-           "of the output lists follows the order of @var{list}.  @var{list}\n"
-           "is not mutated.  One of the output lists may share memory with 
@var{list}.\n")
-#define FUNC_NAME s_scm_srfi1_partition
-{
-  /* In this implementation, the output lists don't share memory with
-     list, because it's probably not worth the effort. */
-  SCM orig_list = list;
-  SCM kept = scm_cons(SCM_EOL, SCM_EOL);
-  SCM kept_tail = kept;
-  SCM dropped = scm_cons(SCM_EOL, SCM_EOL);
-  SCM dropped_tail = dropped;
-  
-  SCM_VALIDATE_PROC (SCM_ARG1, pred);
-  
-  for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) {
-    SCM elt, new_tail;
-
-    /* Make sure LIST is not a dotted list.  */
-    SCM_ASSERT (scm_is_pair (list), orig_list, SCM_ARG2, FUNC_NAME);
-
-    elt = SCM_CAR (list);
-    new_tail = scm_cons (SCM_CAR (list), SCM_EOL);
-
-    if (scm_is_true (scm_call_1 (pred, elt))) {
-      SCM_SETCDR(kept_tail, new_tail);
-      kept_tail = new_tail;
-    }
-    else {
-      SCM_SETCDR(dropped_tail, new_tail);
-      dropped_tail = new_tail;
-    }
-  }
-  return scm_values_2 (SCM_CDR (kept), SCM_CDR (dropped));
-}
-#undef FUNC_NAME
-
-
 SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0,
             (SCM pred, SCM lst),
            "Split @var{lst} into those elements which do and don't satisfy\n"
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index 9a4eeef6f..744397e9a 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -27,7 +27,6 @@
 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 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 void scm_register_srfi_1 (void);
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 2ecdcd7ff..b44eb0341 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -841,6 +841,28 @@ the list returned."
 
 ;;; Filtering & partitioning
 
+(define (partition pred lst)
+  "Partition the elements of @var{list} with predicate @var{pred}.
+Return two values: the list of elements satisfying @var{pred} and the
+list of elements @emph{not} satisfying @var{pred}.  The order of the
+output lists follows the order of @var{list}.  @var{list} is not
+mutated.  One of the output lists may share memory with @var{list}."
+  (let ((matches (list #f))
+        (mismatches (list #f)))
+    (let lp ((lst lst)
+             (matches-end matches)
+             (mismatches-end mismatches))
+      (if (null? lst)
+          (values (cdr matches) (cdr mismatches))
+          (let ((x (car lst)))
+            (if (pred x)
+                (begin
+                  (set-cdr! matches-end (list x))
+                  (lp (cdr lst) (cdr matches-end) mismatches-end))
+                (begin
+                  (set-cdr! mismatches-end (list x))
+                  (lp (cdr lst) matches-end (cdr mismatches-end)))))))))
+
 (define (list-prefix-and-tail lst stop)
   (when (eq? lst stop)
     (error "Prefix cannot be empty"))