SRFI-1: Rewrite `split-at' and `split-at!' in Scheme.

This partially reverts commit bb560b9c16893f762699ba5a3109c8367fff8dfc
(Tue Mar 15 2005).

* module/srfi/srfi-1.scm (out-of-range, split-at, split-at!): New
  procedures.

* libguile/srfi-1.c (scm_srfi1_split_at, scm_srfi1_split_at_x): Remove.
* libguile/srfi-1.h (scm_srfi1_split_at, scm_srfi1_split_at_x): Ditto.

3 files changed, 28 insertions, 53 deletions

diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 6d5a1ab90..e2a9c9319 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -1183,57 +1183,6 @@ SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-
-SCM_DEFINE (scm_srfi1_split_at, "split-at", 2, 0, 0,
-            (SCM lst, SCM n),
-	    "Return two values (multiple values), being a list of the\n"
-	    "elements before index @var{n} in @var{lst}, and a list of those\n"
-	    "after.")
-#define FUNC_NAME s_scm_srfi1_split_at
-{
-  size_t nn;
-  /* pre is a list of elements before the i split point, loc is the CDRLOC
-     of the last cell, ie. where to store to append to it */
-  SCM pre = SCM_EOL;
-  SCM *loc = ⪯
-
-  for (nn = scm_to_size_t (n); nn != 0; nn--)
-    {
-      SCM_VALIDATE_CONS (SCM_ARG1, lst);
-
-      *loc = scm_cons (SCM_CAR (lst), SCM_EOL);
-      loc = SCM_CDRLOC (*loc);
-      lst = SCM_CDR(lst);
-    }
-  return scm_values (scm_list_2 (pre, lst));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_split_at_x, "split-at!", 2, 0, 0,
-            (SCM lst, SCM n),
-	    "Return two values (multiple values), being a list of the\n"
-	    "elements before index @var{n} in @var{lst}, and a list of those\n"
-	    "after.  @var{lst} is modified to form those values.")
-#define FUNC_NAME s_scm_srfi1_split_at
-{
-  size_t nn;
-  SCM upto = lst;
-  SCM *loc = &lst;
-
-  for (nn = scm_to_size_t (n); nn != 0; nn--)
-    {
-      SCM_VALIDATE_CONS (SCM_ARG1, upto);
-
-      loc = SCM_CDRLOC (upto);
-      upto = SCM_CDR (upto);
-    }
-
-  *loc = SCM_EOL;
-  return scm_values (scm_list_2 (lst, upto));
-}
-#undef FUNC_NAME
-
 SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0,
             (SCM lst, SCM n),
 	    "Return the a list containing the @var{n} last elements of\n"
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index 87aa98981..593d9bb02 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -47,8 +47,6 @@ 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 SCM scm_srfi1_split_at (SCM lst, SCM n);
-SCM_INTERNAL SCM scm_srfi1_split_at_x (SCM lst, SCM n);
 SCM_INTERNAL SCM scm_srfi1_take_right (SCM lst, SCM n);
 
 SCM_INTERNAL void scm_register_srfi_1 (void);
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 5bcc3611c..8ddf2714b 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -238,6 +238,10 @@ higher-order procedures."
       (scm-error 'wrong-type-arg caller
 		 "Wrong type argument: ~S" (list arg) '())))
 
+(define (out-of-range proc arg)
+  (scm-error 'out-of-range proc
+             "Value out of range: ~A" (list arg) (list arg)))
+
 ;; the srfi spec doesn't seem to forbid inexact integers.
 (define (non-negative-integer? x) (and (integer? x) (>= x 0)))
 
@@ -375,6 +379,30 @@ end-of-list checking in contexts where dotted lists are allowed."
               (loop (cdr prev)
                     (cdr tail)))))))
 
+(define (split-at lst i)
+  "Return two values, a list of the elements before index I in LST, and
+a list of those after."
+  (if (< i 0)
+      (out-of-range 'split-at i)
+      (let lp ((l lst) (n i) (acc '()))
+        (if (<= n 0)
+            (values (reverse! acc) l)
+            (lp (cdr l) (- n 1) (cons (car l) acc))))))
+
+(define (split-at! lst i)
+  "Linear-update variant of `split-at'."
+  (cond ((< i 0)
+         (out-of-range 'split-at! i))
+        ((= i 0)
+         (values '() lst))
+        (else
+         (let lp ((l lst) (n (- i 1)))
+           (if (<= n 0)
+               (let ((tmp (cdr l)))
+                 (set-cdr! l '())
+                 (values lst tmp))
+               (lp (cdr l) (- n 1)))))))
+
 (define (last pair)
   "Return the last element of the non-empty, finite list PAIR."
   (car (last-pair pair)))