-;;;; srfi-1.scm --- SRFI-1 procedures for Guile
-;;;;
-;;;; Copyright (C) 2001 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU General Public License as
-;;;; published by the Free Software Foundation; either version 2, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
-;;;;
-;;;; As a special exception, the Free Software Foundation gives permission
-;;;; for additional uses of the text contained in its release of GUILE.
-;;;;
-;;;; The exception is that, if you link the GUILE library with other files
-;;;; to produce an executable, this does not by itself cause the
-;;;; resulting executable to be covered by the GNU General Public License.
-;;;; Your use of that executable is in no way restricted on account of
-;;;; linking the GUILE library code into it.
-;;;;
-;;;; This exception does not however invalidate any other reasons why
-;;;; the executable file might be covered by the GNU General Public License.
-;;;;
-;;;; This exception applies only to the code released by the
-;;;; Free Software Foundation under the name GUILE. If you copy
-;;;; code from other Free Software Foundation releases into a copy of
-;;;; GUILE, as the General Public License permits, the exception does
-;;;; not apply to the code that you add in this way. To avoid misleading
-;;;; anyone as to the status of such modified files, you must delete
-;;;; this exception notice from them.
-;;;;
-;;;; If you write modifications of your own for GUILE, it is your choice
-;;;; whether to permit this exception to apply to your modifications.
-;;;; If you do not wish that, delete this exception notice.
+;;; srfi-1.scm --- List Library
+
+;; Copyright (C) 2001, 2002, 2003, 2004 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.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
;;; Date: 2001-06-06
;;; Commentary:
-;;; This is an implementation of SRFI-1 (List Library)
-;;;
-;;; All procedures defined in SRFI-1, which are not already defined in
-;;; the Guile core library, are exported. The procedures in this
-;;; implementation work, but they have not been tuned for speed or
-;;; memory usage.
-;;;
+;; This is an implementation of SRFI-1 (List Library).
+;;
+;; All procedures defined in SRFI-1, which are not already defined in
+;; the Guile core library, are exported. The procedures in this
+;; implementation work, but they have not been tuned for speed or
+;; memory usage.
+;;
+;; This module is fully documented in the Guile Reference Manual.
;;; Code:
(define-module (srfi srfi-1)
:use-module (ice-9 session)
- :use-module (ice-9 receive))
-
-(export
+ :use-module (ice-9 receive)
+ :export (
;;; Constructors
;; cons <= in the core
;; list <= in the core
;; cons* <= in the core
;; make-list <= in the core
list-tabulate
- ;; list-copy <= in the core
+ list-copy
circular-list
- iota
+ ;; iota ; Extended.
;;; Predicates
proper-list?
reduce-right
unfold
unfold-right
- ;; map <= in the core
- ;; for-each <= in the core
+ ;; map ; Extended.
+ ;; for-each ; Extended.
append-map
append-map!
map!
- ;; map-in-order <= in the core
+ ;; map-in-order ; Extended.
pair-for-each
filter-map
;;; Filtering & partitioning
- filter
+ ;; filter <= in the core
partition
remove
- filter!
+ ;; filter! <= in the core
partition!
remove!
break!
any
every
- list-index
- member ; Extended.
+ ;; list-index ; Extended.
+ ;; member ; Extended.
;; memq <= in the core
;; memv <= in the core
;;; Deletion
- delete ; Extended.
- delete!
+ ;; delete ; Extended.
+ ;; delete! ; Extended.
delete-duplicates
delete-duplicates!
;;; Association lists
- assoc ; Extended.
+ ;; assoc ; Extended.
;; assq <= in the core
;; assv <= in the core
alist-cons
;; set-car! <= in the core
;; set-cdr! <= in the core
)
+ :re-export (cons list cons* make-list pair? null?
+ car cdr caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ list-ref last-pair length append append! reverse reverse!
+ filter filter! memq memv assq assv set-car! set-cdr!)
+ :replace (iota map for-each map-in-order list-copy list-index member
+ delete delete! assoc)
+ )
(cond-expand-provide (current-module) '(srfi-1))
+;; Load the compiled primitives from the shared library.
+;;
+(load-extension "libguile-srfi-srfi-1" "scm_init_srfi_1")
+
+
;;; Constructors
(define (xcons d a)
(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) '())))
+
+;; 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)
+ (check-arg-type non-negative-integer? n "list-tabulate")
(let lp ((n n) (acc '()))
- (if (zero? n)
+ (if (<= n 0)
acc
(lp (- n 1) (cons (init-proc (- n 1)) acc)))))
-(define (circular-list elt1 . rest)
- (let ((start (cons elt1 '())))
- (let lp ((r rest) (p start))
- (if (null? r)
- (begin
- (set-cdr! p start)
- start)
- (begin
- (set-cdr! p (cons (car r) '()))
- (lp (cdr r) (cdr p)))))))
+(define (circular-list elt1 . elts)
+ (set! elts (cons elt1 elts))
+ (set-cdr! (last-pair elts) elts)
+ elts)
(define (iota count . rest)
+ (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 '()))
((not-pair? hare) #t)
(else
(let ((hare (cdr hare)))
- (cond
+ (cond
((null? hare) #f)
((not-pair? hare) #t)
((eq? hare tortoise) #f)
(define (null-list? x)
(cond
- ((proper-list? x)
+ ((proper-list? x)
(null? x))
((circular-list? x)
#f)
(define (car+cdr x) (values (car x) (cdr x)))
-(define (take x i)
- (let lp ((n i) (l x) (acc '()))
- (if (zero? n)
- (reverse! acc)
- (lp (- n 1) (cdr l) (cons (car l) acc)))))
-(define (drop x i)
- (let lp ((n i) (l x))
- (if (zero? n)
- l
- (lp (- n 1) (cdr l)))))
+(define take list-head)
+(define drop list-tail)
+
(define (take-right flist i)
(let lp ((n i) (l flist))
- (if (zero? n)
+ (if (<= n 0)
(let lp0 ((s flist) (l l))
(if (null? l)
s
(lp0 (cdr s) (cdr l))))
(lp (- n 1) (cdr l)))))
-
+
(define (drop-right flist i)
(let lp ((n i) (l flist))
- (if (zero? n)
+ (if (<= n 0)
(let lp0 ((s flist) (l l) (acc '()))
(if (null? l)
(reverse! acc)
(lp (- n 1) (cdr l)))))
(define (take! x i)
- (if (zero? i)
+ (if (<= i 0)
'()
(let lp ((n (- i 1)) (l x))
- (if (zero? n)
- (begin
+ (if (<= n 0)
+ (begin
(set-cdr! l '())
x)
(lp (- n 1) (cdr l))))))
(define (drop-right! flist i)
- (if (zero? i)
+ (if (<= i 0)
flist
(let lp ((n (+ i 1)) (l flist))
- (if (zero? n)
+ (if (<= n 0)
(let lp0 ((s flist) (l l))
(if (null? l)
(begin
(define (split-at x i)
(let lp ((l x) (n i) (acc '()))
- (if (zero? n)
+ (if (<= n 0)
(values (reverse! acc) l)
(lp (cdr l) (- n 1) (cons (car l) acc)))))
(define (split-at! x i)
- (if (zero? i)
+ (if (<= i 0)
(values '() x)
(let lp ((l x) (n (- i 1)))
- (if (zero? n)
+ (if (<= n 0)
(let ((tmp (cdr l)))
(set-cdr! l '())
(values x tmp))
;;; Miscelleneous: length, append, concatenate, reverse, zip & count
-(define (length+ clist)
- (if (null? clist)
- 0
- (let lp ((hare (cdr clist)) (tortoise clist) (l 1))
- (if (null? hare)
- l
- (let ((hare (cdr hare)))
- (if (null? hare)
- (+ l 1)
- (if (eq? hare tortoise)
- #f
- (lp (cdr hare) (cdr tortoise) (+ l 2)))))))))
-
-(define (concatenate l-o-l)
- (let lp ((l l-o-l) (acc '()))
- (if (null? l)
- (reverse! acc)
- (let lp0 ((ll (car l)) (acc acc))
- (if (null? ll)
- (lp (cdr l) acc)
- (lp0 (cdr ll) (cons (car ll) acc)))))))
-
-(define (concatenate! l-o-l)
- (let lp0 ((l-o-l l-o-l))
- (cond
- ((null? l-o-l)
- '())
- ((null? (car l-o-l))
- (lp0 (cdr l-o-l)))
- (else
- (let ((result (car l-o-l)) (tail (last-pair (car l-o-l))))
- (let lp ((l (cdr l-o-l)) (ntail tail))
- (if (null? l)
- result
- (begin
- (set-cdr! ntail (car l))
- (lp (cdr l) (last-pair ntail))))))))))
-
-
(define (append-reverse rev-head tail)
(let lp ((l rev-head) (acc tail))
(if (null? l)
(let lp ((l (cons clist1 rest)) (acc '()))
(if (any null? l)
(reverse! acc)
- (lp (map cdr l) (cons (map car l) acc)))))
-
+ (lp (map1 cdr l) (cons (map1 car l) acc)))))
+
(define (unzip1 l)
- (map first l))
+ (map1 first l))
(define (unzip2 l)
- (values (map first l) (map second l)))
+ (values (map1 first l) (map1 second l)))
(define (unzip3 l)
- (values (map first l) (map second l) (map third l)))
+ (values (map1 first l) (map1 second l) (map1 third l)))
(define (unzip4 l)
- (values (map first l) (map second l) (map third l) (map fourth l)))
+ (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)))
(define (unzip5 l)
- (values (map first l) (map second l) (map third l) (map fourth l)
- (map fifth l)))
-
-(define (count pred clist1 . rest)
- (if (null? rest)
- (count1 pred clist1)
- (let lp ((lists (cons clist1 rest)))
- (cond ((any1 null? lists)
- 0)
- (else
- (if (apply pred (map car lists))
- (+ 1 (lp (map cdr lists)))
- (lp (map cdr lists))))))))
-
-(define (count1 pred clist)
- (if (null? clist)
- 0
- (if (pred (car clist))
- (+ 1 (count1 pred (cdr clist)))
- (count1 pred (cdr clist)))))
+ (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)
+ (map1 fifth l)))
;;; Fold, unfold & map
(let f ((knil knil) (lists (cons list1 rest)))
(if (any null? lists)
knil
- (let ((cars (map car lists))
- (cdrs (map cdr lists)))
+ (let ((cars (map1 car lists))
+ (cdrs (map1 cdr lists)))
(f (apply kons (append! cars (list knil))) cdrs))))))
(define (fold-right kons knil clist1 . rest)
(let f ((lists (cons clist1 rest)))
(if (any null? lists)
knil
- (apply kons (append! (map car lists) (list (f (map cdr lists)))))))))
+ (apply kons (append! (map1 car lists) (list (f (map1 cdr lists)))))))))
(define (pair-fold kons knil clist1 . rest)
(if (null? rest)
(let f ((knil knil) (lists (cons clist1 rest)))
(if (any null? lists)
knil
- (let ((tails (map cdr lists)))
+ (let ((tails (map1 cdr lists)))
(f (apply kons (append! lists (list knil))) tails))))))
(let f ((lists (cons clist1 rest)))
(if (any null? lists)
knil
- (apply kons (append! lists (list (f (map cdr lists)))))))))
+ (apply kons (append! lists (list (f (map1 cdr lists)))))))))
(define (unfold p f g seed . rest)
(let ((tail-gen (if (pair? rest)
(define (reduce-right f ridentity lst)
(fold-right f ridentity lst))
+
+;; Internal helper procedure. Map `f' over the single list `ls'.
+;;
+(define map1 map)
+
(define (append-map f clist1 . rest)
(if (null? rest)
(let lp ((l clist1))
(let lp ((l (cons clist1 rest)))
(if (any1 null? l)
'()
- (append (apply f (map car l)) (lp (map cdr l)))))))
+ (append (apply f (map1 car l)) (lp (map1 cdr l)))))))
+
(define (append-map! f clist1 . rest)
(if (null? rest)
(let lp ((l (cons clist1 rest)))
(if (any1 null? l)
'()
- (append! (apply f (map car l)) (lp (map cdr l)))))))
+ (append! (apply f (map1 car l)) (lp (map1 cdr l)))))))
-(define (map! f list1 . rest)
- (if (null? rest)
- (let lp ((l list1))
- (if (null? l)
- '()
- (begin
- (set-car! l (f (car l)))
- (set-cdr! l (lp (cdr l)))
- l)))
- (let lp ((l (cons list1 rest)) (res list1))
- (if (any1 null? l)
- '()
- (begin
- (set-car! res (apply f (map car l)))
- (set-cdr! res (lp (map cdr l) (cdr res)))
- res)))))
+;; OPTIMIZE-ME: Re-use cons cells of list1
+(define map! map)
(define (pair-for-each f clist1 . rest)
(if (null? rest)
(if #f #f)
(begin
(apply f l)
- (lp (map cdr l)))))))
+ (lp (map1 cdr l)))))))
(define (filter-map f clist1 . rest)
(if (null? rest)
(let lp ((l (cons clist1 rest)))
(if (any1 null? l)
'()
- (let ((res (apply f (map car l))))
+ (let ((res (apply f (map1 car l))))
(if res
- (cons res (lp (map cdr l)))
- (lp (map cdr l))))))))
+ (cons res (lp (map1 cdr l)))
+ (lp (map1 cdr l))))))))
;;; Filtering & partitioning
-(define (filter pred list)
- (if (null? list)
- '()
- (if (pred (car list))
- (cons (car list) (filter pred (cdr list)))
- (filter pred (cdr list)))))
-
-(define (partition pred list)
- (if (null? list)
- (values '() '())
- (if (pred (car list))
- (receive (in out) (partition pred (cdr list))
- (values (cons (car list) in) out))
- (receive (in out) (partition pred (cdr list))
- (values in (cons (car list) out))))))
-
(define (remove pred list)
- (if (null? list)
- '()
- (if (pred (car list))
- (remove pred (cdr list))
- (cons (car list) (remove pred (cdr list))))))
-
-(define (filter! pred list)
- (filter pred list)) ; XXX:optimize
+ (filter (lambda (x) (not (pred x))) list))
(define (partition! pred list)
(partition pred list)) ; XXX:optimize
clist
(find-tail pred (cdr clist)))))
-(define (take-while pred clist)
- (if (null? clist)
- '()
- (if (pred (car clist))
- (cons (car clist) (take-while pred (cdr clist)))
- '())))
+(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
(let lp ((lists (cons ls lists)))
(cond ((any1 null? lists)
#f)
- ((any1 null? (map cdr lists))
- (apply pred (map car lists)))
+ ((any1 null? (map1 cdr lists))
+ (apply pred (map1 car lists)))
(else
- (or (apply pred (map car lists)) (lp (map cdr lists))))))))
+ (or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
(define (any1 pred ls)
(let lp ((ls ls))
(let lp ((lists (cons ls lists)))
(cond ((any1 null? lists)
#t)
- ((any1 null? (map cdr lists))
- (apply pred (map car lists)))
+ ((any1 null? (map1 cdr lists))
+ (apply pred (map1 car lists)))
(else
- (and (apply pred (map car lists)) (lp (map cdr lists))))))))
+ (and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
(define (every1 pred ls)
(let lp ((ls ls))
(let lp ((lists (cons clist1 rest)) (i 0))
(cond ((any1 null? lists)
#f)
- ((apply pred (map car lists)) i)
+ ((apply pred (map1 car lists)) i)
(else
- (lp (map cdr lists) (+ i 1)))))))
-
-(define (member x list . rest)
- (let ((l= (if (pair? rest) (car rest) equal?)))
- (let lp ((l list))
- (if (null? l)
- #f
- (if (l= x (car l))
- l
- (lp (cdr l)))))))
-
-;;; Deletion
-
-(define (delete x list . rest)
- (let ((l= (if (pair? rest) (car rest) equal?)))
- (let lp ((l list))
- (if (null? l)
- '()
- (if (l= (car l) x)
- (lp (cdr l))
- (cons (car l) (lp (cdr l))))))))
-
-(define (delete! x list . rest)
- (let ((l= (if (pair? rest) (car rest) equal?)))
- (delete x list l=))) ; XXX:optimize
-
-(define (delete-duplicates list . rest)
- (let ((l= (if (pair? rest) (car rest) equal?)))
- (let lp0 ((l1 list))
- (if (null? l1)
- '()
- (if (let lp1 ((l2 (cdr l1)))
- (if (null? l2)
- #f
- (if (l= (car l1) (car l2))
- #t
- (lp1 (cdr l2)))))
- (lp0 (cdr l1))
- (cons (car l1) (lp0 (cdr l1))))))))
-
-(define (delete-duplicates list . rest)
- (let ((l= (if (pair? rest) (car rest) equal?)))
- (let lp ((list list))
- (if (null? list)
- '()
- (cons (car list) (lp (delete (car list) (cdr list) l=)))))))
-
-(define (delete-duplicates! list . rest)
- (let ((l= (if (pair? rest) (car rest) equal?)))
- (delete-duplicates list l=))) ; XXX:optimize
+ (lp (map1 cdr lists) (+ i 1)))))))
;;; Association lists
-(define (assoc key alist . rest)
- (let ((k= (if (pair? rest) (car rest) equal?)))
- (let lp ((a alist))
- (if (null? a)
- #f
- (if (k= key (caar a))
- (car a)
- (lp (cdr a)))))))
-
(define (alist-cons key datum alist)
(acons key datum alist))
(define (lset-diff+intersection! = list1 . rest)
(apply lset-diff+intersection = list1 rest)) ; XXX:optimize
+
+;;; srfi-1.scm ends here
HCoop / bpt / guile.git / blobdiff