Added split-at' and split-at-right', with documentation and tests,

and made srfi/1 use it.

svn: r10558

collects/scheme/list.ss

@@ -10,8 +10,10 @@
 
          drop
          take
+         split-at
          drop-right
          take-right
+         split-at-right
 
          append*
          flatten
@@ -99,28 +101,47 @@
     (raise-type-error 'drop "non-negative exact integer" n))
   (or (drop* list n) (too-large 'drop list n)))
 
+(define (split-at list0 n0)
+  (unless (exact-nonnegative-integer? n0)
+    (raise-type-error 'split-at "non-negative exact integer" n0))
+  (let loop ([list list0] [n n0] [pfx '()])
+    (cond [(zero? n) (values (reverse pfx) list)]
+          [(pair? list) (loop (cdr list) (sub1 n) (cons (car list) pfx))]
+          [else (too-large 'take list0 n0)])))
+
 ;; take/drop-right are originally from srfi-1, uses the same lead-pointer trick
 
 (define (take-right list n)
   (unless (exact-nonnegative-integer? n)
     (raise-type-error 'take-right "non-negative exact integer" n))
-  (let loop ([lag list]
+  (let loop ([list list]
              [lead (or (drop* list n) (too-large 'take-right list n))])
     ;; could throw an error for non-lists, but be more like `take'
     (if (pair? lead)
-      (loop (cdr lag) (cdr lead))
-      lag)))
+      (loop (cdr list) (cdr lead))
+      list)))
 
 (define (drop-right list n)
   (unless (exact-nonnegative-integer? n)
     (raise-type-error 'drop-right "non-negative exact integer" n))
-  (let loop ([lag list]
+  (let loop ([list list]
              [lead (or (drop* list n) (too-large 'drop-right list n))])
     ;; could throw an error for non-lists, but be more like `drop'
     (if (pair? lead)
-      (cons (car lag) (loop (cdr lag) (cdr lead)))
+      (cons (car list) (loop (cdr list) (cdr lead)))
       '())))
 
+(define (split-at-right list n)
+  (unless (exact-nonnegative-integer? n)
+    (raise-type-error 'split-at-right "non-negative exact integer" n))
+  (let loop ([list list]
+             [lead (or (drop* list n) (too-large 'split-at-right list n))]
+             [pfx '()])
+    ;; could throw an error for non-lists, but be more like `split-at'
+    (if (pair? lead)
+      (loop (cdr list) (cdr lead) (cons (car list) pfx))
+      (values (reverse pfx) list))))
+
 (define append*
   (case-lambda [(ls) (apply append ls)] ; optimize common case
                [(l . lss) (apply append (apply list* l lss))]))

collects/scribblings/reference/pairs.scrbl

@@ -532,6 +532,14 @@ must merely start with a chain of at least @scheme[pos] pairs.
 @defproc[(drop [lst any/c] [pos nonnegative-exact-integer?]) any/c]{
 Just like @scheme[list-tail].}
 
+@defproc[(split-at [lst any/c] [pos nonnegative-exact-integer?])
+         (values list? any/c)]{
+Returns the same result as
+
+@schemeblock[(values (take lst pos) (drop lst pos))]
+
+except that it can be faster.}
+
 @defproc[(take-right [lst any/c] [pos nonnegative-exact-integer?]) any/c]{
 Returns the @scheme[list]'s @scheme[pos]-length tail. If @scheme[lst]
 has fewer than @scheme[pos] elements, then the
@@ -558,6 +566,14 @@ must merely end with a chain of at least @scheme[pos] pairs.
  (drop-right 'non-list 0)
 ]}
 
+@defproc[(split-at-right [lst any/c] [pos nonnegative-exact-integer?])
+         (values list? any/c)]{
+Returns the same result as
+
+@schemeblock[(values (drop-right lst pos) (take-right lst pos))]
+
+except that it can be faster.}
+
 @defproc[(add-between [lst list?] [v any/c]) list?]{
 
 Returns a list with the same elements as @scheme[lst], but with

collects/srfi/1/selector.ss

@@ -35,7 +35,7 @@
 #lang scheme/base
 
 (require srfi/optional
-         (only-in scheme/list take drop take-right drop-right))
+         (only-in scheme/list take drop take-right drop-right split-at))
 
 (provide first second
          third fourth
@@ -120,6 +120,7 @@
                  lis)))
       '()))) ; Special case dropping everything -- no cons to side-effect.
 
+#; ; provided by scheme/list
 (define (split-at x k)
   (check-arg integer? k 'split-at)
   (let recur ((lis x) (k k))

collects/tests/mzscheme/list.ss

@@ -147,7 +147,12 @@
 
 ;; ---------- take/drop[-right] ----------
 (let ()
-  (define funs (list take drop take-right drop-right))
+  (define-syntax-rule (vals-list expr)
+    (call-with-values (lambda () expr) list))
+  (define (split-at*       l n) (vals-list (split-at       l n)))
+  (define (split-at-right* l n) (vals-list (split-at-right l n)))
+  (define funs (list take drop take-right drop-right
+                     split-at* split-at-right*))
   (define tests
     ;; -----args------ --take--- --drop--- --take-r--- --drop-r-
     '([((a b c d) 2)   (a b)     (c d)     (c d)       (a b)    ]
@@ -156,7 +161,12 @@
       [((a b c . d) 1) (a)       (b c . d) (c . d)     (a b)    ]
       [((a b c . d) 3) (a b c)   d         (a b c . d) ()       ]
       [(99 0)          ()        99        99          ()       ]))
-  (for ([t tests] #:when #t [expect (cdr t)] [fun funs])
+  (for ([t tests]
+        #:when #t
+        [expect `(,@(cdr t)
+                  ,(list (list-ref t 1) (list-ref t 2))
+                  ,(list (list-ref t 4) (list-ref t 3)))]
+        [fun funs])
     (apply test expect fun (car t)))
   (for ([fun funs])
     (arity-test fun 2 2)