| blob | adf085c29b1ba9508c2bcd60d1270d0e9ed59467 |
1 ;;; srfi-1.scm --- List Library
3 ;; Copyright (C) 2001, 2002 Free Software Foundation, Inc.
4 ;;
5 ;; This program is free software; you can redistribute it and/or
6 ;; modify it under the terms of the GNU General Public License as
7 ;; published by the Free Software Foundation; either version 2, or
8 ;; (at your option) any later version.
9 ;;
10 ;; This program is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; General Public License for more details.
14 ;;
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with this software; see the file COPYING. If not, write to
17 ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
18 ;; Boston, MA 02111-1307 USA
19 ;;
20 ;; As a special exception, the Free Software Foundation gives permission
21 ;; for additional uses of the text contained in its release of GUILE.
22 ;;
23 ;; The exception is that, if you link the GUILE library with other files
24 ;; to produce an executable, this does not by itself cause the
25 ;; resulting executable to be covered by the GNU General Public License.
26 ;; Your use of that executable is in no way restricted on account of
27 ;; linking the GUILE library code into it.
28 ;;
29 ;; This exception does not however invalidate any other reasons why
30 ;; the executable file might be covered by the GNU General Public License.
31 ;;
32 ;; This exception applies only to the code released by the
33 ;; Free Software Foundation under the name GUILE. If you copy
34 ;; code from other Free Software Foundation releases into a copy of
35 ;; GUILE, as the General Public License permits, the exception does
36 ;; not apply to the code that you add in this way. To avoid misleading
37 ;; anyone as to the status of such modified files, you must delete
38 ;; this exception notice from them.
39 ;;
40 ;; If you write modifications of your own for GUILE, it is your choice
41 ;; whether to permit this exception to apply to your modifications.
42 ;; If you do not wish that, delete this exception notice.
44 ;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
45 ;;; Date: 2001-06-06
47 ;;; Commentary:
49 ;; This is an implementation of SRFI-1 (List Library).
50 ;;
51 ;; All procedures defined in SRFI-1, which are not already defined in
52 ;; the Guile core library, are exported. The procedures in this
53 ;; implementation work, but they have not been tuned for speed or
54 ;; memory usage.
55 ;;
56 ;; This module is fully documented in the Guile Reference Manual.
58 ;;; Code:
60 (define-module (srfi srfi-1)
61 :use-module (ice-9 session)
62 :use-module (ice-9 receive))
64 (begin-deprecated
65 ;; Prevent `export' from re-exporting core bindings. This behaviour
66 ;; of `export' is deprecated and will disappear in one of the next
67 ;; releases.
68 (define iota #f)
69 (define map #f)
70 (define map-in-order #f)
71 (define for-each #f)
72 (define list-index #f)
73 (define member #f)
74 (define delete #f)
75 (define delete! #f)
76 (define assoc #f))
78 (export
79 ;;; Constructors
80 ;; cons <= in the core
81 ;; list <= in the core
82 xcons
83 ;; cons* <= in the core
84 ;; make-list <= in the core
85 list-tabulate
86 ;; list-copy <= in the core
87 circular-list
88 iota ; Extended.
90 ;;; Predicates
91 proper-list?
92 circular-list?
93 dotted-list?
94 ;; pair? <= in the core
95 ;; null? <= in the core
96 null-list?
97 not-pair?
98 list=
100 ;;; Selectors
101 ;; car <= in the core
102 ;; cdr <= in the core
103 ;; caar <= in the core
104 ;; cadr <= in the core
105 ;; cdar <= in the core
106 ;; cddr <= in the core
107 ;; caaar <= in the core
108 ;; caadr <= in the core
109 ;; cadar <= in the core
110 ;; caddr <= in the core
111 ;; cdaar <= in the core
112 ;; cdadr <= in the core
113 ;; cddar <= in the core
114 ;; cdddr <= in the core
115 ;; caaaar <= in the core
116 ;; caaadr <= in the core
117 ;; caadar <= in the core
118 ;; caaddr <= in the core
119 ;; cadaar <= in the core
120 ;; cadadr <= in the core
121 ;; caddar <= in the core
122 ;; cadddr <= in the core
123 ;; cdaaar <= in the core
124 ;; cdaadr <= in the core
125 ;; cdadar <= in the core
126 ;; cdaddr <= in the core
127 ;; cddaar <= in the core
128 ;; cddadr <= in the core
129 ;; cdddar <= in the core
130 ;; cddddr <= in the core
131 ;; list-ref <= in the core
132 first
133 second
134 third
135 fourth
136 fifth
137 sixth
138 seventh
139 eighth
140 ninth
141 tenth
142 car+cdr
143 take
144 drop
145 take-right
146 drop-right
147 take!
148 drop-right!
149 split-at
150 split-at!
151 last
152 ;; last-pair <= in the core
154 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
155 ;; length <= in the core
156 length+
157 ;; append <= in the core
158 ;; append! <= in the core
159 concatenate
160 concatenate!
161 ;; reverse <= in the core
162 ;; reverse! <= in the core
163 append-reverse
164 append-reverse!
165 zip
166 unzip1
167 unzip2
168 unzip3
169 unzip4
170 unzip5
171 count
173 ;;; Fold, unfold & map
174 fold
175 fold-right
176 pair-fold
177 pair-fold-right
178 reduce
179 reduce-right
180 unfold
181 unfold-right
182 map ; Extended.
183 for-each ; Extended.
184 append-map
185 append-map!
186 map!
187 map-in-order ; Extended.
188 pair-for-each
189 filter-map
191 ;;; Filtering & partitioning
192 filter
193 partition
194 remove
195 filter!
196 partition!
197 remove!
199 ;;; Searching
200 find
201 find-tail
202 take-while
203 take-while!
204 drop-while
205 span
206 span!
207 break
208 break!
209 any
210 every
211 list-index ; Extended.
212 member ; Extended.
213 ;; memq <= in the core
214 ;; memv <= in the core
216 ;;; Deletion
217 delete ; Extended.
218 delete! ; Extended.
219 delete-duplicates
220 delete-duplicates!
222 ;;; Association lists
223 assoc ; Extended.
224 ;; assq <= in the core
225 ;; assv <= in the core
226 alist-cons
227 alist-copy
228 alist-delete
229 alist-delete!
231 ;;; Set operations on lists
232 lset<=
233 lset=
234 lset-adjoin
235 lset-union
236 lset-intersection
237 lset-difference
238 lset-xor
239 lset-diff+intersection
240 lset-union!
241 lset-intersection!
242 lset-difference!
243 lset-xor!
244 lset-diff+intersection!
246 ;;; Primitive side-effects
247 ;; set-car! <= in the core
248 ;; set-cdr! <= in the core
249 )
251 (cond-expand-provide (current-module) '(srfi-1))
253 ;;; Constructors
255 (define (xcons d a)
256 (cons a d))
258 ;; internal helper, similar to (scsh utilities) check-arg.
259 (define (check-arg-type pred arg caller)
260 (if (pred arg)
261 arg
262 (scm-error 'wrong-type-arg caller
263 "Wrong type argument: ~S" (list arg) '())))
265 ;; the srfi spec doesn't seem to forbid inexact integers.
266 (define (non-negative-integer? x) (and (integer? x) (>= x 0)))
268 (define (list-tabulate n init-proc)
269 (check-arg-type non-negative-integer? n "list-tabulate")
270 (let lp ((n n) (acc '()))
271 (if (<= n 0)
272 acc
273 (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
275 (define (circular-list elt1 . rest)
276 (let ((start (cons elt1 '())))
277 (let lp ((r rest) (p start))
278 (if (null? r)
279 (begin
280 (set-cdr! p start)
281 start)
282 (begin
283 (set-cdr! p (cons (car r) '()))
284 (lp (cdr r) (cdr p)))))))
286 (define (iota count . rest)
287 (check-arg-type non-negative-integer? count "iota")
288 (let ((start (if (pair? rest) (car rest) 0))
289 (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1)))
290 (let lp ((n 0) (acc '()))
291 (if (= n count)
292 (reverse! acc)
293 (lp (+ n 1) (cons (+ start (* n step)) acc))))))
295 ;;; Predicates
297 (define (proper-list? x)
298 (list? x))
300 (define (circular-list? x)
301 (if (not-pair? x)
302 #f
303 (let lp ((hare (cdr x)) (tortoise x))
304 (if (not-pair? hare)
305 #f
306 (let ((hare (cdr hare)))
307 (if (not-pair? hare)
308 #f
309 (if (eq? hare tortoise)
310 #t
311 (lp (cdr hare) (cdr tortoise)))))))))
313 (define (dotted-list? x)
314 (cond
315 ((null? x) #f)
316 ((not-pair? x) #t)
317 (else
318 (let lp ((hare (cdr x)) (tortoise x))
319 (cond
320 ((null? hare) #f)
321 ((not-pair? hare) #t)
322 (else
323 (let ((hare (cdr hare)))
324 (cond
325 ((null? hare) #f)
326 ((not-pair? hare) #t)
327 ((eq? hare tortoise) #f)
328 (else
329 (lp (cdr hare) (cdr tortoise)))))))))))
331 (define (null-list? x)
332 (cond
333 ((proper-list? x)
334 (null? x))
335 ((circular-list? x)
336 #f)
337 (else
338 (error "not a proper list in null-list?"))))
340 (define (not-pair? x)
341 (not (pair? x)))
343 (define (list= elt= . rest)
344 (define (lists-equal a b)
345 (let lp ((a a) (b b))
346 (cond ((null? a)
347 (null? b))
348 ((null? b)
349 #f)
350 (else
351 (and (elt= (car a) (car b))
352 (lp (cdr a) (cdr b)))))))
353 (or (null? rest)
354 (let ((first (car rest)))
355 (let lp ((lists rest))
356 (or (null? lists)
357 (and (lists-equal first (car lists))
358 (lp (cdr lists))))))))
360 ;;; Selectors
362 (define first car)
363 (define second cadr)
364 (define third caddr)
365 (define fourth cadddr)
366 (define (fifth x) (car (cddddr x)))
367 (define (sixth x) (cadr (cddddr x)))
368 (define (seventh x) (caddr (cddddr x)))
369 (define (eighth x) (cadddr (cddddr x)))
370 (define (ninth x) (car (cddddr (cddddr x))))
371 (define (tenth x) (cadr (cddddr (cddddr x))))
373 (define (car+cdr x) (values (car x) (cdr x)))
375 (define (take x i)
376 (let lp ((n i) (l x) (acc '()))
377 (if (<= n 0)
378 (reverse! acc)
379 (lp (- n 1) (cdr l) (cons (car l) acc)))))
380 (define (drop x i)
381 (let lp ((n i) (l x))
382 (if (<= n 0)
383 l
384 (lp (- n 1) (cdr l)))))
385 (define (take-right flist i)
386 (let lp ((n i) (l flist))
387 (if (<= n 0)
388 (let lp0 ((s flist) (l l))
389 (if (null? l)
390 s
391 (lp0 (cdr s) (cdr l))))
392 (lp (- n 1) (cdr l)))))
394 (define (drop-right flist i)
395 (let lp ((n i) (l flist))
396 (if (<= n 0)
397 (let lp0 ((s flist) (l l) (acc '()))
398 (if (null? l)
399 (reverse! acc)
400 (lp0 (cdr s) (cdr l) (cons (car s) acc))))
401 (lp (- n 1) (cdr l)))))
403 (define (take! x i)
404 (if (<= i 0)
405 '()
406 (let lp ((n (- i 1)) (l x))
407 (if (<= n 0)
408 (begin
409 (set-cdr! l '())
410 x)
411 (lp (- n 1) (cdr l))))))
413 (define (drop-right! flist i)
414 (if (<= i 0)
415 flist
416 (let lp ((n (+ i 1)) (l flist))
417 (if (<= n 0)
418 (let lp0 ((s flist) (l l))
419 (if (null? l)
420 (begin
421 (set-cdr! s '())
422 flist)
423 (lp0 (cdr s) (cdr l))))
424 (if (null? l)
425 '()
426 (lp (- n 1) (cdr l)))))))
428 (define (split-at x i)
429 (let lp ((l x) (n i) (acc '()))
430 (if (<= n 0)
431 (values (reverse! acc) l)
432 (lp (cdr l) (- n 1) (cons (car l) acc)))))
434 (define (split-at! x i)
435 (if (<= i 0)
436 (values '() x)
437 (let lp ((l x) (n (- i 1)))
438 (if (<= n 0)
439 (let ((tmp (cdr l)))
440 (set-cdr! l '())
441 (values x tmp))
442 (lp (cdr l) (- n 1))))))
444 (define (last pair)
445 (car (last-pair pair)))
447 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
449 (define (length+ clist)
450 (if (null? clist)
451 0
452 (let lp ((hare (cdr clist)) (tortoise clist) (l 1))
453 (if (null? hare)
454 l
455 (let ((hare (cdr hare)))
456 (if (null? hare)
457 (+ l 1)
458 (if (eq? hare tortoise)
459 #f
460 (lp (cdr hare) (cdr tortoise) (+ l 2)))))))))
462 (define (concatenate l-o-l)
463 (let lp ((l l-o-l) (acc '()))
464 (if (null? l)
465 (reverse! acc)
466 (let lp0 ((ll (car l)) (acc acc))
467 (if (null? ll)
468 (lp (cdr l) acc)
469 (lp0 (cdr ll) (cons (car ll) acc)))))))
471 (define (concatenate! l-o-l)
472 (let lp0 ((l-o-l l-o-l))
473 (cond
474 ((null? l-o-l)
475 '())
476 ((null? (car l-o-l))
477 (lp0 (cdr l-o-l)))
478 (else
479 (let ((result (car l-o-l)) (tail (last-pair (car l-o-l))))
480 (let lp ((l (cdr l-o-l)) (ntail tail))
481 (if (null? l)
482 result
483 (begin
484 (set-cdr! ntail (car l))
485 (lp (cdr l) (last-pair ntail))))))))))
488 (define (append-reverse rev-head tail)
489 (let lp ((l rev-head) (acc tail))
490 (if (null? l)
491 acc
492 (lp (cdr l) (cons (car l) acc)))))
494 (define (append-reverse! rev-head tail)
495 (append-reverse rev-head tail)) ; XXX:optimize
497 (define (zip clist1 . rest)
498 (let lp ((l (cons clist1 rest)) (acc '()))
499 (if (any null? l)
500 (reverse! acc)
501 (lp (map1 cdr l) (cons (map1 car l) acc)))))
504 (define (unzip1 l)
505 (map1 first l))
506 (define (unzip2 l)
507 (values (map1 first l) (map1 second l)))
508 (define (unzip3 l)
509 (values (map1 first l) (map1 second l) (map1 third l)))
510 (define (unzip4 l)
511 (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)))
512 (define (unzip5 l)
513 (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)
514 (map1 fifth l)))
516 (define (count pred clist1 . rest)
517 (if (null? rest)
518 (count1 pred clist1)
519 (let lp ((lists (cons clist1 rest)))
520 (cond ((any1 null? lists)
521 0)
522 (else
523 (if (apply pred (map1 car lists))
524 (+ 1 (lp (map1 cdr lists)))
525 (lp (map1 cdr lists))))))))
527 (define (count1 pred clist)
528 (let lp ((result 0) (rest clist))
529 (if (null? rest)
530 result
531 (if (pred (car rest))
532 (lp (+ 1 result) (cdr rest))
533 (lp result (cdr rest))))))
535 ;;; Fold, unfold & map
537 (define (fold kons knil list1 . rest)
538 (if (null? rest)
539 (let f ((knil knil) (list1 list1))
540 (if (null? list1)
541 knil
542 (f (kons (car list1) knil) (cdr list1))))
543 (let f ((knil knil) (lists (cons list1 rest)))
544 (if (any null? lists)
545 knil
546 (let ((cars (map1 car lists))
547 (cdrs (map1 cdr lists)))
548 (f (apply kons (append! cars (list knil))) cdrs))))))
550 (define (fold-right kons knil clist1 . rest)
551 (if (null? rest)
552 (let f ((list1 clist1))
553 (if (null? list1)
554 knil
555 (kons (car list1) (f (cdr list1)))))
556 (let f ((lists (cons clist1 rest)))
557 (if (any null? lists)
558 knil
559 (apply kons (append! (map1 car lists) (list (f (map1 cdr lists)))))))))
561 (define (pair-fold kons knil clist1 . rest)
562 (if (null? rest)
563 (let f ((knil knil) (list1 clist1))
564 (if (null? list1)
565 knil
566 (let ((tail (cdr list1)))
567 (f (kons list1 knil) tail))))
568 (let f ((knil knil) (lists (cons clist1 rest)))
569 (if (any null? lists)
570 knil
571 (let ((tails (map1 cdr lists)))
572 (f (apply kons (append! lists (list knil))) tails))))))
575 (define (pair-fold-right kons knil clist1 . rest)
576 (if (null? rest)
577 (let f ((list1 clist1))
578 (if (null? list1)
579 knil
580 (kons list1 (f (cdr list1)))))
581 (let f ((lists (cons clist1 rest)))
582 (if (any null? lists)
583 knil
584 (apply kons (append! lists (list (f (map1 cdr lists)))))))))
586 (define (unfold p f g seed . rest)
587 (let ((tail-gen (if (pair? rest)
588 (if (pair? (cdr rest))
589 (scm-error 'wrong-number-of-args
590 "unfold" "too many arguments" '() '())
591 (car rest))
592 (lambda (x) '()))))
593 (let uf ((seed seed))
594 (if (p seed)
595 (tail-gen seed)
596 (cons (f seed)
597 (uf (g seed)))))))
599 (define (unfold-right p f g seed . rest)
600 (let ((tail (if (pair? rest)
601 (if (pair? (cdr rest))
602 (scm-error 'wrong-number-of-args
603 "unfold-right" "too many arguments" '()
604 '())
605 (car rest))
606 '())))
607 (let uf ((seed seed) (lis tail))
608 (if (p seed)
609 lis
610 (uf (g seed) (cons (f seed) lis))))))
612 (define (reduce f ridentity lst)
613 (fold f ridentity lst))
615 (define (reduce-right f ridentity lst)
616 (fold-right f ridentity lst))
619 ;; Internal helper procedure. Map `f' over the single list `ls'.
620 ;;
621 (define (map1 f ls)
622 (if (null? ls)
623 ls
624 (let ((ret (list (f (car ls)))))
625 (let lp ((ls (cdr ls)) (p ret)) ; tail pointer
626 (if (null? ls)
627 ret
628 (begin
629 (set-cdr! p (list (f (car ls))))
630 (lp (cdr ls) (cdr p))))))))
632 ;; This `map' is extended from the standard `map'. It allows argument
633 ;; lists of different length, so that the shortest list determines the
634 ;; number of elements processed.
635 ;;
636 (define (map f list1 . rest)
637 (if (null? rest)
638 (map1 f list1)
639 (let lp ((l (cons list1 rest)))
640 (if (any1 null? l)
641 '()
642 (cons (apply f (map1 car l)) (lp (map1 cdr l)))))))
644 ;; extended to lists of unequal length.
645 (define map-in-order map)
647 ;; This `for-each' is extended from the standard `for-each'. It
648 ;; allows argument lists of different length, so that the shortest
649 ;; list determines the number of elements processed.
650 ;;
651 (define (for-each f list1 . rest)
652 (if (null? rest)
653 (let lp ((l list1))
654 (if (null? l)
655 (if #f #f) ; Return unspecified value.
656 (begin
657 (f (car l))
658 (lp (cdr l)))))
659 (let lp ((l (cons list1 rest)))
660 (if (any1 null? l)
661 (if #f #f)
662 (begin
663 (apply f (map1 car l))
664 (lp (map1 cdr l)))))))
667 (define (append-map f clist1 . rest)
668 (if (null? rest)
669 (let lp ((l clist1))
670 (if (null? l)
671 '()
672 (append (f (car l)) (lp (cdr l)))))
673 (let lp ((l (cons clist1 rest)))
674 (if (any1 null? l)
675 '()
676 (append (apply f (map1 car l)) (lp (map1 cdr l)))))))
679 (define (append-map! f clist1 . rest)
680 (if (null? rest)
681 (let lp ((l clist1))
682 (if (null? l)
683 '()
684 (append! (f (car l)) (lp (cdr l)))))
685 (let lp ((l (cons clist1 rest)))
686 (if (any1 null? l)
687 '()
688 (append! (apply f (map1 car l)) (lp (map1 cdr l)))))))
690 (define (map! f list1 . rest)
691 (if (null? rest)
692 (let lp ((l list1))
693 (if (null? l)
694 '()
695 (begin
696 (set-car! l (f (car l)))
697 (set-cdr! l (lp (cdr l)))
698 l)))
699 (let lp ((l (cons list1 rest)) (res list1))
700 (if (any1 null? l)
701 '()
702 (begin
703 (set-car! res (apply f (map1 car l)))
704 (set-cdr! res (lp (map1 cdr l) (cdr res)))
705 res)))))
707 (define (pair-for-each f clist1 . rest)
708 (if (null? rest)
709 (let lp ((l clist1))
710 (if (null? l)
711 (if #f #f)
712 (begin
713 (f l)
714 (lp (cdr l)))))
715 (let lp ((l (cons clist1 rest)))
716 (if (any1 null? l)
717 (if #f #f)
718 (begin
719 (apply f l)
720 (lp (map1 cdr l)))))))
722 (define (filter-map f clist1 . rest)
723 (if (null? rest)
724 (let lp ((l clist1))
725 (if (null? l)
726 '()
727 (let ((res (f (car l))))
728 (if res
729 (cons res (lp (cdr l)))
730 (lp (cdr l))))))
731 (let lp ((l (cons clist1 rest)))
732 (if (any1 null? l)
733 '()
734 (let ((res (apply f (map1 car l))))
735 (if res
736 (cons res (lp (map1 cdr l)))
737 (lp (map1 cdr l))))))))
739 ;;; Filtering & partitioning
741 (define (filter pred list)
742 (check-arg-type list? list "filter") ; reject circular lists.
743 (letrec ((filiter (lambda (pred rest result)
744 (if (null? rest)
745 (reverse! result)
746 (filiter pred (cdr rest)
747 (cond ((pred (car rest))
748 (cons (car rest) result))
749 (else
750 result)))))))
751 (filiter pred list '())))
753 (define (partition pred list)
754 (if (null? list)
755 (values '() '())
756 (if (pred (car list))
757 (receive (in out) (partition pred (cdr list))
758 (values (cons (car list) in) out))
759 (receive (in out) (partition pred (cdr list))
760 (values in (cons (car list) out))))))
762 (define (remove pred list)
763 (filter (lambda (x) (not (pred x))) list))
765 (define (filter! pred list)
766 (filter pred list)) ; XXX:optimize
768 (define (partition! pred list)
769 (partition pred list)) ; XXX:optimize
771 (define (remove! pred list)
772 (remove pred list)) ; XXX:optimize
774 ;;; Searching
776 (define (find pred clist)
777 (if (null? clist)
778 #f
779 (if (pred (car clist))
780 (car clist)
781 (find pred (cdr clist)))))
783 (define (find-tail pred clist)
784 (if (null? clist)
785 #f
786 (if (pred (car clist))
787 clist
788 (find-tail pred (cdr clist)))))
790 (define (take-while pred ls)
791 (cond ((null? ls) '())
792 ((not (pred (car ls))) '())
793 (else
794 (let ((result (list (car ls))))
795 (let lp ((ls (cdr ls)) (p result))
796 (cond ((null? ls) result)
797 ((not (pred (car ls))) result)
798 (else
799 (set-cdr! p (list (car ls)))
800 (lp (cdr ls) (cdr p)))))))))
802 (define (take-while! pred clist)
803 (take-while pred clist)) ; XXX:optimize
805 (define (drop-while pred clist)
806 (if (null? clist)
807 '()
808 (if (pred (car clist))
809 (drop-while pred (cdr clist))
810 clist)))
812 (define (span pred clist)
813 (if (null? clist)
814 (values '() '())
815 (if (pred (car clist))
816 (receive (first last) (span pred (cdr clist))
817 (values (cons (car clist) first) last))
818 (values '() clist))))
820 (define (span! pred list)
821 (span pred list)) ; XXX:optimize
823 (define (break pred clist)
824 (if (null? clist)
825 (values '() '())
826 (if (pred (car clist))
827 (values '() clist)
828 (receive (first last) (break pred (cdr clist))
829 (values (cons (car clist) first) last)))))
831 (define (break! pred list)
832 (break pred list)) ; XXX:optimize
834 (define (any pred ls . lists)
835 (if (null? lists)
836 (any1 pred ls)
837 (let lp ((lists (cons ls lists)))
838 (cond ((any1 null? lists)
839 #f)
840 ((any1 null? (map1 cdr lists))
841 (apply pred (map1 car lists)))
842 (else
843 (or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
845 (define (any1 pred ls)
846 (let lp ((ls ls))
847 (cond ((null? ls)
848 #f)
849 ((null? (cdr ls))
850 (pred (car ls)))
851 (else
852 (or (pred (car ls)) (lp (cdr ls)))))))
854 (define (every pred ls . lists)
855 (if (null? lists)
856 (every1 pred ls)
857 (let lp ((lists (cons ls lists)))
858 (cond ((any1 null? lists)
859 #t)
860 ((any1 null? (map1 cdr lists))
861 (apply pred (map1 car lists)))
862 (else
863 (and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
865 (define (every1 pred ls)
866 (let lp ((ls ls))
867 (cond ((null? ls)
868 #t)
869 ((null? (cdr ls))
870 (pred (car ls)))
871 (else
872 (and (pred (car ls)) (lp (cdr ls)))))))
874 (define (list-index pred clist1 . rest)
875 (if (null? rest)
876 (let lp ((l clist1) (i 0))
877 (if (null? l)
878 #f
879 (if (pred (car l))
880 i
881 (lp (cdr l) (+ i 1)))))
882 (let lp ((lists (cons clist1 rest)) (i 0))
883 (cond ((any1 null? lists)
884 #f)
885 ((apply pred (map1 car lists)) i)
886 (else
887 (lp (map1 cdr lists) (+ i 1)))))))
889 (define (member x list . rest)
890 (let ((l= (if (pair? rest) (car rest) equal?)))
891 (let lp ((l list))
892 (if (null? l)
893 #f
894 (if (l= x (car l))
895 l
896 (lp (cdr l)))))))
898 ;;; Deletion
900 (define (delete x list . rest)
901 (let ((l= (if (pair? rest) (car rest) equal?)))
902 (let lp ((l list))
903 (if (null? l)
904 '()
905 (if (l= (car l) x)
906 (lp (cdr l))
907 (cons (car l) (lp (cdr l))))))))
909 (define (delete! x list . rest)
910 (let ((l= (if (pair? rest) (car rest) equal?)))
911 (delete x list l=))) ; XXX:optimize
913 (define (delete-duplicates list . rest)
914 (let ((l= (if (pair? rest) (car rest) equal?)))
915 (let lp0 ((l1 list))
916 (if (null? l1)
917 '()
918 (if (let lp1 ((l2 (cdr l1)))
919 (if (null? l2)
920 #f
921 (if (l= (car l1) (car l2))
922 #t
923 (lp1 (cdr l2)))))
924 (lp0 (cdr l1))
925 (cons (car l1) (lp0 (cdr l1))))))))
927 (define (delete-duplicates list . rest)
928 (let ((l= (if (pair? rest) (car rest) equal?)))
929 (let lp ((list list))
930 (if (null? list)
931 '()
932 (cons (car list) (lp (delete (car list) (cdr list) l=)))))))
934 (define (delete-duplicates! list . rest)
935 (let ((l= (if (pair? rest) (car rest) equal?)))
936 (delete-duplicates list l=))) ; XXX:optimize
938 ;;; Association lists
940 (define (assoc key alist . rest)
941 (let ((k= (if (pair? rest) (car rest) equal?)))
942 (let lp ((a alist))
943 (if (null? a)
944 #f
945 (if (k= key (caar a))
946 (car a)
947 (lp (cdr a)))))))
949 (define (alist-cons key datum alist)
950 (acons key datum alist))
952 (define (alist-copy alist)
953 (let lp ((a alist))
954 (if (null? a)
955 '()
956 (acons (caar a) (cdar a) (lp (cdr a))))))
958 (define (alist-delete key alist . rest)
959 (let ((k= (if (pair? rest) (car rest) equal?)))
960 (let lp ((a alist))
961 (if (null? a)
962 '()
963 (if (k= (caar a) key)
964 (lp (cdr a))
965 (cons (car a) (lp (cdr a))))))))
967 (define (alist-delete! key alist . rest)
968 (let ((k= (if (pair? rest) (car rest) equal?)))
969 (alist-delete key alist k=))) ; XXX:optimize
971 ;;; Set operations on lists
973 (define (lset<= = . rest)
974 (if (null? rest)
975 #t
976 (let lp ((f (car rest)) (r (cdr rest)))
977 (or (null? r)
978 (and (every (lambda (el) (member el (car r) =)) f)
979 (lp (car r) (cdr r)))))))
981 (define (lset= = list1 . rest)
982 (if (null? rest)
983 #t
984 (let lp ((f list1) (r rest))
985 (or (null? r)
986 (and (every (lambda (el) (member el (car r) =)) f)
987 (every (lambda (el) (member el f =)) (car r))
988 (lp (car r) (cdr r)))))))
990 (define (lset-adjoin = list . rest)
991 (let lp ((l rest) (acc list))
992 (if (null? l)
993 acc
994 (if (member (car l) acc)
995 (lp (cdr l) acc)
996 (lp (cdr l) (cons (car l) acc))))))
998 (define (lset-union = . rest)
999 (let lp0 ((l rest) (acc '()))
1000 (if (null? l)
1001 (reverse! acc)
1002 (let lp1 ((ll (car l)) (acc acc))
1003 (if (null? ll)
1004 (lp0 (cdr l) acc)
1005 (if (member (car ll) acc =)
1006 (lp1 (cdr ll) acc)
1007 (lp1 (cdr ll) (cons (car ll) acc))))))))
1009 (define (lset-intersection = list1 . rest)
1010 (let lp ((l list1) (acc '()))
1011 (if (null? l)
1012 (reverse! acc)
1013 (if (every (lambda (ll) (member (car l) ll =)) rest)
1014 (lp (cdr l) (cons (car l) acc))
1015 (lp (cdr l) acc)))))
1017 (define (lset-difference = list1 . rest)
1018 (if (null? rest)
1019 list1
1020 (let lp ((l list1) (acc '()))
1021 (if (null? l)
1022 (reverse! acc)
1023 (if (any (lambda (ll) (member (car l) ll =)) rest)
1024 (lp (cdr l) acc)
1025 (lp (cdr l) (cons (car l) acc)))))))
1027 ;(define (fold kons knil list1 . rest)
1029 (define (lset-xor = . rest)
1030 (fold (lambda (lst res)
1031 (let lp ((l lst) (acc '()))
1032 (if (null? l)
1033 (let lp0 ((r res) (acc acc))
1034 (if (null? r)
1035 (reverse! acc)
1036 (if (member (car r) lst =)
1037 (lp0 (cdr r) acc)
1038 (lp0 (cdr r) (cons (car r) acc)))))
1039 (if (member (car l) res =)
1040 (lp (cdr l) acc)
1041 (lp (cdr l) (cons (car l) acc))))))
1042 '()
1043 rest))
1045 (define (lset-diff+intersection = list1 . rest)
1046 (let lp ((l list1) (accd '()) (acci '()))
1047 (if (null? l)
1048 (values (reverse! accd) (reverse! acci))
1049 (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
1050 (if appears
1051 (lp (cdr l) accd (cons (car l) acci))
1052 (lp (cdr l) (cons (car l) accd) acci))))))
1055 (define (lset-union! = . rest)
1056 (apply lset-union = rest)) ; XXX:optimize
1058 (define (lset-intersection! = list1 . rest)
1059 (apply lset-intersection = list1 rest)) ; XXX:optimize
1061 (define (lset-difference! = list1 . rest)
1062 (apply lset-difference = list1 rest)) ; XXX:optimize
1064 (define (lset-xor! = . rest)
1065 (apply lset-xor = rest)) ; XXX:optimize
1067 (define (lset-diff+intersection! = list1 . rest)
1068 (apply lset-diff+intersection = list1 rest)) ; XXX:optimize
1070 ;;; srfi-1.scm ends here