mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

* README: Update.

Browse source 
* srfi-1.scm: New file.
This commit is contained in:
Martin Grabmüller 2001-06-07 04:27:37 +00:00
parent d36350e841
commit e9680547d3
4 changed files with 990 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

6
srfi/ChangeLog
View file

@ -1,3 +1,9 @@
2001-06-06 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
* README: Update.
* srfi-1.scm: New file.
2001-06-04 Marius Vollmer <mvo@zagadka.ping.de>
Added exception notice to all files.

3
srfi/Makefile.am
View file

@ -37,7 +37,8 @@ libguile_srfi_srfi_13_14_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c\
libguile_srfi_srfi_13_14_la_LDFLAGS = -version-info 0:0 -export-dynamic
srfidir = $(datadir)/guile/$(VERSION)/srfi
srfi_DATA = srfi-2.scm \
srfi_DATA = srfi-1.scm \
srfi-2.scm \
srfi-6.scm \
srfi-8.scm \
srfi-9.scm \

7
srfi/README
View file

@ -5,12 +5,17 @@ stand for, please refer to the SRFI homepage at
http://srfi.schemers.org
The following SRFIs are supported (as of 2001-05-22 -- 'martin):
The following SRFIs are supported (as of 2001-06-06 -- 'martin):
SRFI-0: cond-expand
Supported by default, no module needs to get used.
SRFI-1: List Library
A full toolbox of list processing procedures. (use-modules (srfi
srfi-1)) will make them available for use.
SRFI-2: and-let*
(use-modules (srfi srfi-2)) to make and-let* available.

976
srfi/srfi-1.scm Normal file
View file

@ -0,0 +1,976 @@
;;;; 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.
;;; 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.
;;;
;;; Code:
(define-module (srfi srfi-1)
:use-module (ice-9 receive))
(export
;;; Constructors
;; cons <= in the core
;; list <= in the core
xcons
;; cons* <= in the core
;; make-list <= in the core
list-tabulate
;; list-copy <= in the core
circular-list
iota
;;; Predicates
proper-list?
circular-list?
dotted-list?
;; pair? <= in the core
;; null? <= in the core
null-list?
not-pair?
list=
;;; Selectors
;; car <= in the core
;; cdr <= in the core
;; caar <= in the core
;; cadr <= in the core
;; cdar <= in the core
;; cddr <= in the core
;; caaar <= in the core
;; caadr <= in the core
;; cadar <= in the core
;; caddr <= in the core
;; cdaar <= in the core
;; cdadr <= in the core
;; cddar <= in the core
;; cdddr <= in the core
;; caaaar <= in the core
;; caaadr <= in the core
;; caadar <= in the core
;; caaddr <= in the core
;; cadaar <= in the core
;; cadadr <= in the core
;; caddar <= in the core
;; cadddr <= in the core
;; cdaaar <= in the core
;; cdaadr <= in the core
;; cdadar <= in the core
;; cdaddr <= in the core
;; cddaar <= in the core
;; cddadr <= in the core
;; cdddar <= in the core
;; cddddr <= in the core
;; list-ref <= in the core
first
second
third
fourth
fifth
sixth
seventh
eighth
ninth
tenth
car+cdr
take
drop
take-right
drop-right
take!
drop-right!
split-at
split-at!
last
;; last-pair <= in the core
;;; Miscelleneous: length, append, concatenate, reverse, zip & count
;; length <= in the core
length+
;; append <= in the core
;; append! <= in the core
concatenate
concatenate!
;; reverse <= in the core
;; reverse! <= in the core
append-reverse
append-reverse!
zip
unzip1
unzip2
unzip3
unzip4
unzip5
count
;;; Fold, unfold & map
fold
fold-right
pair-fold
pair-fold-right
reduce
reduce-right
unfold
unfold-right
;; map <= in the core
;; for-each <= in the core
append-map
append-map!
map!
;; map-in-order <= in the core
pair-for-each
filter-map
;;; Filtering & partitioning
filter
partition
remove
filter!
partition!
remove!
;;; Searching
find
find-tail
take-while
take-while!
drop-while
span
span!
break
break!
any
every
list-index
member ; Extended.
;; memq <= in the core
;; memv <= in the core
;;; Deletion
delete ; Extended.
delete!
delete-duplicates
delete-duplicates!
;;; Association lists
assoc ; Extended.
;; assq <= in the core
;; assv <= in the core
alist-cons
alist-copy
alist-delete
alist-delete!
;;; Set operations on lists
lset<=
lset=
lset-adjoin
lset-union
lset-intersection
lset-difference
lset-xor
lset-diff+intersection
lset-union!
lset-intersection!
lset-difference!
lset-xor!
lset-diff+intersection!
;;; Primitive side-effects
;; set-car! <= in the core
;; set-cdr! <= in the core
)
(cond-expand-provide (current-module) '(srfi-1))
;;; Constructors
(define (xcons d a)
(cons a d))
(define (list-tabulate n init-proc)
(let lp ((n n) (acc '()))
(if (zero? n)
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 (iota count . rest)
(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)
(reverse! acc)
(lp (+ n 1) (cons (+ start (* n step)) acc))))))
;;; Predicates
(define (proper-list? x)
(list? x))
(define (circular-list? x)
(if (not-pair? x)
#f
(let lp ((hare (cdr x)) (tortoise x))
(if (not-pair? hare)
#f
(let ((hare (cdr hare)))
(if (not-pair? hare)
#f
(if (eq? hare tortoise)
#t
(lp (cdr hare) (cdr tortoise)))))))))
(define (dotted-list? x)
(cond
((null? x) #f)
((not-pair? x) #t)
(else
(let lp ((hare (cdr x)) (tortoise x))
(cond
((null? hare) #f)
((not-pair? hare) #t)
(else
(let ((hare (cdr hare)))
(cond
((null? hare) #f)
((not-pair? hare) #t)
((eq? hare tortoise) #f)
(else
(lp (cdr hare) (cdr tortoise)))))))))))
(define (null-list? x)
(cond
((proper-list? x)
(null? x))
((circular-list? x)
#f)
(else
(error "not a proper list in null-list?"))))
(define (not-pair? x)
(not (pair? x)))
(define (list= elt= . rest)
(define (lists-equal a b)
(let lp ((a a) (b b))
(cond ((null? a)
(null? b))
((null? b)
#f)
(else
(and (elt= (car a) (car b))
(lp (cdr a) (cdr b)))))))
(or (null? rest)
(let ((first (car rest)))
(let lp ((lists rest))
(or (null? lists)
(and (lists-equal first (car lists))
(lp (cdr lists))))))))
;;; Selectors
(define first car)
(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) (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-right flist i)
(let lp ((n i) (l flist))
(if (zero? n)
(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)
(let lp0 ((s flist) (l l) (acc '()))
(if (null? l)
(reverse! acc)
(lp0 (cdr s) (cdr l) (cons (car s) acc))))
(lp (- n 1) (cdr l)))))
(define (take! x i)
(if (zero? i)
'()
(let lp ((n (- i 1)) (l x))
(if (zero? n)
(begin
(set-cdr! l '())
x)
(lp (- n 1) (cdr l))))))
(define (drop-right! flist i)
(if (zero? i)
flist
(let lp ((n (+ i 1)) (l flist))
(if (zero? n)
(let lp0 ((s flist) (l l))
(if (null? l)
(begin
(set-cdr! s '())
flist)
(lp0 (cdr s) (cdr l))))
(if (null? l)
'()
(lp (- n 1) (cdr l)))))))
(define (split-at x i)
(let lp ((l x) (n i) (acc '()))
(if (zero? n)
(values (reverse! acc) l)
(lp (cdr l) (- n 1) (cons (car l) acc)))))
(define (split-at! x i)
(if (zero? i)
(values '() x)
(let lp ((l x) (n (- i 1)))
(if (zero? n)
(let ((tmp (cdr l)))
(set-cdr! l '())
(values x tmp))
(lp (cdr l) (- n 1))))))
(define (last pair)
(car (last-pair pair)))
;;; 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)
acc
(lp (cdr l) (cons (car l) acc)))))
(define (append-reverse! rev-head tail)
(append-reverse rev-head tail)) ; XXX:optimize
(define (zip clist1 . rest)
(let lp ((l (cons clist1 rest)) (acc '()))
(if (any null? l)
(reverse! acc)
(lp (map cdr l) (cons (map car l) acc)))))
(define (unzip1 l)
(map first l))
(define (unzip2 l)
(values (map first l) (map second l)))
(define (unzip3 l)
(values (map first l) (map second l) (map third l)))
(define (unzip4 l)
(values (map first l) (map second l) (map third l) (map 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)))))
;;; Fold, unfold & map
(define (fold kons knil list1 . rest)
(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 (map car lists))
(cdrs (map cdr lists)))
(f (apply kons cars (list knil)) cdrs))))))
(define (fold-right kons knil clist1 . rest)
(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! (map car lists) (list (f (map cdr lists)))))))))
(define (pair-fold kons knil clist1 . rest)
(if (null? rest)
(let f ((knil knil) (list1 clist1))
(if (null? list1)
knil
(let ((tail (cdr list1)))
(f (kons list1 knil) tail))))
(let f ((knil knil) (lists (cons clist1 rest)))
(if (any null? lists)
knil
(let ((tails (map cdr lists)))
(f (apply kons lists (list knil)) tails))))))
(define (pair-fold-right kons knil clist1 . rest)
(if (null? rest)
(let f ((list1 clist1))
(if (null? list1)
knil
(kons list1 (f (cdr list1)))))
(let f ((lists (cons clist1 rest)))
(if (any null? lists)
knil
(apply kons (append! lists (list (f (map 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 (reduce f ridentity lst)
(fold f ridentity lst))
(define (reduce-right f ridentity lst)
(fold-right f ridentity lst))
(define (append-map f clist1 . rest)
(if (null? rest)
(let lp ((l clist1))
(if (null? l)
'()
(append (f (car l)) (lp (cdr l)))))
(let lp ((l (cons clist1 rest)))
(if (any1 null? l)
'()
(append (apply f (map car l)) (lp (map cdr l)))))))
(define (append-map! f clist1 . rest)
(if (null? rest)
(let lp ((l clist1))
(if (null? l)
'()
(append! (f (car l)) (lp (cdr l)))))
(let lp ((l (cons clist1 rest)))
(if (any1 null? l)
'()
(append! (apply f (map car l)) (lp (map 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)))))
(define (pair-for-each f clist1 . rest)
(if (null? rest)
(let lp ((l clist1))
(if (null? l)
(if #f #f)
(begin
(f l)
(lp (cdr l)))))
(let lp ((l (cons clist1 rest)))
(if (any1 null? l)
(if #f #f)
(begin
(apply f l)
(lp (map cdr l)))))))
(define (filter-map f clist1 . rest)
(if (null? rest)
(let lp ((l clist1))
(if (null? l)
'()
(let ((res (f (car l))))
(if res
(cons res (lp (cdr l)))
(lp (cdr l))))))
(let lp ((l (cons clist1 rest)))
(if (any1 null? l)
'()
(let ((res (apply f (map car l))))
(if res
(cons res (lp (map cdr l)))
(lp (map 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
(define (partition! pred list)
(partition pred list)) ; XXX:optimize
(define (remove! pred list)
(remove pred list)) ; XXX:optimize
;;; Searching
(define (find pred clist)
(if (null? clist)
#f
(if (pred (car clist))
(car clist)
(find pred (cdr clist)))))
(define (find-tail pred clist)
(if (null? clist)
#f
(if (pred (car clist))
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 clist)
(take-while pred clist)) ; XXX:optimize
(define (drop-while pred clist)
(if (null? clist)
'()
(if (pred (car clist))
(drop-while pred (cdr clist))
clist)))
(define (span pred clist)
(if (null? clist)
(values '() '())
(if (pred (car clist))
(receive (first last) (span pred (cdr clist))
(values (cons (car clist) first) last))
(values '() clist))))
(define (span! pred list)
(span pred list)) ; XXX:optimize
(define (break pred clist)
(if (null? clist)
(values '() '())
(if (pred (car clist))
(values '() clist)
(receive (first last) (break pred (cdr clist))
(values (cons (car clist) first) last)))))
(define (break! pred list)
(break pred list)) ; XXX:optimize
(define (any pred ls . lists)
(if (null? lists)
(any1 pred ls)
(let lp ((lists (cons ls lists)))
(cond ((any1 null? lists)
#f)
((any1 null? (map cdr lists))
(apply pred (map car lists)))
(else
(or (apply pred (map car lists)) (lp (map cdr lists))))))))
(define (any1 pred ls)
(let lp ((ls ls))
(cond ((null? ls)
#f)
((null? (cdr ls))
(pred (car ls)))
(else
(or (pred (car ls)) (lp (cdr ls)))))))
(define (every pred ls . lists)
(if (null? lists)
(every1 pred ls)
(let lp ((lists (cons ls lists)))
(cond ((any1 null? lists)
#t)
((any1 null? (map cdr lists))
(apply pred (map car lists)))
(else
(and (apply pred (map car lists)) (lp (map cdr lists))))))))
(define (every1 pred ls)
(let lp ((ls ls))
(cond ((null? ls)
#t)
((null? (cdr ls))
(pred (car ls)))
(else
(and (pred (car ls)) (lp (cdr ls)))))))
(define (list-index pred clist1 . rest)
(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 (map 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= (car l) x)
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) (cdr l1)))))))
(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= (caar a) key)
(car a)
(lp (cdr a)))))))
(define (alist-cons key datum alist)
(acons key datum alist))
(define (alist-copy alist)
(let lp ((a alist))
(if (null? a)
'()
(cons (cons (caar a) (cdar a)) (lp (cdr a))))))
(define (alist-delete key alist . rest)
(let ((k= (if (pair? rest) (car rest) equal?)))
(let lp ((a alist))
(if (null? a)
'()
(if (k= (caar a) key)
(lp (cdr a))
(cons (car a) (lp (cdr a))))))))
(define (alist-delete! key alist . rest)
(let ((k= (if (pair? rest) (car rest) equal?)))
(alist-delete key alist k=))) ; XXX:optimize
;;; Set operations on lists
(define (lset<= = . rest)
(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)))))))
(define (lset= = list1 . rest)
(if (null? rest)
#t
(let lp ((f list1) (r rest))
(or (null? r)
(and (every (lambda (el) (member el (car r) =)) f)
(every (lambda (el) (member el f =)) (car r))
(lp (car r) (cdr r)))))))
(define (lset-adjoin = list . rest)
(let lp ((l rest) (acc list))
(if (null? l)
acc
(if (member (car l) acc)
(lp (cdr l) acc)
(lp (cdr l) (cons (car l) acc))))))
(define (lset-union = . rest)
(let lp0 ((l rest) (acc '()))
(if (null? l)
(reverse! acc)
(let lp1 ((ll (car l)) (acc acc))
(if (null? ll)
(lp0 (cdr l) acc)
(if (member (car ll) acc =)
(lp1 (cdr ll) acc)
(lp1 (cdr ll) (cons (car ll) acc))))))))
(define (lset-intersection = list1 . rest)
(let lp ((l list1) (acc '()))
(if (null? l)
(reverse! acc)
(if (every (lambda (ll) (member (car l) ll =)) rest)
(lp (cdr l) (cons (car l) acc))
(lp (cdr l) acc)))))
(define (lset-difference = list1 . rest)
(if (null? rest)
list1
(let lp ((l list1) (acc '()))
(if (null? l)
(reverse! acc)
(if (any (lambda (ll) (member (car l) ll =)) rest)
(lp (cdr l) acc)
(lp (cdr l) (cons (car l) acc)))))))
;(define (fold kons knil list1 . rest)
(define (lset-xor = . rest)
(fold (lambda (lst res)
(let lp ((l lst) (acc '()))
(if (null? l)
(let lp0 ((r res) (acc acc))
(if (null? r)
(reverse! acc)
(if (member (car r) lst =)
(lp0 (cdr r) acc)
(lp0 (cdr r) (cons (car r) acc)))))
(if (member (car l) res =)
(lp (cdr l) acc)
(lp (cdr l) (cons (car l) acc))))))
'()
rest))
(define (lset-diff+intersection = list1 . rest)
(let lp ((l list1) (accd '()) (acci '()))
(if (null? l)
(values (reverse! accd) (reverse! acci))
(let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
(if appears
(lp (cdr l) accd (cons (car l) acci))
(lp (cdr l) (cons (car l) accd) acci))))))
(define (lset-union! = . rest)
(apply lset-union = rest)) ; XXX:optimize
(define (lset-intersection! = list1 . rest)
(apply lset-intersection = list1 rest)) ; XXX:optimize
(define (lset-difference! = list1 . rest)
(apply lset-difference = list1 rest)) ; XXX:optimize
(define (lset-xor! = . rest)
(apply lset-xor = rest)) ; XXX:optimize
(define (lset-diff+intersection! = list1 . rest)
(apply lset-diff+intersection = list1 rest)) ; XXX:optimize