d (not (null? lst))
         (let ((head (car lst)))
           (if (pred head)
               lst
               (loop (cdr lst)))))))

(define (take-while pred ls)
  "Return a new list which is the longest initial prefix of LS whose
elements all satisfy the predicate PRED."
  (check-arg procedure? pred take-while)
  (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'."
  (check-arg procedure? pred 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."
  (check-arg procedure? pred drop-while)
  (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."
  (check-arg procedure? pred span)
  (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'."
  (check-arg procedure? pred 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."
  (check-arg procedure? pred break)
  (let lp ((clist clist) (rl '()))
    (if (or (null? clist)
	    (pred (car clist)))
	(values (reverse! rl) clist)
	(lp (cdr clist) (cons (car clist) rl)))))

(define (break! pred list)
  "Linear-update variant of `break'."
  (check-arg procedure? pred break!)
  (let loop ((l    list)
             (prev #f))
    (cond ((null? l)
           (values list '()))
          ((pred (car l))
           (if (pair? prev)
               (begin
                 (set-cdr! prev '())
                 (values list l))
               (values '() list)))
          (else
           (loop (cdr l) l)))))

(define (any pred ls . lists)
  (check-arg procedure? pred any)
  (if (null? lists)
      (any1 pred ls)
      (let lp ((lists (cons ls lists)))
	(cond ((any1 null? lists)
	       #f)
	      ((any1 null? (map cdr lists))
	       (apply pred (map car lists)))
	      (else
	       (or (apply pred (map car lists)) (lp (map cdr lists))))))))

(define (any1 pred ls)
  (let lp ((ls ls))
    (cond ((null? ls)
	   #f)
	  ((null? (cdr ls))
	   (pred (car ls)))
	  (else
	   (or (pred (car ls)) (lp (cdr ls)))))))

(define (every pred ls . lists)
  (check-arg procedure? pred every)
  (if (null? lists)
      (every1 pred ls)
      (let lp ((lists (cons ls lists)))
	(cond ((any1 null? lists)
	       #t)
	      ((any1 null? (map cdr lists))
	       (apply pred (map car lists)))
	      (else
	       (and (apply pred (map car lists)) (lp (map cdr lists))))))))

(define (every1 pred ls)
  (let lp ((ls ls))
    (cond ((null? ls)
	   #t)
	  ((null? (cdr ls))
	   (pred (car ls)))
	  (else
	   (and (pred (car ls)) (lp (cdr ls)))))))

(define (list-index pred clist1 . rest)
  "Return the index of the first set of elements, one from each of
CLIST1 ... CLISTN, that satisfies PRED."
  (check-arg procedure? pred list-index)
  (if (null? rest)
    (let lp ((l clist1) (i 0))
      (if (null? l)
	#f
	(if (pred (car l))
	  i
	  (lp (cdr l) (+ i 1)))))
    (let lp ((lists (cons clist1 rest)) (i 0))
      (cond ((any1 null? lists)
	     #f)
	    ((apply pred (map car lists)) i)
	    (else
	     (lp (map cdr lists) (+ i 1)))))))

;;; Association lists

(define alist-cons acons)

(define (alist-copy alist)
  "Return a copy of ALIST, copying both the pairs comprising the list
and those making the associations."
  (let lp ((a  alist)
           (rl '()))
    (if (null? a)
        (reverse! rl)
        (lp (cdr a) (alist-cons (caar a) (cdar a) rl)))))

(define* (alist-delete key alist #:optional (k= equal?))
  (check-arg procedure? k= alist-delete)
  (let lp ((a alist) (rl '()))
    (if (null? a)
	(reverse! rl)
	(if (k= key (caar a))
            (lp (cdr a) rl)
            (lp (cdr a) (cons (car a) rl))))))

(define* (alist-delete! key alist #:optional (k= equal?))
  (alist-delete key alist k=))	; XXX:optimize

;;; Delete / assoc / member

(define* (assoc key alist #:optional (= equal?))
  "Behaves like @code{assq} but uses third argument @var{pred} for key
comparison.  If @var{pred} is not supplied, @code{equal?} is
used.  (Extended from R5RS.)"
  (cond
   ((eq? = eq?) (assq key alist))
   ((eq? = eqv?) (assv key alist))
   (else
    (check-arg procedure? = assoc)
    (let loop ((alist alist))
      (and (pair? alist)
           (let ((item (car alist)))
             (check-arg pair? item assoc)
             (if (= key (car item))
                 item
                 (loop (cdr alist)))))))))

(define* (member x ls #:optional (= equal?))
  (cond
   ;; This might be performance-sensitive, so punt on the check here,
   ;; relying on memq/memv to check that = is a procedure.
   ((eq? = eq?) (memq x ls))
   ((eq? = eqv?) (memv x ls))
   (else
    (check-arg procedure? = member)
    (find-tail (lambda (y) (= x y)) ls))))

;;; Set operations on lists

(define (lset<= = . rest)
  (check-arg procedure? = lset<=)
  (if (null? rest)
      #t
      (let lp ((f (car rest)) (r (cdr rest)))
        (or (null? r)
            (and (every (lambda (el) (member el (car r) =)) f)
                 (lp (car r) (cdr r)))))))

(define (lset= = . rest)
  (check-arg procedure? = lset<=)
  (if (null? rest)
    #t
    (let lp ((f (car rest)) (r (cdr rest)))
      (or (null? r)
	  (and (every (lambda (el) (member el (car r) =)) f)
	       (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."
  ;; If `=' is `eq?' or `eqv?', users won't be able to tell which arg is
  ;; first, so we can pass the raw procedure through to `member',
  ;; allowing `memq' / `memv' to be selected.
  (define pred
    (if (or (eq? = eq?) (eq? = eqv?))
        =
        (begin
          (check-arg procedure? = lset-adjoin)
          (lambda (x y) (= y x)))))

  (let lp ((ans list) (rest rest))
    (if (null? rest)
        ans
        (lp (if (member (car rest) ans pred)
                ans
                (cons (car rest) ans))
            (cdr rest)))))

(define (lset-union = . rest)
  ;; Likewise, allow memq / memv to be used if possible.
  (define pred
    (if (or (eq? = eq?) (eq? = eqv?))
        =
        (begin
          (check-arg procedure? = lset-union)
          (lambda (x y) (= y x)))))

  (fold (lambda (lis ans)		; Compute ANS + LIS.
          (cond ((null? lis) ans)	; Don't copy any lists
                ((null? ans) lis) 	; if we don't have to.
                ((eq? lis ans) ans)
                (else
                 (fold (lambda (elt ans)
                         (if (member elt ans pred)
                             ans
                             (cons elt ans)))
                       ans lis))))
        '()
        rest))

(define (lset-intersection = list1 . rest)
  (check-arg procedure? = lset-intersection)
  (let lp ((l list1) (acc '()))
    (if (null? l)
      (reverse! acc)
      (if (every (lambda (ll) (member (car l) ll =)) rest)
	(lp (cdr l) (cons (car l) acc))
	(lp (cdr l) acc)))))

(define (lset-difference = list1 . rest)
  (check-arg procedure? = lset-difference)
  (if (null? rest)
    list1
    (let lp ((l list1) (acc '()))
      (if (null? l)
	(reverse! acc)
	(if (any (lambda (ll) (member (car l) ll =)) rest)
	  (lp (cdr l) acc)
	  (lp (cdr l) (cons (car l) acc)))))))

;(define (fold kons knil list1 . rest)

(define (lset-xor = . rest)
  (check-arg procedure? = lset-xor)
  (fold (lambda (lst res)
	  (let lp ((l lst) (acc '()))
	    (if (null? l)
	      (let lp0 ((r res) (acc acc))
		(if (null? r)
		  (reverse! acc)
		  (if (member (car r) lst =)
		    (lp0 (cdr r) acc)
		    (lp0 (cdr r) (cons (car r) acc)))))
	      (if (member (car l) res =)
		(lp (cdr l) acc)
		(lp (cdr l) (cons (car l) acc))))))
	'()
	rest))

(define (lset-diff+intersection = list1 . rest)
  (check-arg procedure? = lset-diff+intersection)
  (let lp ((l list1) (accd '()) (acci '()))
    (if (null? l)
      (values (reverse! accd) (reverse! acci))
      (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
	(if appears
	  (lp (cdr l) accd (cons (car l) acci))
	  (lp (cdr l) (cons (car l) accd) acci))))))


(define (lset-union! = . rest)
  (check-arg procedure? = lset-union!)
  (apply lset-union = rest))		; XXX:optimize

(define (lset-intersection! = list1 . rest)
  (check-arg procedure? = lset-intersection!)
  (apply lset-intersection = list1 rest)) ; XXX:optimize

(define (lset-xor! = . rest)
  (check-arg procedure? = lset-xor!)
  (apply lset-xor = rest))		; XXX:optimize

(define (lset-diff+intersection! = list1 . rest)
  (check-arg procedure? = lset-diff+intersection!)
  (apply lset-diff+intersection = list1 rest)) ; XXX:optimize

;;; srfi-1.scm ends here