(drop-right!, drop-while,

lset-adjoin, reduce, reduce-right, span, span!, take!, take-while,
take-while!): Rewrite in C.

diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm
index 7bbf2cb..24b0e0d 100644 (file)
--- a/srfi/srfi-1.scm
+++ b/srfi/srfi-1.scm
@@ -341,31 +341,6 @@
 (define take list-head)
 (define drop list-tail)
 
-(define (take! x i)
-  (if (<= i 0)
-    '()
-    (let lp ((n (- i 1)) (l x))
-      (if (<= n 0)
-       (begin
-         (set-cdr! l '())
-         x)
-       (lp (- n 1) (cdr l))))))
-
-(define (drop-right! flist i)
-  (if (<= i 0)
-    flist
-    (let lp ((n (+ i 1)) (l flist))
-      (if (<= n 0)
-       (let lp0 ((s flist) (l l))
-         (if (null? l)
-           (begin
-             (set-cdr! s '())
-             flist)
-           (lp0 (cdr s) (cdr l))))
-       (if (null? l)
-         '()
-         (lp (- n 1) (cdr l)))))))
-
 (define (last pair)
   (car (last-pair pair)))
 
@@ -476,16 +451,6 @@
          lis
          (uf (g seed) (cons (f seed) lis))))))
 
-(define (reduce f ridentity lst)
-  (if (null? lst)
-      ridentity
-      (fold f (car lst) (cdr lst))))
-
-(define (reduce-right f ridentity lst)
-  (if (null? lst)
-      ridentity
-      (fold-right f (last lst) (drop-right lst 1))))
-
 
 ;; Internal helper procedure.  Map `f' over the single list `ls'.
 ;;
@@ -517,38 +482,6 @@
 
 ;;; Searching
 
-(define (take-while pred ls)
-  (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 clist)
-  (take-while pred clist))             ; XXX:optimize
-
-(define (drop-while pred clist)
-  (if (null? clist)
-    '()
-    (if (pred (car clist))
-      (drop-while pred (cdr clist))
-      clist)))
-
-(define (span pred clist)
-  (let lp ((clist clist) (rl '()))
-    (if (and (not (null? clist))
-            (pred (car clist)))
-       (lp (cdr clist) (cons (car clist) rl))
-       (values (reverse! rl) clist))))
-
-(define (span! pred list)
-  (span pred list))                    ; XXX:optimize
-
 (define (break pred clist)
   (let lp ((clist clist) (rl '()))
     (if (or (null? clist)
@@ -650,20 +583,6 @@
               (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)
-  (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)