module/srfi/srfi-1.scm

   1 ;;; srfi-1.scm --- List Library
   2
   3 ;;      Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011 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 kons knil list1 . rest)
 458   "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
 459 that result.  See the manual for details."
 460   (check-arg procedure? kons fold)
 461   (if (null? rest)
 462       (let f ((knil knil) (list1 list1))
 463         (if (null? list1)
 464             knil
 465             (f (kons (car list1) knil) (cdr list1))))
 466       (let f ((knil knil) (lists (cons list1 rest)))
 467         (if (any null? lists)
 468             knil
 469             (let ((cars (map car lists))
 470                   (cdrs (map cdr lists)))
 471               (f (apply kons (append! cars (list knil))) cdrs))))))
 472
 473 (define (fold-right kons knil clist1 . rest)
 474   (check-arg procedure? kons fold-right)
 475   (if (null? rest)
 476       (let loop ((lst    (reverse clist1))
 477                  (result knil))
 478         (if (null? lst)
 479             result
 480             (loop (cdr lst)
 481                   (kons (car lst) result))))
 482       (let loop ((lists  (map reverse (cons clist1 rest)))
 483                  (result knil))
 484         (if (any1 null? lists)
 485             result
 486             (loop (map cdr lists)
 487                   (apply kons (append! (map car lists) (list result))))))))
 488
 489 (define (pair-fold kons knil clist1 . rest)
 490   (check-arg procedure? kons pair-fold)
 491   (if (null? rest)
 492       (let f ((knil knil) (list1 clist1))
 493         (if (null? list1)
 494             knil
 495             (let ((tail (cdr list1)))
 496             (f (kons list1 knil) tail))))
 497       (let f ((knil knil) (lists (cons clist1 rest)))
 498         (if (any null? lists)
 499             knil
 500             (let ((tails (map cdr lists)))
 501               (f (apply kons (append! lists (list knil))) tails))))))
 502
 503
 504 (define (pair-fold-right kons knil clist1 . rest)
 505   (check-arg procedure? kons pair-fold-right)
 506   (if (null? rest)
 507     (let f ((list1 clist1))
 508       (if (null? list1)
 509         knil
 510         (kons list1 (f (cdr list1)))))
 511     (let f ((lists (cons clist1 rest)))
 512       (if (any null? lists)
 513         knil
 514         (apply kons (append! lists (list (f (map cdr lists)))))))))
 515
 516 (define* (unfold p f g seed #:optional (tail-gen (lambda (x) '())))
 517   (define (reverse+tail lst seed)
 518     (let loop ((lst    lst)
 519                (result (tail-gen seed)))
 520       (if (null? lst)
 521           result
 522           (loop (cdr lst)
 523                 (cons (car lst) result)))))
 524
 525   (check-arg procedure? p unfold)
 526   (check-arg procedure? f unfold)
 527   (check-arg procedure? g unfold)
 528   (check-arg procedure? tail-gen unfold)
 529   (let loop ((seed   seed)
 530              (result '()))
 531     (if (p seed)
 532         (reverse+tail result seed)
 533         (loop (g seed)
 534               (cons (f seed) result)))))
 535
 536 (define* (unfold-right p f g seed #:optional (tail '()))
 537   (check-arg procedure? p unfold-right)
 538   (check-arg procedure? f unfold-right)
 539   (check-arg procedure? g unfold-right)
 540   (let uf ((seed seed) (lis tail))
 541     (if (p seed)
 542         lis
 543         (uf (g seed) (cons (f seed) lis)))))
 544
 545 (define (reduce f ridentity lst)
 546   "`reduce' is a variant of `fold', where the first call to F is on two
 547 elements from LST, rather than one element and a given initial value.
 548 If LST is empty, RIDENTITY is returned.  If LST has just one element
 549 then that's the return value."
 550   (check-arg procedure? f reduce)
 551   (if (null? lst)
 552       ridentity
 553       (fold f (car lst) (cdr lst))))
 554
 555 (define (reduce-right f ridentity lst)
 556   "`reduce-right' is a variant of `fold-right', where the first call to
 557 F is on two elements from LST, rather than one element and a given
 558 initial value.  If LST is empty, RIDENTITY is returned.  If LST
 559 has just one element then that's the return value."
 560   (check-arg procedure? f reduce)
 561   (if (null? lst)
 562       ridentity
 563       (fold-right f (last lst) (drop-right lst 1))))
 564
 565 (define map
 566   (case-lambda
 567     ((f l)
 568      (check-arg procedure? f map)
 569      (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
 570        (if (pair? hare)
 571            (if move?
 572                (if (eq? tortoise hare)
 573                    (scm-error 'wrong-type-arg "map" "Circular list: ~S"
 574                               (list l) #f)
 575                    (map1 (cdr hare) (cdr tortoise) #f
 576                        (cons (f (car hare)) out)))
 577                (map1 (cdr hare) tortoise #t
 578                      (cons (f (car hare)) out)))
 579            (if (null? hare)
 580                (reverse! out)
 581                (scm-error 'wrong-type-arg "map" "Not a list: ~S"
 582                           (list l) #f)))))
 583
 584     ((f l1 . rest)
 585      (check-arg procedure? f map)
 586      (let ((len (fold (lambda (ls len)
 587                         (let ((ls-len (length+ ls)))
 588                           (if len
 589                               (if ls-len (min ls-len len) len)
 590                               ls-len)))
 591                       (length+ l1)
 592                       rest)))
 593        (if (not len)
 594            (scm-error 'wrong-type-arg "map"
 595                       "Args do not contain a proper (finite) list: ~S"
 596                       (list (cons l1 rest)) #f))
 597        (let mapn ((l1 l1) (rest rest) (len len) (out '()))
 598          (if (zero? len)
 599              (reverse! out)
 600              (mapn (cdr l1) (map cdr rest) (1- len)
 601                    (cons (apply f (car l1) (map car rest)) out))))))))
 602
 603 (define map-in-order map)
 604
 605 (define for-each
 606   (case-lambda
 607     ((f l)
 608      (check-arg procedure? f for-each)
 609      (let for-each1 ((hare l) (tortoise l) (move? #f))
 610        (if (pair? hare)
 611            (if move?
 612                (if (eq? tortoise hare)
 613                    (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
 614                               (list l) #f)
 615                    (begin
 616                      (f (car hare))
 617                      (for-each1 (cdr hare) (cdr tortoise) #f)))
 618                (begin
 619                  (f (car hare))
 620                  (for-each1 (cdr hare) tortoise #t)))
 621
 622            (if (not (null? hare))
 623                (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
 624                           (list l) #f)))))
 625
 626     ((f l1 . rest)
 627      (check-arg procedure? f for-each)
 628      (let ((len (fold (lambda (ls len)
 629                         (let ((ls-len (length+ ls)))
 630                           (if len
 631                               (if ls-len (min ls-len len) len)
 632                               ls-len)))
 633                       (length+ l1)
 634                       rest)))
 635        (if (not len)
 636            (scm-error 'wrong-type-arg "for-each"
 637                       "Args do not contain a proper (finite) list: ~S"
 638                       (list (cons l1 rest)) #f))
 639        (let for-eachn ((l1 l1) (rest rest) (len len))
 640          (if (> len 0)
 641              (begin
 642                (apply f (car l1) (map car rest))
 643                (for-eachn (cdr l1) (map cdr rest) (1- len)))))))))
 644
 645 (define (append-map f clist1 . rest)
 646   (concatenate (apply map f clist1 rest)))
 647
 648 (define (append-map! f clist1 . rest)
 649   (concatenate! (apply map f clist1 rest)))
 650
 651 ;; OPTIMIZE-ME: Re-use cons cells of list1
 652 (define map! map)
 653
 654 (define (filter-map proc list1 . rest)
 655   "Apply PROC to the elements of LIST1... and return a list of the
 656 results as per SRFI-1 `map', except that any #f results are omitted from
 657 the list returned."
 658   (check-arg procedure? proc filter-map)
 659   (if (null? rest)
 660       (let lp ((l list1)
 661                (rl '()))
 662         (if (null? l)
 663             (reverse! rl)
 664             (let ((res (proc (car l))))
 665               (if res
 666                   (lp (cdr l) (cons res rl))
 667                   (lp (cdr l) rl)))))
 668       (let lp ((l (cons list1 rest))
 669                (rl '()))
 670         (if (any1 null? l)
 671             (reverse! rl)
 672             (let ((res (apply proc (map car l))))
 673               (if res
 674                   (lp (map cdr l) (cons res rl))
 675                   (lp (map cdr l) rl)))))))
 676
 677 (define (pair-for-each f clist1 . rest)
 678   (check-arg procedure? f pair-for-each)
 679   (if (null? rest)
 680     (let lp ((l clist1))
 681       (if (null? l)
 682         (if #f #f)
 683         (begin
 684           (f l)
 685           (lp (cdr l)))))
 686     (let lp ((l (cons clist1 rest)))
 687       (if (any1 null? l)
 688         (if #f #f)
 689         (begin
 690           (apply f l)
 691           (lp (map cdr l)))))))
 692
 693 \f
 694 ;;; Searching
 695
 696 (define (take-while pred ls)
 697   "Return a new list which is the longest initial prefix of LS whose
 698 elements all satisfy the predicate PRED."
 699   (check-arg procedure? pred take-while)
 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 lst)
 712   "Linear-update variant of `take-while'."
 713   (check-arg procedure? pred take-while!)
 714   (let loop ((prev #f)
 715              (rest lst))
 716     (cond ((null? rest)
 717            lst)
 718           ((pred (car rest))
 719            (loop rest (cdr rest)))
 720           (else
 721            (if (pair? prev)
 722                (begin
 723                  (set-cdr! prev '())
 724                  lst)
 725                '())))))
 726
 727 (define (drop-while pred lst)
 728   "Drop the longest initial prefix of LST whose elements all satisfy the
 729 predicate PRED."
 730   (check-arg procedure? pred drop-while)
 731   (let loop ((lst lst))
 732     (cond ((null? lst)
 733            '())
 734           ((pred (car lst))
 735            (loop (cdr lst)))
 736           (else lst))))
 737
 738 (define (span pred lst)
 739   "Return two values, the longest initial prefix of LST whose elements
 740 all satisfy the predicate PRED, and the remainder of LST."
 741   (check-arg procedure? pred span)
 742   (let lp ((lst lst) (rl '()))
 743     (if (and (not (null? lst))
 744              (pred (car lst)))
 745         (lp (cdr lst) (cons (car lst) rl))
 746         (values (reverse! rl) lst))))
 747
 748 (define (span! pred list)
 749   "Linear-update variant of `span'."
 750   (check-arg procedure? pred span!)
 751   (let loop ((prev #f)
 752              (rest list))
 753     (cond ((null? rest)
 754            (values list '()))
 755           ((pred (car rest))
 756            (loop rest (cdr rest)))
 757           (else
 758            (if (pair? prev)
 759                (begin
 760                  (set-cdr! prev '())
 761                  (values list rest))
 762                (values '() list))))))
 763
 764 (define (break pred clist)
 765   "Return two values, the longest initial prefix of LST whose elements
 766 all fail the predicate PRED, and the remainder of LST."
 767   (check-arg procedure? pred break)
 768   (let lp ((clist clist) (rl '()))
 769     (if (or (null? clist)
 770             (pred (car clist)))
 771         (values (reverse! rl) clist)
 772         (lp (cdr clist) (cons (car clist) rl)))))
 773
 774 (define (break! pred list)
 775   "Linear-update variant of `break'."
 776   (check-arg procedure? pred break!)
 777   (let loop ((l    list)
 778              (prev #f))
 779     (cond ((null? l)
 780            (values list '()))
 781           ((pred (car l))
 782            (if (pair? prev)
 783                (begin
 784                  (set-cdr! prev '())
 785                  (values list l))
 786                (values '() list)))
 787           (else
 788            (loop (cdr l) l)))))
 789
 790 (define (any pred ls . lists)
 791   (check-arg procedure? pred any)
 792   (if (null? lists)
 793       (any1 pred ls)
 794       (let lp ((lists (cons ls lists)))
 795         (cond ((any1 null? lists)
 796                #f)
 797               ((any1 null? (map cdr lists))
 798                (apply pred (map car lists)))
 799               (else
 800                (or (apply pred (map car lists)) (lp (map cdr lists))))))))
 801
 802 (define (any1 pred ls)
 803   (let lp ((ls ls))
 804     (cond ((null? ls)
 805            #f)
 806           ((null? (cdr ls))
 807            (pred (car ls)))
 808           (else
 809            (or (pred (car ls)) (lp (cdr ls)))))))
 810
 811 (define (every pred ls . lists)
 812   (check-arg procedure? pred every)
 813   (if (null? lists)
 814       (every1 pred ls)
 815       (let lp ((lists (cons ls lists)))
 816         (cond ((any1 null? lists)
 817                #t)
 818               ((any1 null? (map cdr lists))
 819                (apply pred (map car lists)))
 820               (else
 821                (and (apply pred (map car lists)) (lp (map cdr lists))))))))
 822
 823 (define (every1 pred ls)
 824   (let lp ((ls ls))
 825     (cond ((null? ls)
 826            #t)
 827           ((null? (cdr ls))
 828            (pred (car ls)))
 829           (else
 830            (and (pred (car ls)) (lp (cdr ls)))))))
 831
 832 (define (list-index pred clist1 . rest)
 833   "Return the index of the first set of elements, one from each of
 834 CLIST1 ... CLISTN, that satisfies PRED."
 835   (check-arg procedure? pred list-index)
 836   (if (null? rest)
 837     (let lp ((l clist1) (i 0))
 838       (if (null? l)
 839         #f
 840         (if (pred (car l))
 841           i
 842           (lp (cdr l) (+ i 1)))))
 843     (let lp ((lists (cons clist1 rest)) (i 0))
 844       (cond ((any1 null? lists)
 845              #f)
 846             ((apply pred (map car lists)) i)
 847             (else
 848              (lp (map cdr lists) (+ i 1)))))))
 849
 850 ;;; Association lists
 851
 852 (define alist-cons acons)
 853
 854 (define (alist-copy alist)
 855   "Return a copy of ALIST, copying both the pairs comprising the list
 856 and those making the associations."
 857   (let lp ((a  alist)
 858            (rl '()))
 859     (if (null? a)
 860         (reverse! rl)
 861         (lp (cdr a) (alist-cons (caar a) (cdar a) rl)))))
 862
 863 (define* (alist-delete key alist #:optional (k= equal?))
 864   (check-arg procedure? k= alist-delete)
 865   (let lp ((a alist) (rl '()))
 866     (if (null? a)
 867         (reverse! rl)
 868         (if (k= key (caar a))
 869             (lp (cdr a) rl)
 870             (lp (cdr a) (cons (car a) rl))))))
 871
 872 (define* (alist-delete! key alist #:optional (k= equal?))
 873   (alist-delete key alist k=))  ; XXX:optimize
 874
 875 ;;; Delete / assoc / member
 876
 877 (define* (member x ls #:optional (= equal?))
 878   (cond
 879    ;; This might be performance-sensitive, so punt on the check here,
 880    ;; relying on memq/memv to check that = is a procedure.
 881    ((eq? = eq?) (memq x ls))
 882    ((eq? = eqv?) (memv x ls))
 883    (else
 884     (check-arg procedure? = member)
 885     (find-tail (lambda (y) (= x y)) ls))))
 886
 887 ;;; Set operations on lists
 888
 889 (define (lset<= = . rest)
 890   (check-arg procedure? = lset<=)
 891   (if (null? rest)
 892       #t
 893       (let lp ((f (car rest)) (r (cdr rest)))
 894         (or (null? r)
 895             (and (every (lambda (el) (member el (car r) =)) f)
 896                  (lp (car r) (cdr r)))))))
 897
 898 (define (lset= = . rest)
 899   (check-arg procedure? = lset<=)
 900   (if (null? rest)
 901     #t
 902     (let lp ((f (car rest)) (r (cdr rest)))
 903       (or (null? r)
 904           (and (every (lambda (el) (member el (car r) =)) f)
 905                (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r))
 906                (lp (car r) (cdr r)))))))
 907
 908 ;; It's not quite clear if duplicates among the `rest' elements are meant to
 909 ;; be cast out.  The spec says `=' is called as (= lstelem restelem),
 910 ;; suggesting perhaps not, but the reference implementation shows the "list"
 911 ;; at each stage as including those elements already added.  The latter
 912 ;; corresponds to what's described for lset-union, so that's what's done.
 913 ;;
 914 (define (lset-adjoin = list . rest)
 915   "Add to LIST any of the elements of REST not already in the list.
 916 These elements are `cons'ed onto the start of LIST (so the return shares
 917 a common tail with LIST), but the order they're added is unspecified.
 918
 919 The given `=' procedure is used for comparing elements, called
 920 as `(@var{=} listelem elem)', i.e., the second argument is one of the
 921 given REST parameters."
 922   ;; If `=' is `eq?' or `eqv?', users won't be able to tell which arg is
 923   ;; first, so we can pass the raw procedure through to `member',
 924   ;; allowing `memq' / `memv' to be selected.
 925   (define pred
 926     (if (or (eq? = eq?) (eq? = eqv?))
 927         =
 928         (begin
 929           (check-arg procedure? = lset-adjoin)
 930           (lambda (x y) (= y x)))))
 931
 932   (let lp ((ans list) (rest rest))
 933     (if (null? rest)
 934         ans
 935         (lp (if (member (car rest) ans pred)
 936                 ans
 937                 (cons (car rest) ans))
 938             (cdr rest)))))
 939
 940 (define (lset-union = . rest)
 941   ;; Likewise, allow memq / memv to be used if possible.
 942   (define pred
 943     (if (or (eq? = eq?) (eq? = eqv?))
 944         =
 945         (begin
 946           (check-arg procedure? = lset-union)
 947           (lambda (x y) (= y x)))))
 948
 949   (fold (lambda (lis ans)               ; Compute ANS + LIS.
 950           (cond ((null? lis) ans)       ; Don't copy any lists
 951                 ((null? ans) lis)       ; if we don't have to.
 952                 ((eq? lis ans) ans)
 953                 (else
 954                  (fold (lambda (elt ans)
 955                          (if (member elt ans pred)
 956                              ans
 957                              (cons elt ans)))
 958                        ans lis))))
 959         '()
 960         rest))
 961
 962 (define (lset-intersection = list1 . rest)
 963   (check-arg procedure? = lset-intersection)
 964   (let lp ((l list1) (acc '()))
 965     (if (null? l)
 966       (reverse! acc)
 967       (if (every (lambda (ll) (member (car l) ll =)) rest)
 968         (lp (cdr l) (cons (car l) acc))
 969         (lp (cdr l) acc)))))
 970
 971 (define (lset-difference = list1 . rest)
 972   (check-arg procedure? = lset-difference)
 973   (if (null? rest)
 974     list1
 975     (let lp ((l list1) (acc '()))
 976       (if (null? l)
 977         (reverse! acc)
 978         (if (any (lambda (ll) (member (car l) ll =)) rest)
 979           (lp (cdr l) acc)
 980           (lp (cdr l) (cons (car l) acc)))))))
 981
 982 ;(define (fold kons knil list1 . rest)
 983
 984 (define (lset-xor = . rest)
 985   (check-arg procedure? = lset-xor)
 986   (fold (lambda (lst res)
 987           (let lp ((l lst) (acc '()))
 988             (if (null? l)
 989               (let lp0 ((r res) (acc acc))
 990                 (if (null? r)
 991                   (reverse! acc)
 992                   (if (member (car r) lst =)
 993                     (lp0 (cdr r) acc)
 994                     (lp0 (cdr r) (cons (car r) acc)))))
 995               (if (member (car l) res =)
 996                 (lp (cdr l) acc)
 997                 (lp (cdr l) (cons (car l) acc))))))
 998         '()
 999         rest))
1000
1001 (define (lset-diff+intersection = list1 . rest)
1002   (check-arg procedure? = lset-diff+intersection)
1003   (let lp ((l list1) (accd '()) (acci '()))
1004     (if (null? l)
1005       (values (reverse! accd) (reverse! acci))
1006       (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
1007         (if appears
1008           (lp (cdr l) accd (cons (car l) acci))
1009           (lp (cdr l) (cons (car l) accd) acci))))))
1010
1011
1012 (define (lset-union! = . rest)
1013   (check-arg procedure? = lset-union!)
1014   (apply lset-union = rest))            ; XXX:optimize
1015
1016 (define (lset-intersection! = list1 . rest)
1017   (check-arg procedure? = lset-intersection!)
1018   (apply lset-intersection = list1 rest)) ; XXX:optimize
1019
1020 (define (lset-xor! = . rest)
1021   (check-arg procedure? = lset-xor!)
1022   (apply lset-xor = rest))              ; XXX:optimize
1023
1024 (define (lset-diff+intersection! = list1 . rest)
1025   (check-arg procedure? = lset-diff+intersection!)
1026   (apply lset-diff+intersection = list1 rest)) ; XXX:optimize
1027
1028 ;;; srfi-1.scm ends here