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

@@ -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)

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);

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