;;; srfi-1.scm --- List Library
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010 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 as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; Constructors
+(define (xcons d a)
+ "Like `cons', but with interchanged arguments. Useful mostly when passed to
+higher-order procedures."
+ (cons a d))
+
;; internal helper, similar to (scsh utilities) check-arg.
(define (check-arg-type pred arg caller)
(if (pred 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-type 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))
(set-cdr! (last-pair elts) elts)
elts)
-(define (iota count . rest)
+(define* (iota count #:optional (start 0) (step 1))
(check-arg-type non-negative-integer? count "iota")
- (let ((start (if (pair? rest) (car rest) 0))
- (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1)))
- (let lp ((n 0) (acc '()))
- (if (= n count)
+ (let lp ((n 0) (acc '()))
+ (if (= n count)
(reverse! acc)
- (lp (+ n 1) (cons (+ start (* n step)) acc))))))
+ (lp (+ n 1) (cons (+ start (* n step)) acc)))))
;;; Predicates
(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))
(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)
+(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)
;;; 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."
+ (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 (map1 car lists))
+ (cdrs (map1 cdr lists)))
+ (f (apply kons (append! cars (list knil))) cdrs))))))
+
(define (fold-right kons knil clist1 . rest)
(if (null? rest)
(let f ((list1 clist1))
knil
(apply kons (append! lists (list (f (map1 cdr lists)))))))))
-(define (unfold p f g seed . rest)
- (let ((tail-gen (if (pair? rest)
- (if (pair? (cdr rest))
- (scm-error 'wrong-number-of-args
- "unfold" "too many arguments" '() '())
- (car rest))
- (lambda (x) '()))))
- (let uf ((seed seed))
- (if (p seed)
- (tail-gen seed)
- (cons (f seed)
- (uf (g seed)))))))
-
-(define (unfold-right p f g seed . rest)
- (let ((tail (if (pair? rest)
- (if (pair? (cdr rest))
- (scm-error 'wrong-number-of-args
- "unfold-right" "too many arguments" '()
- '())
- (car rest))
- '())))
- (let uf ((seed seed) (lis tail))
- (if (p seed)
- lis
- (uf (g seed) (cons (f seed) lis))))))
+(define* (unfold p f g seed #:optional (tail-gen (lambda (x) '())))
+ (let uf ((seed seed))
+ (if (p seed)
+ (tail-gen seed)
+ (cons (f seed)
+ (uf (g seed))))))
+
+(define* (unfold-right p f g seed #:optional (tail '()))
+ (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'.
;;; Searching
+(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."
+ (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'."
+ (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)
(if (null? lists)
(any1 pred 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."
+ (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 (map1 car lists)) i)
+ (else
+ (lp (map1 cdr lists) (+ i 1)))))))
+
;;; Association lists
(define alist-cons acons)
-(define (alist-delete key alist . rest)
- (let ((k= (if (pair? rest) (car rest) equal?)))
- (let lp ((a alist) (rl '()))
- (if (null? a)
+(define* (alist-delete key alist #:optional (k= equal?))
+ (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)))))))
+ (lp (cdr a) rl)
+ (lp (cdr a) (cons (car a) rl))))))
-(define (alist-delete! key alist . rest)
- (let ((k= (if (pair? rest) (car rest) equal?)))
- (alist-delete key alist k=))) ; XXX:optimize
+(define* (alist-delete! key alist #:optional (k= equal?))
+ (alist-delete key alist k=)) ; XXX:optimize
;;; Set operations on lists
HCoop / bpt / guile.git / blobdiff