SRFI-1: Rewrite drop-right!', drop-while', `reduce', etc. in Scheme.

This partially reverts commit e9508fbb7d
(May 3 2005).

* module/srfi/srfi-1.scm (take!, drop-right!, reduce, reduce-right,
  take-while, take-while!, drop-while, span, span!, lset-adjoin): New
  procedures.

* srfi/srfi-1.c (scm_srfi1_drop_right_x, scm_srfi1_drop_while,
  scm_srfi1_lset_adjoin, scm_srfi1_reduce, scm_srfi1_reduce_right,
  scm_srfi1_span, scm_srfi1_span_x, scm_srfi1_take_x,
  scm_srfi1_take_while, scm_srfi1_take_while_x): Rewrite as
  proxies to the corresponding Scheme procedures.

* benchmark-suite/benchmarks/srfi-1.bm ("drop-while"): New benchmark
  prefix.

module/srfi/srfi-1.scm

@@ -350,6 +350,30 @@ end-of-list checking in contexts where dotted lists are allowed."
 (define take list-head)
 (define drop list-tail)
 
+(define (take! lst i)
+  "Linear-update variant of `take'."
+  (if (= i 0)
+      '()
+      (let ((tail (drop lst (- i 1))))
+        (set-cdr! tail '())
+        lst)))
+
+(define (drop-right! lst i)
+  "Linear-update variant of `drop-right'."
+  (let ((tail (drop lst i)))
+    (if (null? tail)
+        '()
+        (let loop ((prev lst)
+                   (tail (cdr tail)))
+          (if (null? tail)
+              (if (pair? prev)
+                  (begin
+                    (set-cdr! prev '())
+                    lst)
+                  lst)
+              (loop (cdr prev)
+                    (cdr tail)))))))
+
 (define (last pair)
   "Return the last element of the non-empty, finite list PAIR."
   (car (last-pair pair)))
@@ -441,6 +465,24 @@ that result.  See the manual for details."
         lis
         (uf (g seed) (cons (f seed) lis)))))
 
+(define (reduce f ridentity lst)
+  "`reduce' is a variant of `fold', where the first call to F is on two
+elements from LST, rather than one element and a given initial value.
+If LST is empty, RIDENTITY is returned.  If LST has just one element
+then that's the return value."
+  (if (null? lst)
+      ridentity
+      (fold f (car lst) (cdr lst))))
+
+(define (reduce-right f ridentity lst)
+  "`reduce-right' is a variant of `fold-right', where the first call to
+F is on two elements from LST, rather than one element and a given
+initial value.  If LST is empty, RIDENTITY is returned.  If LST
+has just one element then that's the return value."
+  (if (null? lst)
+      ridentity
+      (fold-right f (last lst) (drop-right lst 1))))
+
 
 ;; Internal helper procedure.  Map `f' over the single list `ls'.
 ;;
@@ -470,8 +512,72 @@ that result.  See the manual for details."
 	  (apply f l)
 	  (lp (map1 cdr l)))))))
 
+
 ;;; Searching
 
+(define (take-while pred ls)
+  "Return a new list which is the longest initial prefix of LS whose
+elements all satisfy the predicate PRED."
+  (cond ((null? ls) '())
+        ((not (pred (car ls))) '())
+        (else
+         (let ((result (list (car ls))))
+           (let lp ((ls (cdr ls)) (p result))
+             (cond ((null? ls) result)
+                   ((not (pred (car ls))) result)
+                   (else
+                    (set-cdr! p (list (car ls)))
+                    (lp (cdr ls) (cdr p)))))))))
+
+(define (take-while! pred lst)
+  "Linear-update variant of `take-while'."
+  (let loop ((prev #f)
+             (rest lst))
+    (cond ((null? rest)
+           lst)
+          ((pred (car rest))
+           (loop rest (cdr rest)))
+          (else
+           (if (pair? prev)
+               (begin
+                 (set-cdr! prev '())
+                 lst)
+               '())))))
+
+(define (drop-while pred lst)
+  "Drop the longest initial prefix of LST whose elements all satisfy the
+predicate PRED."
+  (let loop ((lst lst))
+    (cond ((null? lst)
+           '())
+          ((pred (car lst))
+           (loop (cdr lst)))
+          (else lst))))
+
+(define (span pred lst)
+  "Return two values, the longest initial prefix of LST whose elements
+all satisfy the predicate PRED, and the remainder of LST."
+  (let lp ((lst lst) (rl '()))
+    (if (and (not (null? lst))
+             (pred (car lst)))
+        (lp (cdr lst) (cons (car lst) rl))
+        (values (reverse! rl) lst))))
+
+(define (span! pred list)
+  "Linear-update variant of `span'."
+  (let loop ((prev #f)
+             (rest list))
+    (cond ((null? rest)
+           (values list '()))
+          ((pred (car rest))
+           (loop rest (cdr rest)))
+          (else
+           (if (pair? prev)
+               (begin
+                 (set-cdr! prev '())
+                 (values list rest))
+               (values '() list))))))
+
 (define (break pred clist)
   "Return two values, the longest initial prefix of LST whose elements
 all fail the predicate PRED, and the remainder of LST."
@@ -587,6 +693,27 @@ CLIST1 ... CLISTN, that satisfies PRED."
 	       (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r))
 	       (lp (car r) (cdr r)))))))
 
+;; It's not quite clear if duplicates among the `rest' elements are meant to
+;; be cast out.  The spec says `=' is called as (= lstelem restelem),
+;; suggesting perhaps not, but the reference implementation shows the "list"
+;; at each stage as including those elements already added.  The latter
+;; corresponds to what's described for lset-union, so that's what's done.
+;;
+(define (lset-adjoin = list . rest)
+  "Add to LIST any of the elements of REST not already in the list.
+These elements are `cons'ed onto the start of LIST (so the return shares
+a common tail with LIST), but the order they're added is unspecified.
+
+The given `=' procedure is used for comparing elements, called
+as `(@var{=} listelem elem)', i.e., the second argument is one of the
+given REST parameters."
+  (let lp ((l rest) (acc list))
+    (if (null? l)
+        acc
+        (if (member (car l) acc (lambda (x y) (= y x)))
+            (lp (cdr l) acc)
+            (lp (cdr l) (cons (car l) acc))))))
+
 (define (lset-union = . rest)
   (let ((acc '()))
     (for-each (lambda (lst)