;;; srfi-1.scm --- List Library
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010 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
higher-order procedures."
(cons a d))
-;; 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 (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)))
"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-type non-negative-integer? n "list-tabulate")
+ (check-arg non-negative-integer? n list-tabulate)
(let lp ((n n) (acc '()))
(if (<= n 0)
acc
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
(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 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)
(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)))
(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)
(let f ((knil knil) (lists (cons list1 rest)))
(if (any null? lists)
knil
- (let ((cars (map1 car lists))
- (cdrs (map1 cdr lists)))
+ (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
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))))
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))))
-
-;; Internal helper procedure. Map `f' over the single list `ls'.
-;;
-(define map1 map)
+(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
(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)
(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)
'())
(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)))
(define (span! pred list)
"Linear-update variant of `span'."
+ (check-arg procedure? pred span!)
(let loop ((prev #f)
(rest list))
(cond ((null? rest)
(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)))
(define (break! pred list)
"Linear-update variant of `break'."
+ (check-arg procedure? pred break!)
(let loop ((l list)
(prev #f))
(cond ((null? l)
(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))
(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)
(let lp ((lists (cons clist1 rest)) (i 0))
(cond ((any1 null? lists)
#f)
- ((apply pred (map1 car lists)) i)
+ ((apply pred (map car lists)) i)
(else
- (lp (map1 cdr lists) (+ i 1)))))))
+ (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)))
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))))))
+ ;; 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