-;;;; 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 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 ; exported below
+ ;; iota ; Extended.
;;; Predicates
proper-list?
reduce-right
unfold
unfold-right
- ;; map ; exported below
- ;; for-each ; exported below
+ ;; map ; Extended.
+ ;; for-each ; Extended.
append-map
append-map!
map!
- ;; map-in-order ; exported below
+ ;; 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 ; exported below.
- ;; member ; exported below ; Extended.
+ ;; list-index ; Extended.
+ ;; member ; Extended.
;; memq <= in the core
;; memv <= in the core
;;; Deletion
-;; delete ; exported below ; Extended.
-;; delete! ; exported below
+ ;; delete ; Extended.
+ ;; delete! ; Extended.
delete-duplicates
delete-duplicates!
;;; Association lists
- ;; assoc ; exported below ; 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 (<= n 0)
acc
(lp (cdr r) (cdr p)))))))
(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 (<= n 0)
- (reverse! acc)
- (lp (- n 1) (cdr l) (cons (car l) acc)))))
-(define (drop x i)
- (let lp ((n i) (l x))
- (if (<= n 0)
- 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 (<= n 0)
s
(lp0 (cdr s) (cdr l))))
(lp (- n 1) (cdr l)))))
-
+
(define (drop-right flist i)
(let lp ((n i) (l flist))
(if (<= n 0)
'()
(let lp ((n (- i 1)) (l x))
(if (<= n 0)
- (begin
+ (begin
(set-cdr! l '())
x)
(lp (- n 1) (cdr l))))))
;;; 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)
(if (any null? l)
(reverse! acc)
(lp (map1 cdr l) (cons (map1 car l) acc)))))
-
+
(define (unzip1 l)
(map1 first l))
(lp (map1 cdr lists))))))))
(define (count1 pred clist)
- (if (null? clist)
- 0
- (if (pred (car clist))
- (+ 1 (count1 pred (cdr clist)))
- (count1 pred (cdr clist)))))
+ (let lp ((result 0) (rest clist))
+ (if (null? rest)
+ result
+ (if (pred (car rest))
+ (lp (+ 1 result) (cdr rest))
+ (lp result (cdr rest))))))
;;; Fold, unfold & map
;; Internal helper procedure. Map `f' over the single list `ls'.
;;
-(define (map1 f ls)
- (let lp ((l ls))
- (if (null? l)
- '()
- (cons (f (car l)) (lp (cdr l))))))
-
-;; This `map' is extended from the standard `map'. It allows argument
-;; lists of different length, so that the shortest list determines the
-;; number of elements processed.
-;;
-(define (map f list1 . rest)
- (if (null? rest)
- (map1 f list1)
- (let lp ((l (cons list1 rest)))
- (if (any1 null? l)
- '()
- (cons (apply f (map1 car l)) (lp (map1 cdr l)))))))
-
-;; extended to lists of unequal length.
-(define map-in-order map)
-
-;; This `for-each' is extended from the standard `for-each'. It
-;; allows argument lists of different length, so that the shortest
-;; list determines the number of elements processed.
-;;
-(define (for-each f list1 . rest)
- (if (null? rest)
- (let lp ((l list1))
- (if (null? l)
- (if #f #f) ; Return unspecified value.
- (begin
- (f (car l))
- (lp (cdr l)))))
- (let lp ((l (cons list1 rest)))
- (if (any1 null? l)
- (if #f #f)
- (begin
- (apply f (map1 car l))
- (lp (map1 cdr l)))))))
-
+(define map1 map)
(define (append-map f clist1 . rest)
(if (null? rest)
;;; 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
(else
(lp (map1 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
-
;;; 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
-;; extended versions of builtin procedures. exporting is delayed until the
-;; new bindings have been created.
-(export iota map map-in-order for-each list-index member delete delete! assoc)
+;;; srfi-1.scm ends here