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 o ;; 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 x i)
 351   (let lp ((n i) (l x) (acc '()))
 352     (if (<= n 0)
 353       (reverse! acc)
 354       (lp (- n 1) (cdr l) (cons (car l) acc)))))
 355 (define (drop x i)
 356   (let lp ((n i) (l x))
 357     (if (<= n 0)
 358       l
 359       (lp (- n 1) (cdr l)))))
 360 (define (take-right flist i)
 361   (let lp ((n i) (l flist))
 362     (if (<= n 0)
 363       (let lp0 ((s flist) (l l))
 364         (if (null? l)
 365           s
 366           (lp0 (cdr s) (cdr l))))
 367       (lp (- n 1) (cdr l)))))
 368
 369 (define (drop-right flist i)
 370   (let lp ((n i) (l flist))
 371     (if (<= n 0)
 372       (let lp0 ((s flist) (l l) (acc '()))
 373         (if (null? l)
 374           (reverse! acc)
 375           (lp0 (cdr s) (cdr l) (cons (car s) acc))))
 376       (lp (- n 1) (cdr l)))))
 377
 378 (define (take! x i)
 379   (if (<= i 0)
 380     '()
 381     (let lp ((n (- i 1)) (l x))
 382       (if (<= n 0)
 383         (begin
 384           (set-cdr! l '())
 385           x)
 386         (lp (- n 1) (cdr l))))))
 387
 388 (define (drop-right! flist i)
 389   (if (<= i 0)
 390     flist
 391     (let lp ((n (+ i 1)) (l flist))
 392       (if (<= n 0)
 393         (let lp0 ((s flist) (l l))
 394           (if (null? l)
 395             (begin
 396               (set-cdr! s '())
 397               flist)
 398             (lp0 (cdr s) (cdr l))))
 399         (if (null? l)
 400           '()
 401           (lp (- n 1) (cdr l)))))))
 402
 403 (define (split-at x i)
 404   (let lp ((l x) (n i) (acc '()))
 405     (if (<= n 0)
 406       (values (reverse! acc) l)
 407       (lp (cdr l) (- n 1) (cons (car l) acc)))))
 408
 409 (define (split-at! x i)
 410   (if (<= i 0)
 411     (values '() x)
 412     (let lp ((l x) (n (- i 1)))
 413       (if (<= n 0)
 414         (let ((tmp (cdr l)))
 415           (set-cdr! l '())
 416           (values x tmp))
 417         (lp (cdr l) (- n 1))))))
 418
 419 (define (last pair)
 420   (car (last-pair pair)))
 421
 422 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
 423
 424 (define (length+ clist)
 425   (if (null? clist)
 426     0
 427     (let lp ((hare (cdr clist)) (tortoise clist) (l 1))
 428       (if (null? hare)
 429         l
 430         (let ((hare (cdr hare)))
 431           (if (null? hare)
 432             (+ l 1)
 433             (if (eq? hare tortoise)
 434               #f
 435               (lp (cdr hare) (cdr tortoise) (+ l 2)))))))))
 436
 437 (define (concatenate l-o-l)
 438   (let lp ((l l-o-l) (acc '()))
 439     (if (null? l)
 440       (reverse! acc)
 441       (let lp0 ((ll (car l)) (acc acc))
 442         (if (null? ll)
 443           (lp (cdr l) acc)
 444           (lp0 (cdr ll) (cons (car ll) acc)))))))
 445
 446 (define (concatenate! l-o-l)
 447   (let lp0 ((l-o-l l-o-l))
 448     (cond
 449       ((null? l-o-l)
 450        '())
 451       ((null? (car l-o-l))
 452        (lp0 (cdr l-o-l)))
 453       (else
 454        (let ((result (car l-o-l)) (tail (last-pair (car l-o-l))))
 455          (let lp ((l (cdr l-o-l)) (ntail tail))
 456            (if (null? l)
 457              result
 458              (begin
 459                (set-cdr! ntail (car l))
 460                (lp (cdr l) (last-pair ntail))))))))))
 461
 462
 463 (define (append-reverse rev-head tail)
 464   (let lp ((l rev-head) (acc tail))
 465     (if (null? l)
 466       acc
 467       (lp (cdr l) (cons (car l) acc)))))
 468
 469 (define (append-reverse! rev-head tail)
 470   (append-reverse rev-head tail))       ; XXX:optimize
 471
 472 (define (zip clist1 . rest)
 473   (let lp ((l (cons clist1 rest)) (acc '()))
 474     (if (any null? l)
 475       (reverse! acc)
 476       (lp (map1 cdr l) (cons (map1 car l) acc)))))
 477
 478
 479 (define (unzip1 l)
 480   (map1 first l))
 481 (define (unzip2 l)
 482   (values (map1 first l) (map1 second l)))
 483 (define (unzip3 l)
 484   (values (map1 first l) (map1 second l) (map1 third l)))
 485 (define (unzip4 l)
 486   (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)))
 487 (define (unzip5 l)
 488   (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)
 489           (map1 fifth l)))
 490
 491 (define (count pred clist1 . rest)
 492   (if (null? rest)
 493       (count1 pred clist1)
 494       (let lp ((lists (cons clist1 rest)))
 495         (cond ((any1 null? lists)
 496                0)
 497               (else
 498                (if (apply pred (map1 car lists))
 499                  (+ 1 (lp (map1 cdr lists)))
 500                  (lp (map1 cdr lists))))))))
 501
 502 (define (count1 pred clist)
 503   (let lp ((result 0) (rest clist))
 504     (if (null? rest)
 505         result
 506         (if (pred (car rest))
 507             (lp (+ 1 result) (cdr rest))
 508             (lp result (cdr rest))))))
 509
 510 ;;; Fold, unfold & map
 511
 512 (define (fold kons knil list1 . rest)
 513   (if (null? rest)
 514       (let f ((knil knil) (list1 list1))
 515         (if (null? list1)
 516             knil
 517             (f (kons (car list1) knil) (cdr list1))))
 518       (let f ((knil knil) (lists (cons list1 rest)))
 519         (if (any null? lists)
 520             knil
 521             (let ((cars (map1 car lists))
 522                   (cdrs (map1 cdr lists)))
 523               (f (apply kons (append! cars (list knil))) cdrs))))))
 524
 525 (define (fold-right kons knil clist1 . rest)
 526   (if (null? rest)
 527     (let f ((list1 clist1))
 528       (if (null? list1)
 529         knil
 530         (kons (car list1) (f (cdr list1)))))
 531     (let f ((lists (cons clist1 rest)))
 532       (if (any null? lists)
 533         knil
 534         (apply kons (append! (map1 car lists) (list (f (map1 cdr lists)))))))))
 535
 536 (define (pair-fold kons knil clist1 . rest)
 537   (if (null? rest)
 538       (let f ((knil knil) (list1 clist1))
 539         (if (null? list1)
 540             knil
 541             (let ((tail (cdr list1)))
 542             (f (kons list1 knil) tail))))
 543       (let f ((knil knil) (lists (cons clist1 rest)))
 544         (if (any null? lists)
 545             knil
 546             (let ((tails (map1 cdr lists)))
 547               (f (apply kons (append! lists (list knil))) tails))))))
 548
 549
 550 (define (pair-fold-right kons knil clist1 . rest)
 551   (if (null? rest)
 552     (let f ((list1 clist1))
 553       (if (null? list1)
 554         knil
 555         (kons list1 (f (cdr list1)))))
 556     (let f ((lists (cons clist1 rest)))
 557       (if (any null? lists)
 558         knil
 559         (apply kons (append! lists (list (f (map1 cdr lists)))))))))
 560
 561 (define (unfold p f g seed . rest)
 562   (let ((tail-gen (if (pair? rest)
 563                       (if (pair? (cdr rest))
 564                           (scm-error 'wrong-number-of-args
 565                                      "unfold" "too many arguments" '() '())
 566                           (car rest))
 567                       (lambda (x) '()))))
 568     (let uf ((seed seed))
 569       (if (p seed)
 570           (tail-gen seed)
 571           (cons (f seed)
 572                 (uf (g seed)))))))
 573
 574 (define (unfold-right p f g seed . rest)
 575   (let ((tail (if (pair? rest)
 576                   (if (pair? (cdr rest))
 577                       (scm-error 'wrong-number-of-args
 578                                      "unfold-right" "too many arguments" '()
 579                                      '())
 580                       (car rest))
 581                       '())))
 582     (let uf ((seed seed) (lis tail))
 583       (if (p seed)
 584           lis
 585           (uf (g seed) (cons (f seed) lis))))))
 586
 587 (define (reduce f ridentity lst)
 588   (fold f ridentity lst))
 589
 590 (define (reduce-right f ridentity lst)
 591   (fold-right f ridentity lst))
 592
 593
 594 ;; Internal helper procedure.  Map `f' over the single list `ls'.
 595 ;;
 596 (define map1 map)
 597
 598 (define (append-map f clist1 . rest)
 599   (if (null? rest)
 600     (let lp ((l clist1))
 601       (if (null? l)
 602         '()
 603         (append (f (car l)) (lp (cdr l)))))
 604     (let lp ((l (cons clist1 rest)))
 605       (if (any1 null? l)
 606         '()
 607         (append (apply f (map1 car l)) (lp (map1 cdr l)))))))
 608
 609
 610 (define (append-map! f clist1 . rest)
 611   (if (null? rest)
 612     (let lp ((l clist1))
 613       (if (null? l)
 614         '()
 615         (append! (f (car l)) (lp (cdr l)))))
 616     (let lp ((l (cons clist1 rest)))
 617       (if (any1 null? l)
 618         '()
 619         (append! (apply f (map1 car l)) (lp (map1 cdr l)))))))
 620
 621 (define (map! f list1 . rest)
 622   (if (null? rest)
 623     (let lp ((l list1))
 624       (if (null? l)
 625         '()
 626         (begin
 627           (set-car! l (f (car l)))
 628           (set-cdr! l (lp (cdr l)))
 629           l)))
 630     (let lp ((l (cons list1 rest)) (res list1))
 631       (if (any1 null? l)
 632         '()
 633         (begin
 634           (set-car! res (apply f (map1 car l)))
 635           (set-cdr! res (lp (map1 cdr l) (cdr res)))
 636           res)))))
 637
 638 (define (pair-for-each f clist1 . rest)
 639   (if (null? rest)
 640     (let lp ((l clist1))
 641       (if (null? l)
 642         (if #f #f)
 643         (begin
 644           (f l)
 645           (lp (cdr l)))))
 646     (let lp ((l (cons clist1 rest)))
 647       (if (any1 null? l)
 648         (if #f #f)
 649         (begin
 650           (apply f l)
 651           (lp (map1 cdr l)))))))
 652
 653 (define (filter-map f clist1 . rest)
 654   (if (null? rest)
 655     (let lp ((l clist1))
 656       (if (null? l)
 657         '()
 658         (let ((res (f (car l))))
 659           (if res
 660             (cons res (lp (cdr l)))
 661             (lp (cdr l))))))
 662     (let lp ((l (cons clist1 rest)))
 663       (if (any1 null? l)
 664         '()
 665         (let ((res (apply f (map1 car l))))
 666           (if res
 667             (cons res (lp (map1 cdr l)))
 668             (lp (map1 cdr l))))))))
 669
 670 ;;; Filtering & partitioning
 671
 672 (define (partition pred list)
 673   (if (null? list)
 674     (values '() '())
 675     (if (pred (car list))
 676       (receive (in out) (partition pred (cdr list))
 677                (values (cons (car list) in) out))
 678       (receive (in out) (partition pred (cdr list))
 679                (values in (cons (car list) out))))))
 680
 681 (define (remove pred list)
 682   (filter (lambda (x) (not (pred x))) list))
 683
 684 (define (partition! pred list)
 685   (partition pred list))                ; XXX:optimize
 686
 687 (define (remove! pred list)
 688   (remove pred list))                   ; XXX:optimize
 689
 690 ;;; Searching
 691
 692 (define (find pred clist)
 693   (if (null? clist)
 694     #f
 695     (if (pred (car clist))
 696       (car clist)
 697       (find pred (cdr clist)))))
 698
 699 (define (find-tail pred clist)
 700   (if (null? clist)
 701     #f
 702     (if (pred (car clist))
 703       clist
 704       (find-tail pred (cdr clist)))))
 705
 706 (define (take-while pred ls)
 707   (cond ((null? ls) '())
 708         ((not (pred (car ls))) '())
 709         (else
 710          (let ((result (list (car ls))))
 711            (let lp ((ls (cdr ls)) (p result))
 712              (cond ((null? ls) result)
 713                    ((not (pred (car ls))) result)
 714                    (else
 715                     (set-cdr! p (list (car ls)))
 716                     (lp (cdr ls) (cdr p)))))))))
 717
 718 (define (take-while! pred clist)
 719   (take-while pred clist))              ; XXX:optimize
 720
 721 (define (drop-while pred clist)
 722   (if (null? clist)
 723     '()
 724     (if (pred (car clist))
 725       (drop-while pred (cdr clist))
 726       clist)))
 727
 728 (define (span pred clist)
 729   (if (null? clist)
 730     (values '() '())
 731     (if (pred (car clist))
 732       (receive (first last) (span pred (cdr clist))
 733                (values (cons (car clist) first) last))
 734       (values '() clist))))
 735
 736 (define (span! pred list)
 737   (span pred list))                     ; XXX:optimize
 738
 739 (define (break pred clist)
 740   (if (null? clist)
 741     (values '() '())
 742     (if (pred (car clist))
 743       (values '() clist)
 744       (receive (first last) (break pred (cdr clist))
 745                (values (cons (car clist) first) last)))))
 746
 747 (define (break! pred list)
 748   (break pred list))                    ; XXX:optimize
 749
 750 (define (any pred ls . lists)
 751   (if (null? lists)
 752       (any1 pred ls)
 753       (let lp ((lists (cons ls lists)))
 754         (cond ((any1 null? lists)
 755                #f)
 756               ((any1 null? (map1 cdr lists))
 757                (apply pred (map1 car lists)))
 758               (else
 759                (or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
 760
 761 (define (any1 pred ls)
 762   (let lp ((ls ls))
 763     (cond ((null? ls)
 764            #f)
 765           ((null? (cdr ls))
 766            (pred (car ls)))
 767           (else
 768            (or (pred (car ls)) (lp (cdr ls)))))))
 769
 770 (define (every pred ls . lists)
 771   (if (null? lists)
 772       (every1 pred ls)
 773       (let lp ((lists (cons ls lists)))
 774         (cond ((any1 null? lists)
 775                #t)
 776               ((any1 null? (map1 cdr lists))
 777                (apply pred (map1 car lists)))
 778               (else
 779                (and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
 780
 781 (define (every1 pred ls)
 782   (let lp ((ls ls))
 783     (cond ((null? ls)
 784            #t)
 785           ((null? (cdr ls))
 786            (pred (car ls)))
 787           (else
 788            (and (pred (car ls)) (lp (cdr ls)))))))
 789
 790 (define (list-index pred clist1 . rest)
 791   (if (null? rest)
 792     (let lp ((l clist1) (i 0))
 793       (if (null? l)
 794         #f
 795         (if (pred (car l))
 796           i
 797           (lp (cdr l) (+ i 1)))))
 798     (let lp ((lists (cons clist1 rest)) (i 0))
 799       (cond ((any1 null? lists)
 800              #f)
 801             ((apply pred (map1 car lists)) i)
 802             (else
 803              (lp (map1 cdr lists) (+ i 1)))))))
 804
 805 ;;; Deletion
 806
 807 (define (delete x list . rest)
 808   (let ((l= (if (pair? rest) (car rest) equal?)))
 809     (let lp ((l list))
 810       (if (null? l)
 811         '()
 812         (if (l= (car l) x)
 813           (lp (cdr l))
 814           (cons (car l) (lp (cdr l))))))))
 815
 816 (define (delete! x list . rest)
 817   (let ((l= (if (pair? rest) (car rest) equal?)))
 818     (delete x list l=)))                ; XXX:optimize
 819
 820 (define (delete-duplicates list . rest)
 821   (let ((l= (if (pair? rest) (car rest) equal?)))
 822     (let lp0 ((l1 list))
 823       (if (null? l1)
 824         '()
 825         (if (let lp1 ((l2 (cdr l1)))
 826               (if (null? l2)
 827                 #f
 828                 (if (l= (car l1) (car l2))
 829                   #t
 830                   (lp1 (cdr l2)))))
 831           (lp0 (cdr l1))
 832           (cons (car l1) (lp0 (cdr l1))))))))
 833
 834 (define (delete-duplicates list . rest)
 835   (let ((l= (if (pair? rest) (car rest) equal?)))
 836     (let lp ((list list))
 837       (if (null? list)
 838         '()
 839         (cons (car list) (lp (delete (car list) (cdr list) l=)))))))
 840
 841 (define (delete-duplicates! list . rest)
 842   (let ((l= (if (pair? rest) (car rest) equal?)))
 843     (delete-duplicates list l=)))       ; XXX:optimize
 844
 845 ;;; Association lists
 846
 847 (define (alist-cons key datum alist)
 848   (acons key datum alist))
 849
 850 (define (alist-copy alist)
 851   (let lp ((a alist))
 852     (if (null? a)
 853       '()
 854       (acons (caar a) (cdar a) (lp (cdr a))))))
 855
 856 (define (alist-delete key alist . rest)
 857   (let ((k= (if (pair? rest) (car rest) equal?)))
 858     (let lp ((a alist))
 859       (if (null? a)
 860         '()
 861         (if (k= (caar a) key)
 862           (lp (cdr a))
 863           (cons (car a) (lp (cdr a))))))))
 864
 865 (define (alist-delete! key alist . rest)
 866   (let ((k= (if (pair? rest) (car rest) equal?)))
 867     (alist-delete key alist k=)))       ; XXX:optimize
 868
 869 ;;; Set operations on lists
 870
 871 (define (lset<= = . rest)
 872   (if (null? rest)
 873     #t
 874     (let lp ((f (car rest)) (r (cdr rest)))
 875       (or (null? r)
 876           (and (every (lambda (el) (member el (car r) =)) f)
 877                (lp (car r) (cdr r)))))))
 878
 879 (define (lset= = list1 . rest)
 880   (if (null? rest)
 881     #t
 882     (let lp ((f list1) (r rest))
 883       (or (null? r)
 884           (and (every (lambda (el) (member el (car r) =)) f)
 885                (every (lambda (el) (member el f =)) (car r))
 886                (lp (car r) (cdr r)))))))
 887
 888 (define (lset-adjoin = list . rest)
 889   (let lp ((l rest) (acc list))
 890     (if (null? l)
 891       acc
 892       (if (member (car l) acc)
 893         (lp (cdr l) acc)
 894         (lp (cdr l) (cons (car l) acc))))))
 895
 896 (define (lset-union = . rest)
 897   (let lp0 ((l rest) (acc '()))
 898     (if (null? l)
 899       (reverse! acc)
 900       (let lp1 ((ll (car l)) (acc acc))
 901         (if (null? ll)
 902           (lp0 (cdr l) acc)
 903           (if (member (car ll) acc =)
 904             (lp1 (cdr ll) acc)
 905             (lp1 (cdr ll) (cons (car ll) acc))))))))
 906
 907 (define (lset-intersection = list1 . rest)
 908   (let lp ((l list1) (acc '()))
 909     (if (null? l)
 910       (reverse! acc)
 911       (if (every (lambda (ll) (member (car l) ll =)) rest)
 912         (lp (cdr l) (cons (car l) acc))
 913         (lp (cdr l) acc)))))
 914
 915 (define (lset-difference = list1 . rest)
 916   (if (null? rest)
 917     list1
 918     (let lp ((l list1) (acc '()))
 919       (if (null? l)
 920         (reverse! acc)
 921         (if (any (lambda (ll) (member (car l) ll =)) rest)
 922           (lp (cdr l) acc)
 923           (lp (cdr l) (cons (car l) acc)))))))
 924
 925 ;(define (fold kons knil list1 . rest)
 926
 927 (define (lset-xor = . rest)
 928   (fold (lambda (lst res)
 929           (let lp ((l lst) (acc '()))
 930             (if (null? l)
 931               (let lp0 ((r res) (acc acc))
 932                 (if (null? r)
 933                   (reverse! acc)
 934                   (if (member (car r) lst =)
 935                     (lp0 (cdr r) acc)
 936                     (lp0 (cdr r) (cons (car r) acc)))))
 937               (if (member (car l) res =)
 938                 (lp (cdr l) acc)
 939                 (lp (cdr l) (cons (car l) acc))))))
 940         '()
 941         rest))
 942
 943 (define (lset-diff+intersection = list1 . rest)
 944   (let lp ((l list1) (accd '()) (acci '()))
 945     (if (null? l)
 946       (values (reverse! accd) (reverse! acci))
 947       (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
 948         (if appears
 949           (lp (cdr l) accd (cons (car l) acci))
 950           (lp (cdr l) (cons (car l) accd) acci))))))
 951
 952
 953 (define (lset-union! = . rest)
 954   (apply lset-union = rest))            ; XXX:optimize
 955
 956 (define (lset-intersection! = list1 . rest)
 957   (apply lset-intersection = list1 rest)) ; XXX:optimize
 958
 959 (define (lset-difference! = list1 . rest)
 960   (apply lset-difference = list1 rest)) ; XXX:optimize
 961
 962 (define (lset-xor! = . rest)
 963   (apply lset-xor = rest))              ; XXX:optimize
 964
 965 (define (lset-diff+intersection! = list1 . rest)
 966   (apply lset-diff+intersection = list1 rest)) ; XXX:optimize
 967
 968 ;;; srfi-1.scm ends here