-;;;; 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 ; Extended.
+ ;; iota ; Extended.
;;; Predicates
proper-list?
reduce-right
unfold
unfold-right
- map ; Extended.
- for-each ; Extended.
+ ;; map ; Extended.
+ ;; for-each ; Extended.
append-map
append-map!
map!
- map-in-order ; Extended.
+ ;; 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 ; Extended.
- member ; Extended.
+ ;; list-index ; Extended.
+ ;; member ; Extended.
;; memq <= in the core
;; memv <= in the core
;;; Deletion
- delete ; Extended.
- delete! ; Extended.
+ ;; 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)
(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)
;;; 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)
(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)
- (if (null? ls)
- ls
- (let ((ret (list (f (car ls)))))
- (let lp ((ls (cdr ls)) (p ret)) ; tail pointer
- (if (null? ls)
- ret
- (begin
- (set-cdr! p (list (f (car ls))))
- (lp (cdr ls) (cdr p))))))))
-
-;; 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)
- (check-arg-type list? list "filter") ; reject circular lists.
- (letrec ((filiter (lambda (pred rest result)
- (if (null? rest)
- (reverse! result)
- (filiter pred (cdr rest)
- (cond ((pred (car rest))
- (cons (car rest) result))
- (else
- result)))))))
- (filiter pred 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)
(filter (lambda (x) (not (pred x))) list))
-(define (filter! pred list)
- (filter pred list)) ; XXX:optimize
-
(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
+
+;;; srfi-1.scm ends here
HCoop / bpt / guile.git / blobdiff