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

[Rob Browning]

rlb pushed a commit to branch main
in repository guile.

commit 3eb6afe738b313deac6b43cc4c883f70179f48cc
Author: Rob Browning <rlb@defaultvalue.org>
AuthorDate: Wed Jul 17 22:18:05 2024 -0500

    srfi-1 partition!: move from C to Scheme
    
    * libguile/srfi-1.c (scm_srfi1_partition_x): delete.
    * libguile/srfi-1.h (scm_srfi1_partition_x): delete.
    * module/srfi/srfi-1.scm: add partition!.
---
 libguile/srfi-1.c      | 53 --------------------------------------------------
 libguile/srfi-1.h      |  1 -
 module/srfi/srfi-1.scm | 21 ++++++++++++++++++++
 3 files changed, 21 insertions(+), 54 deletions(-)

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index e79492f65..64b4f46ee 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -331,59 +331,6 @@ SCM_DEFINE (scm_srfi1_lset_difference_x, 
"lset-difference!", 2, 0, 1,
 }
 #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"
-           "the predicate @var{pred}.\n"
-           "\n"
-           "The return is two values (@pxref{Multiple Values}), the first\n"
-           "being a list of all elements from @var{lst} which satisfy\n"
-           "@var{pred}, the second a list of those which do not.\n"
-           "\n"
-           "The elements in the result lists are in the same order as in\n"
-           "@var{lst} but the order in which the calls @code{(@var{pred}\n"
-           "elem)} are made on the list elements is unspecified.\n"
-           "\n"
-           "@var{lst} may be modified to construct the return lists.")
-#define FUNC_NAME s_scm_srfi1_partition_x
-{
-  SCM  tlst, flst, *tp, *fp;
-
-  SCM_ASSERT (scm_is_true (scm_procedure_p (pred)), pred, SCM_ARG1, FUNC_NAME);
-
-  /* tlst and flst are the lists of true and false elements.  tp and fp are
-     where to store to append to them, initially &tlst and &flst, then
-     SCM_CDRLOC of the last pair in the respective lists.  */
-
-  tlst = SCM_EOL;
-  flst = SCM_EOL;
-  tp = &tlst;
-  fp = &flst;
-
-  for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
-    {
-      if (scm_is_true (scm_call_1 (pred, SCM_CAR (lst))))
-        {
-          *tp = lst;
-          tp = SCM_CDRLOC (lst);
-        }
-      else
-        {
-          *fp = lst;
-          fp = SCM_CDRLOC (lst);
-        }
-    }
-
-  SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
-
-  /* terminate whichever didn't get the last element(s) */
-  *tp = SCM_EOL;
-  *fp = SCM_EOL;
-
-  return scm_values_2 (tlst, flst);
-}
-#undef FUNC_NAME
-
 
 void
 scm_register_srfi_1 (void)
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index 744397e9a..c0f8f8866 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_x (SCM pred, SCM list);
 
 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 b44eb0341..49ee46e40 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -907,6 +907,27 @@ a common tail with @{list}."
                             (lp (cdr lst) (cdr lst) new-tail))))
                     (lp (cdr lst) last-kept tail))))))))
 
+(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.  @var{lst} may be modified to construct the return lists."
+  (let ((matches (cons #f lst))
+        (mismatches (list #f)))
+    (let lp ((matches-next matches)
+             (mismatches-end mismatches))
+      (let ((next (cdr matches-next)))
+        (if (null? next)
+            (values (cdr matches) (cdr mismatches))
+            (let ((x (car next)))
+              (if (pred x)
+                  (lp (cdr matches-next) mismatches-end)
+                  (begin
+                    (set-cdr! matches-next (cdr next))
+                    (set-cdr! mismatches-end (list x))
+                    (lp matches-next (cdr mismatches-end))))))))))
+
 (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