;;; srfi-1.scm --- List Library
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;; Some parts from the reference implementation, which is
+;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;;; this code as long as you do not remove this copyright notice or
+;;; hold me liable for its use.
+
;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
;;; Date: 2001-06-06
;; Load the compiled primitives from the shared library.
;;
-(load-extension "libguile-srfi-srfi-1-v-4" "scm_init_srfi_1")
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_srfi_1")
;;; Constructors
-;; internal helper, similar to (scsh utilities) check-arg.
-(define (check-arg-type pred arg caller)
- (if (pred arg)
- arg
- (scm-error 'wrong-type-arg caller
- "Wrong type argument: ~S" (list arg) '())))
+(define (xcons d a)
+ "Like `cons', but with interchanged arguments. Useful mostly when passed to
+higher-order procedures."
+ (cons a d))
+
+(define (wrong-type-arg caller arg)
+ (scm-error 'wrong-type-arg (symbol->string caller)
+ "Wrong type argument: ~S" (list arg) '()))
+
+(define-syntax-rule (check-arg pred arg caller)
+ (if (not (pred arg))
+ (wrong-type-arg 'caller 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)))
-
+(define (list-tabulate n init-proc)
+ "Return an N-element list, where each list element is produced by applying the
+procedure INIT-PROC to the corresponding list index. The order in which
+INIT-PROC is applied to the indices is not specified."
+ (check-arg non-negative-integer? n list-tabulate)
+ (let lp ((n n) (acc '()))
+ (if (<= n 0)
+ acc
+ (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
(define (circular-list elt1 . elts)
(set! elts (cons elt1 elts))
elts)
(define* (iota count #:optional (start 0) (step 1))
- (check-arg-type non-negative-integer? count "iota")
+ (check-arg non-negative-integer? count iota)
(let lp ((n 0) (acc '()))
(if (= n count)
(reverse! acc)
(else
(error "not a proper list in null-list?"))))
+(define (not-pair? x)
+ "Return #t if X is not a pair, #f otherwise.
+
+This is shorthand notation `(not (pair? X))' and is supposed to be used for
+end-of-list checking in contexts where dotted lists are allowed."
+ (not (pair? x)))
+
(define (list= elt= . rest)
(define (lists-equal a b)
(let lp ((a a) (b b))
(else
(and (elt= (car a) (car b))
(lp (cdr a) (cdr b)))))))
+
+ (check-arg procedure? elt= list=)
(or (null? rest)
(let lp ((lists rest))
(or (null? (cdr lists))
(define second cadr)
(define third caddr)
(define fourth cadddr)
+(define (fifth x) (car (cddddr x)))
+(define (sixth x) (cadr (cddddr x)))
+(define (seventh x) (caddr (cddddr x)))
+(define (eighth x) (cadddr (cddddr x)))
+(define (ninth x) (car (cddddr (cddddr x))))
+(define (tenth x) (cadr (cddddr (cddddr x))))
+
+(define (car+cdr x)
+ "Return two values, the `car' and the `cdr' of PAIR."
+ (values (car x) (cdr x)))
(define take list-head)
(define drop list-tail)
+;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list,
+;;; off by K, then chasing down the list until the lead pointer falls off
+;;; the end. Note that they diverge for circular lists.
+
+(define (take-right lis k)
+ (let lp ((lag lis) (lead (drop lis k)))
+ (if (pair? lead)
+ (lp (cdr lag) (cdr lead))
+ lag)))
+
+(define (drop-right lis k)
+ (let recur ((lag lis) (lead (drop lis k)))
+ (if (pair? lead)
+ (cons (car lag) (recur (cdr lag) (cdr lead)))
+ '())))
+
+(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 (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)))
+
;;; Miscelleneous: length, append, concatenate, reverse, zip & count
(define (zip clist1 . rest)
(let lp ((l (cons clist1 rest)) (acc '()))
(if (any null? l)
(reverse! acc)
- (lp (map1 cdr l) (cons (map1 car l) acc)))))
+ (lp (map cdr l) (cons (map car l) acc)))))
(define (unzip1 l)
- (map1 first l))
+ (map first l))
(define (unzip2 l)
- (values (map1 first l) (map1 second l)))
+ (values (map first l) (map second l)))
(define (unzip3 l)
- (values (map1 first l) (map1 second l) (map1 third l)))
+ (values (map first l) (map second l) (map third l)))
(define (unzip4 l)
- (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)))
+ (values (map first l) (map second l) (map third l) (map fourth l)))
(define (unzip5 l)
- (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)
- (map1 fifth l)))
+ (values (map first l) (map second l) (map third l) (map fourth l)
+ (map fifth l)))
;;; Fold, unfold & map
+(define (fold kons knil list1 . rest)
+ "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
+that result. See the manual for details."
+ (check-arg procedure? kons fold)
+ (if (null? rest)
+ (let f ((knil knil) (list1 list1))
+ (if (null? list1)
+ knil
+ (f (kons (car list1) knil) (cdr list1))))
+ (let f ((knil knil) (lists (cons list1 rest)))
+ (if (any null? lists)
+ knil
+ (let ((cars (map car lists))
+ (cdrs (map cdr lists)))
+ (f (apply kons (append! cars (list knil))) cdrs))))))
+
(define (fold-right kons knil clist1 . rest)
+ (check-arg procedure? kons fold-right)
(if (null? rest)
- (let f ((list1 clist1))
- (if (null? list1)
- knil
- (kons (car list1) (f (cdr list1)))))
- (let f ((lists (cons clist1 rest)))
- (if (any null? lists)
- knil
- (apply kons (append! (map1 car lists) (list (f (map1 cdr lists)))))))))
+ (let loop ((lst (reverse clist1))
+ (result knil))
+ (if (null? lst)
+ result
+ (loop (cdr lst)
+ (kons (car lst) result))))
+ (let loop ((lists (map reverse (cons clist1 rest)))
+ (result knil))
+ (if (any1 null? lists)
+ result
+ (loop (map cdr lists)
+ (apply kons (append! (map car lists) (list result))))))))
(define (pair-fold kons knil clist1 . rest)
+ (check-arg procedure? kons pair-fold)
(if (null? rest)
(let f ((knil knil) (list1 clist1))
(if (null? list1)
(let f ((knil knil) (lists (cons clist1 rest)))
(if (any null? lists)
knil
- (let ((tails (map1 cdr lists)))
+ (let ((tails (map cdr lists)))
(f (apply kons (append! lists (list knil))) tails))))))
(define (pair-fold-right kons knil clist1 . rest)
+ (check-arg procedure? kons pair-fold-right)
(if (null? rest)
(let f ((list1 clist1))
(if (null? list1)
(let f ((lists (cons clist1 rest)))
(if (any null? lists)
knil
- (apply kons (append! lists (list (f (map1 cdr lists)))))))))
+ (apply kons (append! lists (list (f (map cdr lists)))))))))
(define* (unfold p f g seed #:optional (tail-gen (lambda (x) '())))
- (let uf ((seed seed))
+ (define (reverse+tail lst seed)
+ (let loop ((lst lst)
+ (result (tail-gen seed)))
+ (if (null? lst)
+ result
+ (loop (cdr lst)
+ (cons (car lst) result)))))
+
+ (check-arg procedure? p unfold)
+ (check-arg procedure? f unfold)
+ (check-arg procedure? g unfold)
+ (check-arg procedure? tail-gen unfold)
+ (let loop ((seed seed)
+ (result '()))
(if (p seed)
- (tail-gen seed)
- (cons (f seed)
- (uf (g seed))))))
+ (reverse+tail result seed)
+ (loop (g seed)
+ (cons (f seed) result)))))
(define* (unfold-right p f g seed #:optional (tail '()))
+ (check-arg procedure? p unfold-right)
+ (check-arg procedure? f unfold-right)
+ (check-arg procedure? g unfold-right)
(let uf ((seed seed) (lis tail))
(if (p seed)
lis
(uf (g seed) (cons (f seed) lis)))))
-
-;; Internal helper procedure. Map `f' over the single list `ls'.
-;;
-(define map1 map)
+(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."
+ (check-arg procedure? f reduce)
+ (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."
+ (check-arg procedure? f reduce)
+ (if (null? lst)
+ ridentity
+ (fold-right f (last lst) (drop-right lst 1))))
+
+(define map
+ (case-lambda
+ ((f l)
+ (check-arg procedure? f map)
+ (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
+ (if (pair? hare)
+ (if move?
+ (if (eq? tortoise hare)
+ (scm-error 'wrong-type-arg "map" "Circular list: ~S"
+ (list l) #f)
+ (map1 (cdr hare) (cdr tortoise) #f
+ (cons (f (car hare)) out)))
+ (map1 (cdr hare) tortoise #t
+ (cons (f (car hare)) out)))
+ (if (null? hare)
+ (reverse! out)
+ (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+ (list l) #f)))))
+
+ ((f l1 . rest)
+ (check-arg procedure? f map)
+ (let ((len (fold (lambda (ls len)
+ (let ((ls-len (length+ ls)))
+ (if len
+ (if ls-len (min ls-len len) len)
+ ls-len)))
+ (length+ l1)
+ rest)))
+ (if (not len)
+ (scm-error 'wrong-type-arg "map"
+ "Args do not contain a proper (finite) list: ~S"
+ (list (cons l1 rest)) #f))
+ (let mapn ((l1 l1) (rest rest) (len len) (out '()))
+ (if (zero? len)
+ (reverse! out)
+ (mapn (cdr l1) (map cdr rest) (1- len)
+ (cons (apply f (car l1) (map car rest)) out))))))))
+
+(define map-in-order map)
+
+(define for-each
+ (case-lambda
+ ((f l)
+ (check-arg procedure? f for-each)
+ (let for-each1 ((hare l) (tortoise l) (move? #f))
+ (if (pair? hare)
+ (if move?
+ (if (eq? tortoise hare)
+ (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
+ (list l) #f)
+ (begin
+ (f (car hare))
+ (for-each1 (cdr hare) (cdr tortoise) #f)))
+ (begin
+ (f (car hare))
+ (for-each1 (cdr hare) tortoise #t)))
+
+ (if (not (null? hare))
+ (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
+ (list l) #f)))))
+
+ ((f l1 . rest)
+ (check-arg procedure? f for-each)
+ (let ((len (fold (lambda (ls len)
+ (let ((ls-len (length+ ls)))
+ (if len
+ (if ls-len (min ls-len len) len)
+ ls-len)))
+ (length+ l1)
+ rest)))
+ (if (not len)
+ (scm-error 'wrong-type-arg "for-each"
+ "Args do not contain a proper (finite) list: ~S"
+ (list (cons l1 rest)) #f))
+ (let for-eachn ((l1 l1) (rest rest) (len len))
+ (if (> len 0)
+ (begin
+ (apply f (car l1) (map car rest))
+ (for-eachn (cdr l1) (map cdr rest) (1- len)))))))))
(define (append-map f clist1 . rest)
(concatenate (apply map f clist1 rest)))
;; OPTIMIZE-ME: Re-use cons cells of list1
(define map! map)
+(define (filter-map proc list1 . rest)
+ "Apply PROC to the elements of LIST1... and return a list of the
+results as per SRFI-1 `map', except that any #f results are omitted from
+the list returned."
+ (check-arg procedure? proc filter-map)
+ (if (null? rest)
+ (let lp ((l list1)
+ (rl '()))
+ (if (null? l)
+ (reverse! rl)
+ (let ((res (proc (car l))))
+ (if res
+ (lp (cdr l) (cons res rl))
+ (lp (cdr l) rl)))))
+ (let lp ((l (cons list1 rest))
+ (rl '()))
+ (if (any1 null? l)
+ (reverse! rl)
+ (let ((res (apply proc (map car l))))
+ (if res
+ (lp (map cdr l) (cons res rl))
+ (lp (map cdr l) rl)))))))
+
(define (pair-for-each f clist1 . rest)
+ (check-arg procedure? f pair-for-each)
(if (null? rest)
(let lp ((l clist1))
(if (null? l)
(if #f #f)
(begin
(apply f l)
- (lp (map1 cdr l)))))))
+ (lp (map cdr l)))))))
+\f
;;; 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."
+ (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? (map1 cdr lists))
- (apply pred (map1 car lists)))
+ ((any1 null? (map cdr lists))
+ (apply pred (map car lists)))
(else
- (or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
+ (or (apply pred (map car lists)) (lp (map cdr lists))))))))
(define (any1 pred ls)
(let lp ((ls ls))
(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? (map1 cdr lists))
- (apply pred (map1 car lists)))
+ ((any1 null? (map cdr lists))
+ (apply pred (map car lists)))
(else
- (and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
+ (and (apply pred (map car lists)) (lp (map cdr lists))))))))
(define (every1 pred ls)
(let lp ((ls 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)
(define* (alist-delete! key alist #:optional (k= equal?))
(alist-delete key alist k=)) ; XXX:optimize
+;;; Delete / assoc / member
+
+(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)))))))
+ #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)))
(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)
- (let ((acc '()))
- (for-each (lambda (lst)
- (if (null? acc)
- (set! acc lst)
- (for-each (lambda (elem)
- (if (not (member elem acc
- (lambda (x y) (= y x))))
- (set! acc (cons elem acc))))
- lst)))
- rest)
- acc))
+ ;; 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)
(lp (cdr l) acc)))))
(define (lset-difference = list1 . rest)
+ (check-arg procedure? = lset-difference)
(if (null? rest)
list1
(let lp ((l list1) (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)
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))
(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
HCoop / bpt / guile.git / blobdiff