module/srfi/srfi-1.scm

   1 ;;; srfi-1.scm --- List Library
   2
   3 ;;      Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2014 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Some parts from the reference implementation, which is
  20 ;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
  21 ;;; this code as long as you do not remove this copyright notice or
  22 ;;; hold me liable for its use.
  23
  24 ;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
  25 ;;; Date: 2001-06-06
  26
  27 ;;; Commentary:
  28
  29 ;; This is an implementation of SRFI-1 (List Library).
  30 ;;
  31 ;; All procedures defined in SRFI-1, which are not already defined in
  32 ;; the Guile core library, are exported.  The procedures in this
  33 ;; implementation work, but they have not been tuned for speed or
  34 ;; memory usage.
  35 ;;
  36 ;; This module is fully documented in the Guile Reference Manual.
  37
  38 ;;; Code:
  39
  40 (define-module (srfi srfi-1)
  41   :export (
  42 ;;; Constructors
  43  ;; cons                                <= in the core
  44  ;; list                                <= in the core
  45  xcons
  46  ;; cons*                               <= in the core
  47  ;; make-list                           <= in the core
  48  list-tabulate
  49  list-copy
  50  circular-list
  51  ;; iota                                ; Extended.
  52
  53 ;;; Predicates
  54  proper-list?
  55  circular-list?
  56  dotted-list?
  57  ;; pair?                               <= in the core
  58  ;; null?                               <= in the core
  59  null-list?
  60  not-pair?
  61  list=
  62
  63 ;;; Selectors
  64  ;; car                                 <= in the core
  65  ;; cdr                                 <= in the core
  66  ;; caar                                <= in the core
  67  ;; cadr                                <= in the core
  68  ;; cdar                                <= in the core
  69  ;; cddr                                <= in the core
  70  ;; caaar                               <= in the core
  71  ;; caadr                               <= in the core
  72  ;; cadar                               <= in the core
  73  ;; caddr                               <= in the core
  74  ;; cdaar                               <= in the core
  75  ;; cdadr                               <= in the core
  76  ;; cddar                               <= in the core
  77  ;; cdddr                               <= in the core
  78  ;; caaaar                              <= in the core
  79  ;; caaadr                              <= in the core
  80  ;; caadar                              <= in the core
  81  ;; caaddr                              <= in the core
  82  ;; cadaar                              <= in the core
  83  ;; cadadr                              <= in the core
  84  ;; caddar                              <= in the core
  85  ;; cadddr                              <= in the core
  86  ;; cdaaar                              <= in the core
  87  ;; cdaadr                              <= in the core
  88  ;; cdadar                              <= in the core
  89  ;; cdaddr                              <= in the core
  90  ;; cddaar                              <= in the core
  91  ;; cddadr                              <= in the core
  92  ;; cdddar                              <= in the core
  93  ;; cddddr                              <= in the core
  94  ;; list-ref                            <= in the core
  95  first
  96  second
  97  third
  98  fourth
  99  fifth
 100  sixth
 101  seventh
 102  eighth
 103  ninth
 104  tenth
 105  car+cdr
 106  take
 107  drop
 108  take-right
 109  drop-right
 110  take!
 111  drop-right!
 112  split-at
 113  split-at!
 114  last
 115  ;; last-pair                           <= in the core
 116
 117 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
 118  ;; length                              <= in the core
 119  length+
 120  ;; append                              <= in the core
 121  ;; append!                             <= in the core
 122  concatenate
 123  concatenate!
 124  ;; reverse                             <= in the core
 125  ;; reverse!                            <= in the core
 126  append-reverse
 127  append-reverse!
 128  zip
 129  unzip1
 130  unzip2
 131  unzip3
 132  unzip4
 133  unzip5
 134  count
 135
 136 ;;; Fold, unfold & map
 137  fold
 138  fold-right
 139  pair-fold
 140  pair-fold-right
 141  reduce
 142  reduce-right
 143  unfold
 144  unfold-right
 145  ;; map                                 ; Extended.
 146  ;; for-each                            ; Extended.
 147  append-map
 148  append-map!
 149  map!
 150  ;; map-in-order                        ; Extended.
 151  pair-for-each
 152  filter-map
 153
 154 ;;; Filtering & partitioning
 155  ;; filter                              <= in the core
 156  partition
 157  remove
 158  ;; filter!                             <= in the core
 159  partition!
 160  remove!
 161
 162 ;;; Searching
 163  find
 164  find-tail
 165  take-while
 166  take-while!
 167  drop-while
 168  span
 169  span!
 170  break
 171  break!
 172  any
 173  every
 174  ;; list-index                          ; Extended.
 175  ;; member                              ; Extended.
 176  ;; memq                                <= in the core
 177  ;; memv                                <= in the core
 178
 179 ;;; Deletion
 180  ;; delete                              ; Extended.
 181  ;; delete!                             ; Extended.
 182  delete-duplicates
 183  delete-duplicates!
 184
 185 ;;; Association lists
 186  ;; assoc                               ; Extended.
 187  ;; assq                                <= in the core
 188  ;; assv                                <= in the core
 189  alist-cons
 190  alist-copy
 191  alist-delete
 192  alist-delete!
 193
 194 ;;; Set operations on lists
 195  lset<=
 196  lset=
 197  lset-adjoin
 198  lset-union
 199  lset-intersection
 200  lset-difference
 201  lset-xor
 202  lset-diff+intersection
 203  lset-union!
 204  lset-intersection!
 205  lset-difference!
 206  lset-xor!
 207  lset-diff+intersection!
 208
 209 ;;; Primitive side-effects
 210  ;; set-car!                            <= in the core
 211  ;; set-cdr!                            <= in the core
 212  )
 213   :re-export (cons list cons* make-list pair? null?
 214               car cdr caar cadr cdar cddr
 215               caaar caadr cadar caddr cdaar cdadr cddar cdddr
 216               caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
 217               cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
 218               list-ref last-pair length append append! reverse reverse!
 219               filter filter! memq memv assq assv set-car! set-cdr!)
 220   :replace (iota map for-each map-in-order list-copy list-index member
 221             delete delete! assoc)
 222   )
 223
 224 (cond-expand-provide (current-module) '(srfi-1))
 225
 226 ;; Load the compiled primitives from the shared library.
 227 ;;
 228 (load-extension (string-append "libguile-" (effective-version))
 229                 "scm_init_srfi_1")
 230
 231
 232 ;;; Constructors
 233
 234 (define (xcons d a)
 235   "Like `cons', but with interchanged arguments.  Useful mostly when passed to
 236 higher-order procedures."
 237   (cons a d))
 238
 239 (define (wrong-type-arg caller arg)
 240   (scm-error 'wrong-type-arg (symbol->string caller)
 241              "Wrong type argument: ~S" (list arg) '()))
 242
 243 (define-syntax-rule (check-arg pred arg caller)
 244   (if (not (pred arg))
 245       (wrong-type-arg 'caller arg)))
 246
 247 (define (out-of-range proc arg)
 248   (scm-error 'out-of-range proc
 249              "Value out of range: ~A" (list arg) (list arg)))
 250
 251 ;; the srfi spec doesn't seem to forbid inexact integers.
 252 (define (non-negative-integer? x) (and (integer? x) (>= x 0)))
 253
 254 (define (list-tabulate n init-proc)
 255   "Return an N-element list, where each list element is produced by applying the
 256 procedure INIT-PROC to the corresponding list index.  The order in which
 257 INIT-PROC is applied to the indices is not specified."
 258   (check-arg non-negative-integer? n list-tabulate)
 259   (let lp ((n n) (acc '()))
 260     (if (<= n 0)
 261         acc
 262         (lp (- n 1) (cons (init-proc (- n 1)) acc)))))
 263
 264 (define (circular-list elt1 . elts)
 265   (set! elts (cons elt1 elts))
 266   (set-cdr! (last-pair elts) elts)
 267   elts)
 268
 269 (define* (iota count #:optional (start 0) (step 1))
 270   (check-arg non-negative-integer? count iota)
 271   (let lp ((n 0) (acc '()))
 272     (if (= n count)
 273         (reverse! acc)
 274         (lp (+ n 1) (cons (+ start (* n step)) acc)))))
 275
 276 ;;; Predicates
 277
 278 (define (proper-list? x)
 279   (list? x))
 280
 281 (define (circular-list? x)
 282   (if (not-pair? x)
 283     #f
 284     (let lp ((hare (cdr x)) (tortoise x))
 285       (if (not-pair? hare)
 286         #f
 287         (let ((hare (cdr hare)))
 288           (if (not-pair? hare)
 289             #f
 290             (if (eq? hare tortoise)
 291               #t
 292               (lp (cdr hare) (cdr tortoise)))))))))
 293
 294 (define (dotted-list? x)
 295   (cond
 296     ((null? x) #f)
 297     ((not-pair? x) #t)
 298     (else
 299      (let lp ((hare (cdr x)) (tortoise x))
 300        (cond
 301          ((null? hare) #f)
 302          ((not-pair? hare) #t)
 303          (else
 304           (let ((hare (cdr hare)))
 305             (cond
 306               ((null? hare) #f)
 307               ((not-pair? hare) #t)
 308               ((eq? hare tortoise) #f)
 309               (else
 310                (lp (cdr hare) (cdr tortoise)))))))))))
 311
 312 (define (null-list? x)
 313   (cond
 314     ((proper-list? x)
 315      (null? x))
 316     ((circular-list? x)
 317      #f)
 318     (else
 319      (error "not a proper list in null-list?"))))
 320
 321 (define (not-pair? x)
 322   "Return #t if X is not a pair, #f otherwise.
 323
 324 This is shorthand notation `(not (pair? X))' and is supposed to be used for
 325 end-of-list checking in contexts where dotted lists are allowed."
 326   (not (pair? x)))
 327
 328 (define (list= elt= . rest)
 329   (define (lists-equal a b)
 330     (let lp ((a a) (b b))
 331       (cond ((null? a)
 332              (null? b))
 333             ((null? b)
 334              #f)
 335             (else
 336              (and (elt= (car a) (car b))
 337                   (lp (cdr a) (cdr b)))))))
 338
 339   (check-arg procedure? elt= list=)
 340   (or (null? rest)
 341       (let lp ((lists rest))
 342         (or (null? (cdr lists))
 343             (and (lists-equal (car lists) (cadr lists))
 344                  (lp (cdr lists)))))))
 345
 346 ;;; Selectors
 347
 348 (define first car)
 349 (define second cadr)
 350 (define third caddr)
 351 (define fourth cadddr)
 352 (define (fifth x) (car (cddddr x)))
 353 (define (sixth x) (cadr (cddddr x)))
 354 (define (seventh x) (caddr (cddddr x)))
 355 (define (eighth x) (cadddr (cddddr x)))
 356 (define (ninth x) (car (cddddr (cddddr x))))
 357 (define (tenth x) (cadr (cddddr (cddddr x))))
 358
 359 (define (car+cdr x)
 360   "Return two values, the `car' and the `cdr' of PAIR."
 361   (values (car x) (cdr x)))
 362
 363 (define take list-head)
 364 (define drop list-tail)
 365
 366 ;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list,
 367 ;;; off by K, then chasing down the list until the lead pointer falls off
 368 ;;; the end.  Note that they diverge for circular lists.
 369
 370 (define (take-right lis k)
 371   (let lp ((lag lis)  (lead (drop lis k)))
 372     (if (pair? lead)
 373         (lp (cdr lag) (cdr lead))
 374         lag)))
 375
 376 (define (drop-right lis k)
 377   (let recur ((lag lis) (lead (drop lis k)))
 378     (if (pair? lead)
 379         (cons (car lag) (recur (cdr lag) (cdr lead)))
 380         '())))
 381
 382 (define (take! lst i)
 383   "Linear-update variant of `take'."
 384   (if (= i 0)
 385       '()
 386       (let ((tail (drop lst (- i 1))))
 387         (set-cdr! tail '())
 388         lst)))
 389
 390 (define (drop-right! lst i)
 391   "Linear-update variant of `drop-right'."
 392   (let ((tail (drop lst i)))
 393     (if (null? tail)
 394         '()
 395         (let loop ((prev lst)
 396                    (tail (cdr tail)))
 397           (if (null? tail)
 398               (if (pair? prev)
 399                   (begin
 400                     (set-cdr! prev '())
 401                     lst)
 402                   lst)
 403               (loop (cdr prev)
 404                     (cdr tail)))))))
 405
 406 (define (split-at lst i)
 407   "Return two values, a list of the elements before index I in LST, and
 408 a list of those after."
 409   (if (< i 0)
 410       (out-of-range 'split-at i)
 411       (let lp ((l lst) (n i) (acc '()))
 412         (if (<= n 0)
 413             (values (reverse! acc) l)
 414             (lp (cdr l) (- n 1) (cons (car l) acc))))))
 415
 416 (define (split-at! lst i)
 417   "Linear-update variant of `split-at'."
 418   (cond ((< i 0)
 419          (out-of-range 'split-at! i))
 420         ((= i 0)
 421          (values '() lst))
 422         (else
 423          (let lp ((l lst) (n (- i 1)))
 424            (if (<= n 0)
 425                (let ((tmp (cdr l)))
 426                  (set-cdr! l '())
 427                  (values lst tmp))
 428                (lp (cdr l) (- n 1)))))))
 429
 430 (define (last pair)
 431   "Return the last element of the non-empty, finite list PAIR."
 432   (car (last-pair pair)))
 433
 434 ;;; Miscelleneous: length, append, concatenate, reverse, zip & count
 435
 436 (define (zip clist1 . rest)
 437   (let lp ((l (cons clist1 rest)) (acc '()))
 438     (if (any null? l)
 439       (reverse! acc)
 440       (lp (map cdr l) (cons (map car l) acc)))))
 441
 442
 443 (define (unzip1 l)
 444   (map first l))
 445 (define (unzip2 l)
 446   (values (map first l) (map second l)))
 447 (define (unzip3 l)
 448   (values (map first l) (map second l) (map third l)))
 449 (define (unzip4 l)
 450   (values (map first l) (map second l) (map third l) (map fourth l)))
 451 (define (unzip5 l)
 452   (values (map first l) (map second l) (map third l) (map fourth l)
 453           (map fifth l)))
 454
 455 ;;; Fold, unfold & map
 456
 457 (define fold
 458   (case-lambda
 459     "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
 460 that result.  See the manual for details."
 461     ((kons knil list1)
 462      (check-arg procedure? kons fold)
 463      (check-arg list? list1 fold)
 464      (let fold1 ((knil knil) (list1 list1))
 465        (if (pair? list1)
 466            (fold1 (kons (car list1) knil) (cdr list1))
 467            knil)))
 468     ((kons knil list1 list2)
 469      (check-arg procedure? kons fold)
 470      (let* ((len1 (length+ list1))
 471             (len2 (length+ list2))
 472             (len (if (and len1 len2)
 473                      (min len1 len2)
 474                      (or len1 len2))))
 475        (unless len
 476          (scm-error 'wrong-type-arg "fold"
 477                     "Args do not contain a proper (finite) list: ~S"
 478                     (list (list list1 list2)) #f))
 479        (let fold2 ((knil knil) (list1 list1) (list2 list2) (len len))
 480          (if (zero? len)
 481              knil
 482              (fold2 (kons (car list1) (car list2) knil)
 483                     (cdr list1) (cdr list2) (1- len))))))
 484     ((kons knil list1 . rest)
 485      (check-arg procedure? kons fold)
 486      (let foldn ((knil knil) (lists (cons list1 rest)))
 487        (if (any null? lists)
 488            knil
 489            (let ((cars (map car lists))
 490                  (cdrs (map cdr lists)))
 491              (foldn (apply kons (append! cars (list knil))) cdrs)))))))
 492
 493 (define (fold-right kons knil clist1 . rest)
 494   (check-arg procedure? kons fold-right)
 495   (if (null? rest)
 496       (let loop ((lst    (reverse clist1))
 497                  (result knil))
 498         (if (null? lst)
 499             result
 500             (loop (cdr lst)
 501                   (kons (car lst) result))))
 502       (let loop ((lists  (map reverse (cons clist1 rest)))
 503                  (result knil))
 504         (if (any1 null? lists)
 505             result
 506             (loop (map cdr lists)
 507                   (apply kons (append! (map car lists) (list result))))))))
 508
 509 (define (pair-fold kons knil clist1 . rest)
 510   (check-arg procedure? kons pair-fold)
 511   (if (null? rest)
 512       (let f ((knil knil) (list1 clist1))
 513         (if (null? list1)
 514             knil
 515             (let ((tail (cdr list1)))
 516             (f (kons list1 knil) tail))))
 517       (let f ((knil knil) (lists (cons clist1 rest)))
 518         (if (any null? lists)
 519             knil
 520             (let ((tails (map cdr lists)))
 521               (f (apply kons (append! lists (list knil))) tails))))))
 522
 523
 524 (define (pair-fold-right kons knil clist1 . rest)
 525   (check-arg procedure? kons pair-fold-right)
 526   (if (null? rest)
 527     (let f ((list1 clist1))
 528       (if (null? list1)
 529         knil
 530         (kons list1 (f (cdr list1)))))
 531     (let f ((lists (cons clist1 rest)))
 532       (if (any null? lists)
 533         knil
 534         (apply kons (append! lists (list (f (map cdr lists)))))))))
 535
 536 (define* (unfold p f g seed #:optional (tail-gen (lambda (x) '())))
 537   (define (reverse+tail lst seed)
 538     (let loop ((lst    lst)
 539                (result (tail-gen seed)))
 540       (if (null? lst)
 541           result
 542           (loop (cdr lst)
 543                 (cons (car lst) result)))))
 544
 545   (check-arg procedure? p unfold)
 546   (check-arg procedure? f unfold)
 547   (check-arg procedure? g unfold)
 548   (check-arg procedure? tail-gen unfold)
 549   (let loop ((seed   seed)
 550              (result '()))
 551     (if (p seed)
 552         (reverse+tail result seed)
 553         (loop (g seed)
 554               (cons (f seed) result)))))
 555
 556 (define* (unfold-right p f g seed #:optional (tail '()))
 557   (check-arg procedure? p unfold-right)
 558   (check-arg procedure? f unfold-right)
 559   (check-arg procedure? g unfold-right)
 560   (let uf ((seed seed) (lis tail))
 561     (if (p seed)
 562         lis
 563         (uf (g seed) (cons (f seed) lis)))))
 564
 565 (define (reduce f ridentity lst)
 566   "`reduce' is a variant of `fold', where the first call to F is on two
 567 elements from LST, rather than one element and a given initial value.
 568 If LST is empty, RIDENTITY is returned.  If LST has just one element
 569 then that's the return value."
 570   (check-arg procedure? f reduce)
 571   (if (null? lst)
 572       ridentity
 573       (fold f (car lst) (cdr lst))))
 574
 575 (define (reduce-right f ridentity lst)
 576   "`reduce-right' is a variant of `fold-right', where the first call to
 577 F is on two elements from LST, rather than one element and a given
 578 initial value.  If LST is empty, RIDENTITY is returned.  If LST
 579 has just one element then that's the return value."
 580   (check-arg procedure? f reduce)
 581   (if (null? lst)
 582       ridentity
 583       (fold-right f (last lst) (drop-right lst 1))))
 584
 585 (define map
 586   (case-lambda
 587     ((f l)
 588      (check-arg procedure? f map)
 589      (check-arg list? l map)
 590      (let map1 ((l l))
 591        (if (pair? l)
 592            (cons (f (car l)) (map1 (cdr l)))
 593            '())))
 594
 595     ((f l1 l2)
 596      (check-arg procedure? f map)
 597      (let* ((len1 (length+ l1))
 598             (len2 (length+ l2))
 599             (len (if (and len1 len2)
 600                      (min len1 len2)
 601                      (or len1 len2))))
 602        (unless len
 603          (scm-error 'wrong-type-arg "map"
 604                     "Args do not contain a proper (finite) list: ~S"
 605                     (list (list l1 l2)) #f))
 606        (let map2 ((l1 l1) (l2 l2) (len len))
 607          (if (zero? len)
 608              '()
 609              (cons (f (car l1) (car l2))
 610                    (map2 (cdr l1) (cdr l2) (1- len)))))))
 611
 612     ((f l1 . rest)
 613      (check-arg procedure? f map)
 614      (let ((len (fold (lambda (ls len)
 615                         (let ((ls-len (length+ ls)))
 616                           (if len
 617                               (if ls-len (min ls-len len) len)
 618                               ls-len)))
 619                       (length+ l1)
 620                       rest)))
 621        (if (not len)
 622            (scm-error 'wrong-type-arg "map"
 623                       "Args do not contain a proper (finite) list: ~S"
 624                       (list (cons l1 rest)) #f))
 625        (let mapn ((l1 l1) (rest rest) (len len))
 626          (if (zero? len)
 627              '()
 628              (cons (apply f (car l1) (map car rest))
 629                    (mapn (cdr l1) (map cdr rest) (1- len)))))))))
 630
 631 (define map-in-order map)
 632
 633 (define for-each
 634   (case-lambda
 635     ((f l)
 636      (check-arg procedure? f for-each)
 637      (check-arg list? l for-each)
 638      (let for-each1 ((l l))
 639        (unless (null? l)
 640          (f (car l))
 641          (for-each1 (cdr l)))))
 642
 643     ((f l1 l2)
 644      (check-arg procedure? f for-each)
 645      (let* ((len1 (length+ l1))
 646             (len2 (length+ l2))
 647             (len (if (and len1 len2)
 648                      (min len1 len2)
 649                      (or len1 len2))))
 650        (unless len
 651          (scm-error 'wrong-type-arg "for-each"
 652                     "Args do not contain a proper (finite) list: ~S"
 653                     (list (list l1 l2)) #f))
 654        (let for-each2 ((l1 l1) (l2 l2) (len len))
 655          (unless (zero? len)
 656            (f (car l1) (car l2))
 657            (for-each2 (cdr l1) (cdr l2) (1- len))))))
 658
 659     ((f l1 . rest)
 660      (check-arg procedure? f for-each)
 661      (let ((len (fold (lambda (ls len)
 662                         (let ((ls-len (length+ ls)))
 663                           (if len
 664                               (if ls-len (min ls-len len) len)
 665                               ls-len)))
 666                       (length+ l1)
 667                       rest)))
 668        (if (not len)
 669            (scm-error 'wrong-type-arg "for-each"
 670                       "Args do not contain a proper (finite) list: ~S"
 671                       (list (cons l1 rest)) #f))
 672        (let for-eachn ((l1 l1) (rest rest) (len len))
 673          (if (> len 0)
 674              (begin
 675                (apply f (car l1) (map car rest))
 676                (for-eachn (cdr l1) (map cdr rest) (1- len)))))))))
 677
 678 (define (append-map f clist1 . rest)
 679   (concatenate (apply map f clist1 rest)))
 680
 681 (define (append-map! f clist1 . rest)
 682   (concatenate! (apply map f clist1 rest)))
 683
 684 ;; OPTIMIZE-ME: Re-use cons cells of list1
 685 (define map! map)
 686
 687 (define (filter-map proc list1 . rest)
 688   "Apply PROC to the elements of LIST1... and return a list of the
 689 results as per SRFI-1 `map', except that any #f results are omitted from
 690 the list returned."
 691   (check-arg procedure? proc filter-map)
 692   (if (null? rest)
 693       (let lp ((l list1)
 694                (rl '()))
 695         (if (null? l)
 696             (reverse! rl)
 697             (let ((res (proc (car l))))
 698               (if res
 699                   (lp (cdr l) (cons res rl))
 700                   (lp (cdr l) rl)))))
 701       (let lp ((l (cons list1 rest))
 702                (rl '()))
 703         (if (any1 null? l)
 704             (reverse! rl)
 705             (let ((res (apply proc (map car l))))
 706               (if res
 707                   (lp (map cdr l) (cons res rl))
 708                   (lp (map cdr l) rl)))))))
 709
 710 (define (pair-for-each f clist1 . rest)
 711   (check-arg procedure? f pair-for-each)
 712   (if (null? rest)
 713     (let lp ((l clist1))
 714       (if (null? l)
 715         (if #f #f)
 716         (begin
 717           (f l)
 718           (lp (cdr l)))))
 719     (let lp ((l (cons clist1 rest)))
 720       (if (any1 null? l)
 721         (if #f #f)
 722         (begin
 723           (apply f l)
 724           (lp (map cdr l)))))))
 725
 726 \f
 727 ;;; Searching
 728
 729 (define (take-while pred ls)
 730   "Return a new list which is the longest initial prefix of LS whose
 731 elements all satisfy the predicate PRED."
 732   (check-arg procedure? pred take-while)
 733   (cond ((null? ls) '())
 734         ((not (pred (car ls))) '())
 735         (else
 736          (let ((result (list (car ls))))
 737            (let lp ((ls (cdr ls)) (p result))
 738              (cond ((null? ls) result)
 739                    ((not (pred (car ls))) result)
 740                    (else
 741                     (set-cdr! p (list (car ls)))
 742                     (lp (cdr ls) (cdr p)))))))))
 743
 744 (define (take-while! pred lst)
 745   "Linear-update variant of `take-while'."
 746   (check-arg procedure? pred take-while!)
 747   (let loop ((prev #f)
 748              (rest lst))
 749     (cond ((null? rest)
 750            lst)
 751           ((pred (car rest))
 752            (loop rest (cdr rest)))
 753           (else
 754            (if (pair? prev)
 755                (begin
 756                  (set-cdr! prev '())
 757                  lst)
 758                '())))))
 759
 760 (define (drop-while pred lst)
 761   "Drop the longest initial prefix of LST whose elements all satisfy the
 762 predicate PRED."
 763   (check-arg procedure? pred drop-while)
 764   (let loop ((lst lst))
 765     (cond ((null? lst)
 766            '())
 767           ((pred (car lst))
 768            (loop (cdr lst)))
 769           (else lst))))
 770
 771 (define (span pred lst)
 772   "Return two values, the longest initial prefix of LST whose elements
 773 all satisfy the predicate PRED, and the remainder of LST."
 774   (check-arg procedure? pred span)
 775   (let lp ((lst lst) (rl '()))
 776     (if (and (not (null? lst))
 777              (pred (car lst)))
 778         (lp (cdr lst) (cons (car lst) rl))
 779         (values (reverse! rl) lst))))
 780
 781 (define (span! pred list)
 782   "Linear-update variant of `span'."
 783   (check-arg procedure? pred span!)
 784   (let loop ((prev #f)
 785              (rest list))
 786     (cond ((null? rest)
 787            (values list '()))
 788           ((pred (car rest))
 789            (loop rest (cdr rest)))
 790           (else
 791            (if (pair? prev)
 792                (begin
 793                  (set-cdr! prev '())
 794                  (values list rest))
 795                (values '() list))))))
 796
 797 (define (break pred clist)
 798   "Return two values, the longest initial prefix of LST whose elements
 799 all fail the predicate PRED, and the remainder of LST."
 800   (check-arg procedure? pred break)
 801   (let lp ((clist clist) (rl '()))
 802     (if (or (null? clist)
 803             (pred (car clist)))
 804         (values (reverse! rl) clist)
 805         (lp (cdr clist) (cons (car clist) rl)))))
 806
 807 (define (break! pred list)
 808   "Linear-update variant of `break'."
 809   (check-arg procedure? pred break!)
 810   (let loop ((l    list)
 811              (prev #f))
 812     (cond ((null? l)
 813            (values list '()))
 814           ((pred (car l))
 815            (if (pair? prev)
 816                (begin
 817                  (set-cdr! prev '())
 818                  (values list l))
 819                (values '() list)))
 820           (else
 821            (loop (cdr l) l)))))
 822
 823 (define (any pred ls . lists)
 824   (check-arg procedure? pred any)
 825   (if (null? lists)
 826       (any1 pred ls)
 827       (let lp ((lists (cons ls lists)))
 828         (cond ((any1 null? lists)
 829                #f)
 830               ((any1 null? (map cdr lists))
 831                (apply pred (map car lists)))
 832               (else
 833                (or (apply pred (map car lists)) (lp (map cdr lists))))))))
 834
 835 (define (any1 pred ls)
 836   (let lp ((ls ls))
 837     (cond ((null? ls)
 838            #f)
 839           ((null? (cdr ls))
 840            (pred (car ls)))
 841           (else
 842            (or (pred (car ls)) (lp (cdr ls)))))))
 843
 844 (define (every pred ls . lists)
 845   (check-arg procedure? pred every)
 846   (if (null? lists)
 847       (every1 pred ls)
 848       (let lp ((lists (cons ls lists)))
 849         (cond ((any1 null? lists)
 850                #t)
 851               ((any1 null? (map cdr lists))
 852                (apply pred (map car lists)))
 853               (else
 854                (and (apply pred (map car lists)) (lp (map cdr lists))))))))
 855
 856 (define (every1 pred ls)
 857   (let lp ((ls ls))
 858     (cond ((null? ls)
 859            #t)
 860           ((null? (cdr ls))
 861            (pred (car ls)))
 862           (else
 863            (and (pred (car ls)) (lp (cdr ls)))))))
 864
 865 (define (list-index pred clist1 . rest)
 866   "Return the index of the first set of elements, one from each of
 867 CLIST1 ... CLISTN, that satisfies PRED."
 868   (check-arg procedure? pred list-index)
 869   (if (null? rest)
 870     (let lp ((l clist1) (i 0))
 871       (if (null? l)
 872         #f
 873         (if (pred (car l))
 874           i
 875           (lp (cdr l) (+ i 1)))))
 876     (let lp ((lists (cons clist1 rest)) (i 0))
 877       (cond ((any1 null? lists)
 878              #f)
 879             ((apply pred (map car lists)) i)
 880             (else
 881              (lp (map cdr lists) (+ i 1)))))))
 882
 883 ;;; Association lists
 884
 885 (define alist-cons acons)
 886
 887 (define (alist-copy alist)
 888   "Return a copy of ALIST, copying both the pairs comprising the list
 889 and those making the associations."
 890   (let lp ((a  alist)
 891            (rl '()))
 892     (if (null? a)
 893         (reverse! rl)
 894         (lp (cdr a) (alist-cons (caar a) (cdar a) rl)))))
 895
 896 (define* (alist-delete key alist #:optional (k= equal?))
 897   (check-arg procedure? k= alist-delete)
 898   (let lp ((a alist) (rl '()))
 899     (if (null? a)
 900         (reverse! rl)
 901         (if (k= key (caar a))
 902             (lp (cdr a) rl)
 903             (lp (cdr a) (cons (car a) rl))))))
 904
 905 (define* (alist-delete! key alist #:optional (k= equal?))
 906   (alist-delete key alist k=))  ; XXX:optimize
 907
 908 ;;; Delete / assoc / member
 909
 910 (define* (member x ls #:optional (= equal?))
 911   (cond
 912    ;; This might be performance-sensitive, so punt on the check here,
 913    ;; relying on memq/memv to check that = is a procedure.
 914    ((eq? = eq?) (memq x ls))
 915    ((eq? = eqv?) (memv x ls))
 916    (else
 917     (check-arg procedure? = member)
 918     (find-tail (lambda (y) (= x y)) ls))))
 919
 920 ;;; Set operations on lists
 921
 922 (define (lset<= = . rest)
 923   (check-arg procedure? = lset<=)
 924   (if (null? rest)
 925       #t
 926       (let lp ((f (car rest)) (r (cdr rest)))
 927         (or (null? r)
 928             (and (every (lambda (el) (member el (car r) =)) f)
 929                  (lp (car r) (cdr r)))))))
 930
 931 (define (lset= = . rest)
 932   (check-arg procedure? = lset<=)
 933   (if (null? rest)
 934     #t
 935     (let lp ((f (car rest)) (r (cdr rest)))
 936       (or (null? r)
 937           (and (every (lambda (el) (member el (car r) =)) f)
 938                (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r))
 939                (lp (car r) (cdr r)))))))
 940
 941 ;; It's not quite clear if duplicates among the `rest' elements are meant to
 942 ;; be cast out.  The spec says `=' is called as (= lstelem restelem),
 943 ;; suggesting perhaps not, but the reference implementation shows the "list"
 944 ;; at each stage as including those elements already added.  The latter
 945 ;; corresponds to what's described for lset-union, so that's what's done.
 946 ;;
 947 (define (lset-adjoin = list . rest)
 948   "Add to LIST any of the elements of REST not already in the list.
 949 These elements are `cons'ed onto the start of LIST (so the return shares
 950 a common tail with LIST), but the order they're added is unspecified.
 951
 952 The given `=' procedure is used for comparing elements, called
 953 as `(@var{=} listelem elem)', i.e., the second argument is one of the
 954 given REST parameters."
 955   ;; If `=' is `eq?' or `eqv?', users won't be able to tell which arg is
 956   ;; first, so we can pass the raw procedure through to `member',
 957   ;; allowing `memq' / `memv' to be selected.
 958   (define pred
 959     (if (or (eq? = eq?) (eq? = eqv?))
 960         =
 961         (begin
 962           (check-arg procedure? = lset-adjoin)
 963           (lambda (x y) (= y x)))))
 964
 965   (let lp ((ans list) (rest rest))
 966     (if (null? rest)
 967         ans
 968         (lp (if (member (car rest) ans pred)
 969                 ans
 970                 (cons (car rest) ans))
 971             (cdr rest)))))
 972
 973 (define (lset-union = . rest)
 974   ;; Likewise, allow memq / memv to be used if possible.
 975   (define pred
 976     (if (or (eq? = eq?) (eq? = eqv?))
 977         =
 978         (begin
 979           (check-arg procedure? = lset-union)
 980           (lambda (x y) (= y x)))))
 981
 982   (fold (lambda (lis ans)               ; Compute ANS + LIS.
 983           (cond ((null? lis) ans)       ; Don't copy any lists
 984                 ((null? ans) lis)       ; if we don't have to.
 985                 ((eq? lis ans) ans)
 986                 (else
 987                  (fold (lambda (elt ans)
 988                          (if (member elt ans pred)
 989                              ans
 990                              (cons elt ans)))
 991                        ans lis))))
 992         '()
 993         rest))
 994
 995 (define (lset-intersection = list1 . rest)
 996   (check-arg procedure? = lset-intersection)
 997   (let lp ((l list1) (acc '()))
 998     (if (null? l)
 999       (reverse! acc)
1000       (if (every (lambda (ll) (member (car l) ll =)) rest)
1001         (lp (cdr l) (cons (car l) acc))
1002         (lp (cdr l) acc)))))
1003
1004 (define (lset-difference = list1 . rest)
1005   (check-arg procedure? = lset-difference)
1006   (if (null? rest)
1007     list1
1008     (let lp ((l list1) (acc '()))
1009       (if (null? l)
1010         (reverse! acc)
1011         (if (any (lambda (ll) (member (car l) ll =)) rest)
1012           (lp (cdr l) acc)
1013           (lp (cdr l) (cons (car l) acc)))))))
1014
1015 ;(define (fold kons knil list1 . rest)
1016
1017 (define (lset-xor = . rest)
1018   (check-arg procedure? = lset-xor)
1019   (fold (lambda (lst res)
1020           (let lp ((l lst) (acc '()))
1021             (if (null? l)
1022               (let lp0 ((r res) (acc acc))
1023                 (if (null? r)
1024                   (reverse! acc)
1025                   (if (member (car r) lst =)
1026                     (lp0 (cdr r) acc)
1027                     (lp0 (cdr r) (cons (car r) acc)))))
1028               (if (member (car l) res =)
1029                 (lp (cdr l) acc)
1030                 (lp (cdr l) (cons (car l) acc))))))
1031         '()
1032         rest))
1033
1034 (define (lset-diff+intersection = list1 . rest)
1035   (check-arg procedure? = lset-diff+intersection)
1036   (let lp ((l list1) (accd '()) (acci '()))
1037     (if (null? l)
1038       (values (reverse! accd) (reverse! acci))
1039       (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
1040         (if appears
1041           (lp (cdr l) accd (cons (car l) acci))
1042           (lp (cdr l) (cons (car l) accd) acci))))))
1043
1044
1045 (define (lset-union! = . rest)
1046   (check-arg procedure? = lset-union!)
1047   (apply lset-union = rest))            ; XXX:optimize
1048
1049 (define (lset-intersection! = list1 . rest)
1050   (check-arg procedure? = lset-intersection!)
1051   (apply lset-intersection = list1 rest)) ; XXX:optimize
1052
1053 (define (lset-xor! = . rest)
1054   (check-arg procedure? = lset-xor!)
1055   (apply lset-xor = rest))              ; XXX:optimize
1056
1057 (define (lset-diff+intersection! = list1 . rest)
1058   (check-arg procedure? = lset-diff+intersection!)
1059   (apply lset-diff+intersection = list1 rest)) ; XXX:optimize
1060
1061 ;;; srfi-1.scm ends here