srfi/srfi-1.scm

   1 ;;; srfi-1.scm --- List Library
   2
   3 ;;      Copyright (C) 2001, 2002, 2003 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 2.1 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library 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 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  18
  19 ;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
  20 ;;; Date: 2001-06-06
  21
  22 ;;; Commentary:
  23
  24 ;; This is an implementation of SRFI-1 (List Library).
  25 ;;
  26 ;; All procedures defined in SRFI-1, which are not already defined in
  27 ;; the Guile core library, are exported.  The procedures in this
  28 ;; implementation work, but they have not been tuned for speed or
  29 ;; memory usage.
  30 ;;
  31 ;; This module is fully documented in the Guile Reference Manual.
  32
  33 ;;; Code:
  34
  35 (define-module (srfi srfi-1)
  36   :use-module (ice-9 session)
  37   :use-module (ice-9 receive)
  38   :export (
  39 ;;; Constructors
  40  ;; cons                                <= in the core
  41  ;; list                                <= in the core
  42  xcons
  43  ;; cons*                               <= in the core
  44  ;; make-list                           <= in the core
  45  list-tabulate
  46  ;; list-copy                           <= in the core
  47  circular-list
  48  ;; iota                                ; Extended.
  49
  50 ;;; Predicates
  51  proper-list?
  52  circular-list?
  53  dotted-list?
  54  ;; pair?                               <= in the core
  55  ;; null?                               <= in the core
  56  null-list?
  57  not-pair?
  58  list=
  59
  60 ;;; Selectors
  61  ;; car                                 <= in the core
  62  ;; cdr                                 <= in the core
  63  ;; caar                                <= in the core
  64  ;; cadr                                <= in the core
  65  ;; cdar                                <= in the core
  66  ;; cddr                                <= in the core
  67  ;; caaar                               <= in the core
  68  ;; caadr                               <= in the core
  69  ;; cadar                               <= in the core
  70  ;; caddr                               <= in the core
  71  ;; cdaar                               <= in the core
  72  ;; cdadr                               <= in the core
  73  ;; cddar                               <= in the core
  74  ;; cdddr                               <= in the core
  75  ;; caaaar                              <= in the core
  76  ;; caaadr                              <= in the core
  77  ;; caadar                              <= in the core
  78  ;; caaddr                              <= in the core
  79  ;; cadaar                              <= in the core
  80  ;; cadadr                              <= in the core
  81  ;; caddar                              <= in the core
  82  ;; cadddr                              <= in the core
  83  ;; cdaaar                              <= in the core
  84  ;; cdaadr                              <= in the core
  85  ;; cdadar                              <= in the core
  86  ;; cdaddr                              <= in the core
  87  ;; cddaar                              <= in the core
  88  ;; cddadr                              <= in the core
  89  ;; cdddar                              <= in the core
  90  ;; cddddr                              <= in the core
  91  ;; list-ref                            <= in the core
  92  first
  93  second
  94  third
  95  fourth
  96  fifth
  97  sixth
  98  seventh
  99  eighth
 100  ninth
 101  tenth
 102  car+cdr
 103  take
 104  drop
 105  take-right
 106  drop-right
 107  take!
 108  drop-right!
 109  split-at
 110  split-at!
 111  last
 112  ;; last-pair                           <= in the core
 113
 114 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
 115  ;; length                              <= in the core
 116  length+
 117  ;; append                              <= in the core
 118  ;; append!                             <= in the core
 119  concatenate
 120  concatenate!
 121  ;; reverse                             <= in the core
 122  ;; reverse!                            <= in the core
 123  append-reverse
 124  append-reverse!
 125  zip
 126  unzip1
 127  unzip2
 128  unzip3
 129  unzip4
 130  unzip5
 131  count
 132
 133 ;;; Fold, unfold & map
 134  fold
 135  fold-right
 136  pair-fold
 137  pair-fold-right
 138  reduce
 139  reduce-right
 140  unfold
 141  unfold-right
 142  ;; map                                 ; Extended.
 143  ;; for-each                            ; Extended.
 144  append-map
 145  append-map!
 146  map!
 147  ;; map-in-order                        ; Extended.
 148  pair-for-each
 149  filter-map
 150
 151 ;;; Filtering & partitioning
 152  ;; filter                              <= in the core
 153  partition
 154  remove
 155  ;; filter!                             <= in the core
 156  partition!
 157  remove!
 158
 159 ;;; Searching
 160  find
 161  find-tail
 162  take-while
 163  take-while!
 164  drop-while
 165  span
 166  span!
 167  break
 168  break!
 169  any
 170  every
 171  ;; list-index                          ; Extended.
 172  ;; member                              ; Extended.
 173  ;; memq                                <= in the core
 174  ;; memv                                <= in the core
 175
 176 ;;; Deletion
 177  ;; delete                              ; Extended.
 178  ;; delete!                             ; Extended.
 179  delete-duplicates
 180  delete-duplicates!
 181
 182 ;;; Association lists
 183  ;; assoc                               ; Extended.
 184  ;; assq                                <= in the core
 185  ;; assv                                <= in the core
 186  alist-cons
 187  alist-copy
 188  alist-delete
 189  alist-delete!
 190
 191 ;;; Set operations on lists
 192  lset<=
 193  lset=
 194  lset-adjoin
 195  lset-union
 196  lset-intersection
 197  lset-difference
 198  lset-xor
 199  lset-diff+intersection
 200  lset-union!
 201  lset-intersection!
 202  lset-difference!
 203  lset-xor!
 204  lset-diff+intersection!
 205
 206 ;;; Primitive side-effects
 207  ;; set-car!                            <= in the core
 208  ;; set-cdr!                            <= in the core
 209  )
 210   :re-export (cons list cons* make-list list-copy pair? null?
 211               car cdr caar cadr cdar cddr
 212               caaar caadr cadar caddr cdaar cdadr cddar cdddr
 213               caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
 214               cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
 215               list-ref last-pair length append append! reverse reverse!
 216               filter filter! memq memv assq assv set-car! set-cdr!)
 217   :replace (iota map for-each map-in-order list-index member
 218             delete delete! assoc)
 219   )
 220
 221 (cond-expand-provide (current-module) '(srfi-1))
 222
 223 ;; Load the compiled primitives from the shared library.
 224 ;;
 225 (load-extension "libguile-srfi-srfi-1" "scm_init_srfi_1")
 226
 227
 228 ;;; Constructors
 229
 230 (define (xcons d a)
 231   (cons a d))
 232
 233 ;; internal helper, similar to (scsh utilities) check-arg.
 234 (define (check-arg-type pred arg caller)
 235   (if (pred arg)
 236       arg
 237       (scm-error 'wrong-type-arg caller
 238                  "Wrong type argument: ~S" (list arg) '())))
 239
 240 ;; the srfi spec doesn't seem to forbid inexact integers.
 241 (define (non-negative-integer? x) (and (integer? x) (>= x 0)))
 242
 243 (define (list-tabulate n init-proc)
 244   (check-arg-type non-negative-integer? n "list-tabulate")
 245   (let lp ((n n) (acc '()))
 246     (if (<= n 0)
 247       acc
 248       (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
 249
 250 (define (circular-list elt1 . rest)
 251   (let ((start (cons elt1 '())))
 252     (let lp ((r rest) (p start))
 253       (if (null? r)
 254         (begin
 255           (set-cdr! p start)
 256           start)
 257         (begin
 258           (set-cdr! p (cons (car r) '()))
 259           (lp (cdr r) (cdr p)))))))
 260
 261 (define (iota count . rest)
 262   (check-arg-type non-negative-integer? count "iota")
 263   (let ((start (if (pair? rest) (car rest) 0))
 264         (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1)))
 265     (let lp ((n 0) (acc '()))
 266       (if (= n count)
 267         (reverse! acc)
 268         (lp (+ n 1) (cons (+ start (* n step)) acc))))))
 269
 270 ;;; Predicates
 271
 272 (define (proper-list? x)
 273   (list? x))
 274
 275 (define (circular-list? x)
 276   (if (not-pair? x)
 277     #f
 278     (let lp ((hare (cdr x)) (tortoise x))
 279       (if (not-pair? hare)
 280         #f
 281         (let ((hare (cdr hare)))
 282           (if (not-pair? hare)
 283             #f
 284             (if (eq? hare tortoise)
 285               #t
 286               (lp (cdr hare) (cdr tortoise)))))))))
 287
 288 (define (dotted-list? x)
 289   (cond
 290     ((null? x) #f)
 291     ((not-pair? x) #t)
 292     (else
 293      (let lp ((hare (cdr x)) (tortoise x))
 294        (cond
 295          ((null? hare) #f)
 296          ((not-pair? hare) #t)
 297          (else
 298           (let ((hare (cdr hare)))
 299             (cond
 300               ((null? hare) #f)
 301               ((not-pair? hare) #t)
 302               ((eq? hare tortoise) #f)
 303               (else
 304                (lp (cdr hare) (cdr tortoise)))))))))))
 305
 306 (define (null-list? x)
 307   (cond
 308     ((proper-list? x)
 309      (null? x))
 310     ((circular-list? x)
 311      #f)
 312     (else
 313      (error "not a proper list in null-list?"))))
 314
 315 (define (not-pair? x)
 316   (not (pair? x)))
 317
 318 (define (list= elt= . rest)
 319   (define (lists-equal a b)
 320     (let lp ((a a) (b b))
 321       (cond ((null? a)
 322              (null? b))
 323             ((null? b)
 324              #f)
 325             (else
 326              (and (elt= (car a) (car b))
 327                   (lp (cdr a) (cdr b)))))))
 328   (or (null? rest)
 329       (let ((first (car rest)))
 330         (let lp ((lists rest))
 331           (or (null? lists)
 332               (and (lists-equal first (car lists))
 333                    (lp (cdr lists))))))))
 334
 335 ;;; Selectors
 336
 337 (define first car)
 338 (define second cadr)
 339 (define third caddr)
 340 (define fourth cadddr)
 341 (define (fifth x) (car (cddddr x)))
 342 (define (sixth x) (cadr (cddddr x)))
 343 (define (seventh x) (caddr (cddddr x)))
 344 (define (eighth x) (cadddr (cddddr x)))
 345 (define (ninth x) (car (cddddr (cddddr x))))
 346 (define (tenth x) (cadr (cddddr (cddddr x))))
 347
 348 (define (car+cdr x) (values (car x) (cdr x)))
 349
 350 (define take list-head)
 351 (define drop list-tail)
 352
 353 (define (take-right flist i)
 354   (let lp ((n i) (l flist))
 355     (if (<= n 0)
 356       (let lp0 ((s flist) (l l))
 357         (if (null? l)
 358           s
 359           (lp0 (cdr s) (cdr l))))
 360       (lp (- n 1) (cdr l)))))
 361
 362 (define (drop-right flist i)
 363   (let lp ((n i) (l flist))
 364     (if (<= n 0)
 365       (let lp0 ((s flist) (l l) (acc '()))
 366         (if (null? l)
 367           (reverse! acc)
 368           (lp0 (cdr s) (cdr l) (cons (car s) acc))))
 369       (lp (- n 1) (cdr l)))))
 370
 371 (define (take! x i)
 372   (if (<= i 0)
 373     '()
 374     (let lp ((n (- i 1)) (l x))
 375       (if (<= n 0)
 376         (begin
 377           (set-cdr! l '())
 378           x)
 379         (lp (- n 1) (cdr l))))))
 380
 381 (define (drop-right! flist i)
 382   (if (<= i 0)
 383     flist
 384     (let lp ((n (+ i 1)) (l flist))
 385       (if (<= n 0)
 386         (let lp0 ((s flist) (l l))
 387           (if (null? l)
 388             (begin
 389               (set-cdr! s '())
 390               flist)
 391             (lp0 (cdr s) (cdr l))))
 392         (if (null? l)
 393           '()
 394           (lp (- n 1) (cdr l)))))))
 395
 396 (define (split-at x i)
 397   (let lp ((l x) (n i) (acc '()))
 398     (if (<= n 0)
 399       (values (reverse! acc) l)
 400       (lp (cdr l) (- n 1) (cons (car l) acc)))))
 401
 402 (define (split-at! x i)
 403   (if (<= i 0)
 404     (values '() x)
 405     (let lp ((l x) (n (- i 1)))
 406       (if (<= n 0)
 407         (let ((tmp (cdr l)))
 408           (set-cdr! l '())
 409           (values x tmp))
 410         (lp (cdr l) (- n 1))))))
 411
 412 (define (last pair)
 413   (car (last-pair pair)))
 414
 415 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
 416
 417 (define (length+ clist)
 418   (if (null? clist)
 419     0
 420     (let lp ((hare (cdr clist)) (tortoise clist) (l 1))
 421       (if (null? hare)
 422         l
 423         (let ((hare (cdr hare)))
 424           (if (null? hare)
 425             (+ l 1)
 426             (if (eq? hare tortoise)
 427               #f
 428               (lp (cdr hare) (cdr tortoise) (+ l 2)))))))))
 429
 430 (define (concatenate l-o-l)
 431   (let lp ((l l-o-l) (acc '()))
 432     (if (null? l)
 433       (reverse! acc)
 434       (let lp0 ((ll (car l)) (acc acc))
 435         (if (null? ll)
 436           (lp (cdr l) acc)
 437           (lp0 (cdr ll) (cons (car ll) acc)))))))
 438
 439 (define (concatenate! l-o-l)
 440   (let lp0 ((l-o-l l-o-l))
 441     (cond
 442       ((null? l-o-l)
 443        '())
 444       ((null? (car l-o-l))
 445        (lp0 (cdr l-o-l)))
 446       (else
 447        (let ((result (car l-o-l)) (tail (last-pair (car l-o-l))))
 448          (let lp ((l (cdr l-o-l)) (ntail tail))
 449            (if (null? l)
 450              result
 451              (begin
 452                (set-cdr! ntail (car l))
 453                (lp (cdr l) (last-pair ntail))))))))))
 454
 455
 456 (define (append-reverse rev-head tail)
 457   (let lp ((l rev-head) (acc tail))
 458     (if (null? l)
 459       acc
 460       (lp (cdr l) (cons (car l) acc)))))
 461
 462 (define (append-reverse! rev-head tail)
 463   (append-reverse rev-head tail))       ; XXX:optimize
 464
 465 (define (zip clist1 . rest)
 466   (let lp ((l (cons clist1 rest)) (acc '()))
 467     (if (any null? l)
 468       (reverse! acc)
 469       (lp (map1 cdr l) (cons (map1 car l) acc)))))
 470
 471
 472 (define (unzip1 l)
 473   (map1 first l))
 474 (define (unzip2 l)
 475   (values (map1 first l) (map1 second l)))
 476 (define (unzip3 l)
 477   (values (map1 first l) (map1 second l) (map1 third l)))
 478 (define (unzip4 l)
 479   (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)))
 480 (define (unzip5 l)
 481   (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)
 482           (map1 fifth l)))
 483
 484 (define (count pred clist1 . rest)
 485   (if (null? rest)
 486       (count1 pred clist1)
 487       (let lp ((lists (cons clist1 rest)))
 488         (cond ((any1 null? lists)
 489                0)
 490               (else
 491                (if (apply pred (map1 car lists))
 492                  (+ 1 (lp (map1 cdr lists)))
 493                  (lp (map1 cdr lists))))))))
 494
 495 (define (count1 pred clist)
 496   (let lp ((result 0) (rest clist))
 497     (if (null? rest)
 498         result
 499         (if (pred (car rest))
 500             (lp (+ 1 result) (cdr rest))
 501             (lp result (cdr rest))))))
 502
 503 ;;; Fold, unfold & map
 504
 505 (define (fold kons knil list1 . rest)
 506   (if (null? rest)
 507       (let f ((knil knil) (list1 list1))
 508         (if (null? list1)
 509             knil
 510             (f (kons (car list1) knil) (cdr list1))))
 511       (let f ((knil knil) (lists (cons list1 rest)))
 512         (if (any null? lists)
 513             knil
 514             (let ((cars (map1 car lists))
 515                   (cdrs (map1 cdr lists)))
 516               (f (apply kons (append! cars (list knil))) cdrs))))))
 517
 518 (define (fold-right kons knil clist1 . rest)
 519   (if (null? rest)
 520     (let f ((list1 clist1))
 521       (if (null? list1)
 522         knil
 523         (kons (car list1) (f (cdr list1)))))
 524     (let f ((lists (cons clist1 rest)))
 525       (if (any null? lists)
 526         knil
 527         (apply kons (append! (map1 car lists) (list (f (map1 cdr lists)))))))))
 528
 529 (define (pair-fold kons knil clist1 . rest)
 530   (if (null? rest)
 531       (let f ((knil knil) (list1 clist1))
 532         (if (null? list1)
 533             knil
 534             (let ((tail (cdr list1)))
 535             (f (kons list1 knil) tail))))
 536       (let f ((knil knil) (lists (cons clist1 rest)))
 537         (if (any null? lists)
 538             knil
 539             (let ((tails (map1 cdr lists)))
 540               (f (apply kons (append! lists (list knil))) tails))))))
 541
 542
 543 (define (pair-fold-right kons knil clist1 . rest)
 544   (if (null? rest)
 545     (let f ((list1 clist1))
 546       (if (null? list1)
 547         knil
 548         (kons list1 (f (cdr list1)))))
 549     (let f ((lists (cons clist1 rest)))
 550       (if (any null? lists)
 551         knil
 552         (apply kons (append! lists (list (f (map1 cdr lists)))))))))
 553
 554 (define (unfold p f g seed . rest)
 555   (let ((tail-gen (if (pair? rest)
 556                       (if (pair? (cdr rest))
 557                           (scm-error 'wrong-number-of-args
 558                                      "unfold" "too many arguments" '() '())
 559                           (car rest))
 560                       (lambda (x) '()))))
 561     (let uf ((seed seed))
 562       (if (p seed)
 563           (tail-gen seed)
 564           (cons (f seed)
 565                 (uf (g seed)))))))
 566
 567 (define (unfold-right p f g seed . rest)
 568   (let ((tail (if (pair? rest)
 569                   (if (pair? (cdr rest))
 570                       (scm-error 'wrong-number-of-args
 571                                      "unfold-right" "too many arguments" '()
 572                                      '())
 573                       (car rest))
 574                       '())))
 575     (let uf ((seed seed) (lis tail))
 576       (if (p seed)
 577           lis
 578           (uf (g seed) (cons (f seed) lis))))))
 579
 580 (define (reduce f ridentity lst)
 581   (fold f ridentity lst))
 582
 583 (define (reduce-right f ridentity lst)
 584   (fold-right f ridentity lst))
 585
 586
 587 ;; Internal helper procedure.  Map `f' over the single list `ls'.
 588 ;;
 589 (define map1 map)
 590
 591 (define (append-map f clist1 . rest)
 592   (if (null? rest)
 593     (let lp ((l clist1))
 594       (if (null? l)
 595         '()
 596         (append (f (car l)) (lp (cdr l)))))
 597     (let lp ((l (cons clist1 rest)))
 598       (if (any1 null? l)
 599         '()
 600         (append (apply f (map1 car l)) (lp (map1 cdr l)))))))
 601
 602
 603 (define (append-map! f clist1 . rest)
 604   (if (null? rest)
 605     (let lp ((l clist1))
 606       (if (null? l)
 607         '()
 608         (append! (f (car l)) (lp (cdr l)))))
 609     (let lp ((l (cons clist1 rest)))
 610       (if (any1 null? l)
 611         '()
 612         (append! (apply f (map1 car l)) (lp (map1 cdr l)))))))
 613
 614 (define (map! f list1 . rest)
 615   (if (null? rest)
 616     (let lp ((l list1))
 617       (if (null? l)
 618         '()
 619         (begin
 620           (set-car! l (f (car l)))
 621           (set-cdr! l (lp (cdr l)))
 622           l)))
 623     (let lp ((l (cons list1 rest)) (res list1))
 624       (if (any1 null? l)
 625         '()
 626         (begin
 627           (set-car! res (apply f (map1 car l)))
 628           (set-cdr! res (lp (map1 cdr l) (cdr res)))
 629           res)))))
 630
 631 (define (pair-for-each f clist1 . rest)
 632   (if (null? rest)
 633     (let lp ((l clist1))
 634       (if (null? l)
 635         (if #f #f)
 636         (begin
 637           (f l)
 638           (lp (cdr l)))))
 639     (let lp ((l (cons clist1 rest)))
 640       (if (any1 null? l)
 641         (if #f #f)
 642         (begin
 643           (apply f l)
 644           (lp (map1 cdr l)))))))
 645
 646 (define (filter-map f clist1 . rest)
 647   (if (null? rest)
 648     (let lp ((l clist1))
 649       (if (null? l)
 650         '()
 651         (let ((res (f (car l))))
 652           (if res
 653             (cons res (lp (cdr l)))
 654             (lp (cdr l))))))
 655     (let lp ((l (cons clist1 rest)))
 656       (if (any1 null? l)
 657         '()
 658         (let ((res (apply f (map1 car l))))
 659           (if res
 660             (cons res (lp (map1 cdr l)))
 661             (lp (map1 cdr l))))))))
 662
 663 ;;; Filtering & partitioning
 664
 665 (define (partition pred list)
 666   (if (null? list)
 667     (values '() '())
 668     (if (pred (car list))
 669       (receive (in out) (partition pred (cdr list))
 670                (values (cons (car list) in) out))
 671       (receive (in out) (partition pred (cdr list))
 672                (values in (cons (car list) out))))))
 673
 674 (define (remove pred list)
 675   (filter (lambda (x) (not (pred x))) list))
 676
 677 (define (partition! pred list)
 678   (partition pred list))                ; XXX:optimize
 679
 680 (define (remove! pred list)
 681   (remove pred list))                   ; XXX:optimize
 682
 683 ;;; Searching
 684
 685 (define (find pred clist)
 686   (if (null? clist)
 687     #f
 688     (if (pred (car clist))
 689       (car clist)
 690       (find pred (cdr clist)))))
 691
 692 (define (find-tail pred clist)
 693   (if (null? clist)
 694     #f
 695     (if (pred (car clist))
 696       clist
 697       (find-tail pred (cdr clist)))))
 698
 699 (define (take-while pred ls)
 700   (cond ((null? ls) '())
 701         ((not (pred (car ls))) '())
 702         (else
 703          (let ((result (list (car ls))))
 704            (let lp ((ls (cdr ls)) (p result))
 705              (cond ((null? ls) result)
 706                    ((not (pred (car ls))) result)
 707                    (else
 708                     (set-cdr! p (list (car ls)))
 709                     (lp (cdr ls) (cdr p)))))))))
 710
 711 (define (take-while! pred clist)
 712   (take-while pred clist))              ; XXX:optimize
 713
 714 (define (drop-while pred clist)
 715   (if (null? clist)
 716     '()
 717     (if (pred (car clist))
 718       (drop-while pred (cdr clist))
 719       clist)))
 720
 721 (define (span pred clist)
 722   (if (null? clist)
 723     (values '() '())
 724     (if (pred (car clist))
 725       (receive (first last) (span pred (cdr clist))
 726                (values (cons (car clist) first) last))
 727       (values '() clist))))
 728
 729 (define (span! pred list)
 730   (span pred list))                     ; XXX:optimize
 731
 732 (define (break pred clist)
 733   (if (null? clist)
 734     (values '() '())
 735     (if (pred (car clist))
 736       (values '() clist)
 737       (receive (first last) (break pred (cdr clist))
 738                (values (cons (car clist) first) last)))))
 739
 740 (define (break! pred list)
 741   (break pred list))                    ; XXX:optimize
 742
 743 (define (any pred ls . lists)
 744   (if (null? lists)
 745       (any1 pred ls)
 746       (let lp ((lists (cons ls lists)))
 747         (cond ((any1 null? lists)
 748                #f)
 749               ((any1 null? (map1 cdr lists))
 750                (apply pred (map1 car lists)))
 751               (else
 752                (or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
 753
 754 (define (any1 pred ls)
 755   (let lp ((ls ls))
 756     (cond ((null? ls)
 757            #f)
 758           ((null? (cdr ls))
 759            (pred (car ls)))
 760           (else
 761            (or (pred (car ls)) (lp (cdr ls)))))))
 762
 763 (define (every pred ls . lists)
 764   (if (null? lists)
 765       (every1 pred ls)
 766       (let lp ((lists (cons ls lists)))
 767         (cond ((any1 null? lists)
 768                #t)
 769               ((any1 null? (map1 cdr lists))
 770                (apply pred (map1 car lists)))
 771               (else
 772                (and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
 773
 774 (define (every1 pred ls)
 775   (let lp ((ls ls))
 776     (cond ((null? ls)
 777            #t)
 778           ((null? (cdr ls))
 779            (pred (car ls)))
 780           (else
 781            (and (pred (car ls)) (lp (cdr ls)))))))
 782
 783 (define (list-index pred clist1 . rest)
 784   (if (null? rest)
 785     (let lp ((l clist1) (i 0))
 786       (if (null? l)
 787         #f
 788         (if (pred (car l))
 789           i
 790           (lp (cdr l) (+ i 1)))))
 791     (let lp ((lists (cons clist1 rest)) (i 0))
 792       (cond ((any1 null? lists)
 793              #f)
 794             ((apply pred (map1 car lists)) i)
 795             (else
 796              (lp (map1 cdr lists) (+ i 1)))))))
 797
 798 ;;; Association lists
 799
 800 (define (alist-cons key datum alist)
 801   (acons key datum alist))
 802
 803 (define (alist-copy alist)
 804   (let lp ((a alist))
 805     (if (null? a)
 806       '()
 807       (acons (caar a) (cdar a) (lp (cdr a))))))
 808
 809 (define (alist-delete key alist . rest)
 810   (let ((k= (if (pair? rest) (car rest) equal?)))
 811     (let lp ((a alist))
 812       (if (null? a)
 813         '()
 814         (if (k= (caar a) key)
 815           (lp (cdr a))
 816           (cons (car a) (lp (cdr a))))))))
 817
 818 (define (alist-delete! key alist . rest)
 819   (let ((k= (if (pair? rest) (car rest) equal?)))
 820     (alist-delete key alist k=)))       ; XXX:optimize
 821
 822 ;;; Set operations on lists
 823
 824 (define (lset<= = . rest)
 825   (if (null? rest)
 826     #t
 827     (let lp ((f (car rest)) (r (cdr rest)))
 828       (or (null? r)
 829           (and (every (lambda (el) (member el (car r) =)) f)
 830                (lp (car r) (cdr r)))))))
 831
 832 (define (lset= = list1 . rest)
 833   (if (null? rest)
 834     #t
 835     (let lp ((f list1) (r rest))
 836       (or (null? r)
 837           (and (every (lambda (el) (member el (car r) =)) f)
 838                (every (lambda (el) (member el f =)) (car r))
 839                (lp (car r) (cdr r)))))))
 840
 841 (define (lset-adjoin = list . rest)
 842   (let lp ((l rest) (acc list))
 843     (if (null? l)
 844       acc
 845       (if (member (car l) acc)
 846         (lp (cdr l) acc)
 847         (lp (cdr l) (cons (car l) acc))))))
 848
 849 (define (lset-union = . rest)
 850   (let lp0 ((l rest) (acc '()))
 851     (if (null? l)
 852       (reverse! acc)
 853       (let lp1 ((ll (car l)) (acc acc))
 854         (if (null? ll)
 855           (lp0 (cdr l) acc)
 856           (if (member (car ll) acc =)
 857             (lp1 (cdr ll) acc)
 858             (lp1 (cdr ll) (cons (car ll) acc))))))))
 859
 860 (define (lset-intersection = list1 . rest)
 861   (let lp ((l list1) (acc '()))
 862     (if (null? l)
 863       (reverse! acc)
 864       (if (every (lambda (ll) (member (car l) ll =)) rest)
 865         (lp (cdr l) (cons (car l) acc))
 866         (lp (cdr l) acc)))))
 867
 868 (define (lset-difference = list1 . rest)
 869   (if (null? rest)
 870     list1
 871     (let lp ((l list1) (acc '()))
 872       (if (null? l)
 873         (reverse! acc)
 874         (if (any (lambda (ll) (member (car l) ll =)) rest)
 875           (lp (cdr l) acc)
 876           (lp (cdr l) (cons (car l) acc)))))))
 877
 878 ;(define (fold kons knil list1 . rest)
 879
 880 (define (lset-xor = . rest)
 881   (fold (lambda (lst res)
 882           (let lp ((l lst) (acc '()))
 883             (if (null? l)
 884               (let lp0 ((r res) (acc acc))
 885                 (if (null? r)
 886                   (reverse! acc)
 887                   (if (member (car r) lst =)
 888                     (lp0 (cdr r) acc)
 889                     (lp0 (cdr r) (cons (car r) acc)))))
 890               (if (member (car l) res =)
 891                 (lp (cdr l) acc)
 892                 (lp (cdr l) (cons (car l) acc))))))
 893         '()
 894         rest))
 895
 896 (define (lset-diff+intersection = list1 . rest)
 897   (let lp ((l list1) (accd '()) (acci '()))
 898     (if (null? l)
 899       (values (reverse! accd) (reverse! acci))
 900       (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
 901         (if appears
 902           (lp (cdr l) accd (cons (car l) acci))
 903           (lp (cdr l) (cons (car l) accd) acci))))))
 904
 905
 906 (define (lset-union! = . rest)
 907   (apply lset-union = rest))            ; XXX:optimize
 908
 909 (define (lset-intersection! = list1 . rest)
 910   (apply lset-intersection = list1 rest)) ; XXX:optimize
 911
 912 (define (lset-difference! = list1 . rest)
 913   (apply lset-difference = list1 rest)) ; XXX:optimize
 914
 915 (define (lset-xor! = . rest)
 916   (apply lset-xor = rest))              ; XXX:optimize
 917
 918 (define (lset-diff+intersection! = list1 . rest)
 919   (apply lset-diff+intersection = list1 rest)) ; XXX:optimize
 920
 921 ;;; srfi-1.scm ends here