module/srfi/srfi-43.scm

   1 ;;; srfi-43.scm -- SRFI 43 Vector library
   2
   3 ;;      Copyright (C) 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 ;;; Author: Mark H Weaver <mhw@netris.org>
  20
  21 (define-module (srfi srfi-43)
  22   #:use-module (srfi srfi-1)
  23   #:use-module (srfi srfi-8)
  24   #:re-export (make-vector vector vector? vector-ref vector-set!
  25                            vector-length)
  26   #:replace (vector-copy vector-fill! list->vector vector->list)
  27   #:export (vector-empty? vector= vector-unfold vector-unfold-right
  28                           vector-reverse-copy
  29                           vector-append vector-concatenate
  30                           vector-fold vector-fold-right
  31                           vector-map vector-map!
  32                           vector-for-each vector-count
  33                           vector-index vector-index-right
  34                           vector-skip vector-skip-right
  35                           vector-binary-search
  36                           vector-any vector-every
  37                           vector-swap! vector-reverse!
  38                           vector-copy! vector-reverse-copy!
  39                           reverse-vector->list
  40                           reverse-list->vector))
  41
  42 (cond-expand-provide (current-module) '(srfi-43))
  43
  44 (define (error-from who msg . args)
  45   (apply error
  46          (string-append (symbol->string who) ": " msg)
  47          args))
  48
  49 (define-syntax-rule (assert-nonneg-exact-integer k who)
  50   (unless (and (exact-integer? k)
  51                (not (negative? k)))
  52     (error-from who "expected non-negative exact integer, got" k)))
  53
  54 (define-syntax-rule (assert-procedure f who)
  55   (unless (procedure? f)
  56     (error-from who "expected procedure, got" f)))
  57
  58 (define-syntax-rule (assert-vector v who)
  59   (unless (vector? v)
  60     (error-from who "expected vector, got" v)))
  61
  62 (define-syntax-rule (assert-valid-index i len who)
  63   (unless (and (exact-integer? i)
  64                (<= 0 i len))
  65     (error-from who "invalid index" i)))
  66
  67 (define-syntax-rule (assert-valid-start start len who)
  68   (unless (and (exact-integer? start)
  69                (<= 0 start len))
  70     (error-from who "invalid start index" start)))
  71
  72 (define-syntax-rule (assert-valid-range start end len who)
  73   (unless (and (exact-integer? start)
  74                (exact-integer? end)
  75                (<= 0 start end len))
  76     (error-from who "invalid index range" start end)))
  77
  78 (define-syntax-rule (assert-vectors vs who)
  79   (let loop ((vs vs))
  80     (unless (null? vs)
  81       (assert-vector (car vs) who)
  82       (loop (cdr vs)))))
  83
  84 ;; Return the length of the shortest vector in VS.
  85 ;; VS must have at least one element.
  86 (define (min-length vs)
  87   (let loop ((vs (cdr vs))
  88              (result (vector-length (car vs))))
  89     (if (null? vs)
  90         result
  91         (loop (cdr vs) (min result (vector-length (car vs)))))))
  92
  93 ;; Return a list of the Ith elements of the vectors in VS.
  94 (define (vectors-ref vs i)
  95   (let loop ((vs vs) (xs '()))
  96     (if (null? vs)
  97         (reverse! xs)
  98         (loop (cdr vs) (cons (vector-ref (car vs) i)
  99                              xs)))))
 100
 101 (define vector-unfold
 102   (case-lambda
 103     "(vector-unfold f length initial-seed ...) -> vector
 104
 105 The fundamental vector constructor.  Create a vector whose length is
 106 LENGTH and iterates across each index k from 0 up to LENGTH - 1,
 107 applying F at each iteration to the current index and current seeds,
 108 in that order, to receive n + 1 values: first, the element to put in
 109 the kth slot of the new vector and n new seeds for the next iteration.
 110 It is an error for the number of seeds to vary between iterations."
 111     ((f len)
 112      (assert-procedure f 'vector-unfold)
 113      (assert-nonneg-exact-integer len 'vector-unfold)
 114      (let ((v (make-vector len)))
 115        (let loop ((i 0))
 116          (unless (= i len)
 117            (vector-set! v i (f i))
 118            (loop (+ i 1))))
 119        v))
 120     ((f len seed)
 121      (assert-procedure f 'vector-unfold)
 122      (assert-nonneg-exact-integer len 'vector-unfold)
 123      (let ((v (make-vector len)))
 124        (let loop ((i 0) (seed seed))
 125          (unless (= i len)
 126            (receive (x seed) (f i seed)
 127              (vector-set! v i x)
 128              (loop (+ i 1) seed))))
 129        v))
 130     ((f len seed1 seed2)
 131      (assert-procedure f 'vector-unfold)
 132      (assert-nonneg-exact-integer len 'vector-unfold)
 133      (let ((v (make-vector len)))
 134        (let loop ((i 0) (seed1 seed1) (seed2 seed2))
 135          (unless (= i len)
 136            (receive (x seed1 seed2) (f i seed1 seed2)
 137              (vector-set! v i x)
 138              (loop (+ i 1) seed1 seed2))))
 139        v))
 140     ((f len . seeds)
 141      (assert-procedure f 'vector-unfold)
 142      (assert-nonneg-exact-integer len 'vector-unfold)
 143      (let ((v (make-vector len)))
 144        (let loop ((i 0) (seeds seeds))
 145          (unless (= i len)
 146            (receive (x . seeds) (apply f i seeds)
 147              (vector-set! v i x)
 148              (loop (+ i 1) seeds))))
 149        v))))
 150
 151 (define vector-unfold-right
 152   (case-lambda
 153     "(vector-unfold-right f length initial-seed ...) -> vector
 154
 155 The fundamental vector constructor.  Create a vector whose length is
 156 LENGTH and iterates across each index k from LENGTH - 1 down to 0,
 157 applying F at each iteration to the current index and current seeds,
 158 in that order, to receive n + 1 values: first, the element to put in
 159 the kth slot of the new vector and n new seeds for the next iteration.
 160 It is an error for the number of seeds to vary between iterations."
 161     ((f len)
 162      (assert-procedure f 'vector-unfold-right)
 163      (assert-nonneg-exact-integer len 'vector-unfold-right)
 164      (let ((v (make-vector len)))
 165        (let loop ((i (- len 1)))
 166          (unless (negative? i)
 167            (vector-set! v i (f i))
 168            (loop (- i 1))))
 169        v))
 170     ((f len seed)
 171      (assert-procedure f 'vector-unfold-right)
 172      (assert-nonneg-exact-integer len 'vector-unfold-right)
 173      (let ((v (make-vector len)))
 174        (let loop ((i (- len 1)) (seed seed))
 175          (unless (negative? i)
 176            (receive (x seed) (f i seed)
 177              (vector-set! v i x)
 178              (loop (- i 1) seed))))
 179        v))
 180     ((f len seed1 seed2)
 181      (assert-procedure f 'vector-unfold-right)
 182      (assert-nonneg-exact-integer len 'vector-unfold-right)
 183      (let ((v (make-vector len)))
 184        (let loop ((i (- len 1)) (seed1 seed1) (seed2 seed2))
 185          (unless (negative? i)
 186            (receive (x seed1 seed2) (f i seed1 seed2)
 187              (vector-set! v i x)
 188              (loop (- i 1) seed1 seed2))))
 189        v))
 190     ((f len . seeds)
 191      (assert-procedure f 'vector-unfold-right)
 192      (assert-nonneg-exact-integer len 'vector-unfold-right)
 193      (let ((v (make-vector len)))
 194        (let loop ((i (- len 1)) (seeds seeds))
 195          (unless (negative? i)
 196            (receive (x . seeds) (apply f i seeds)
 197              (vector-set! v i x)
 198              (loop (- i 1) seeds))))
 199        v))))
 200
 201 (define guile-vector-copy (@ (guile) vector-copy))
 202
 203 ;; TODO: Enhance Guile core 'vector-copy' to do this.
 204 (define vector-copy
 205   (case-lambda*
 206    "(vector-copy vec [start [end [fill]]]) -> vector
 207
 208 Allocate a new vector whose length is END - START and fills it with
 209 elements from vec, taking elements from vec starting at index START
 210 and stopping at index END.  START defaults to 0 and END defaults to
 211 the value of (vector-length VEC).  If END extends beyond the length of
 212 VEC, the slots in the new vector that obviously cannot be filled by
 213 elements from VEC are filled with FILL, whose default value is
 214 unspecified."
 215    ((v) (guile-vector-copy v))
 216    ((v start)
 217     (assert-vector v 'vector-copy)
 218     (let ((len (vector-length v)))
 219       (assert-valid-start start len 'vector-copy)
 220       (let ((result (make-vector (- len start))))
 221         (vector-move-left! v start len result 0)
 222         result)))
 223    ((v start end #:optional (fill *unspecified*))
 224     (assert-vector v 'vector-copy)
 225     (let ((len (vector-length v)))
 226       (unless (and (exact-integer? start)
 227                    (exact-integer? end)
 228                    (<= 0 start end))
 229         (error-from 'vector-copy "invalid index range" start end))
 230       (let ((result (make-vector (- end start) fill)))
 231         (vector-move-left! v start (min end len) result 0)
 232         result)))))
 233
 234 (define vector-reverse-copy
 235   (let ()
 236     (define (%vector-reverse-copy vec start end)
 237       (let* ((len (- end start))
 238              (result (make-vector len)))
 239         (let loop ((i 0) (j (- end 1)))
 240           (unless (= i len)
 241             (vector-set! result i (vector-ref vec j))
 242             (loop (+ i 1) (- j 1))))
 243         result))
 244     (case-lambda
 245       "(vector-reverse-copy vec [start [end]]) -> vector
 246
 247 Allocate a new vector whose length is END - START and fills it with
 248 elements from vec, taking elements from vec in reverse order starting
 249 at index START and stopping at index END.  START defaults to 0 and END
 250 defaults to the value of (vector-length VEC)."
 251       ((vec)
 252        (assert-vector vec 'vector-reverse-copy)
 253        (%vector-reverse-copy vec 0 (vector-length vec)))
 254       ((vec start)
 255        (assert-vector vec 'vector-reverse-copy)
 256        (let ((len (vector-length vec)))
 257          (assert-valid-start start len 'vector-reverse-copy)
 258          (%vector-reverse-copy vec start len)))
 259       ((vec start end)
 260        (assert-vector vec 'vector-reverse-copy)
 261        (let ((len (vector-length vec)))
 262          (assert-valid-range start end len 'vector-reverse-copy)
 263          (%vector-reverse-copy vec start end))))))
 264
 265 (define (%vector-concatenate vs)
 266   (let* ((result-len (let loop ((vs vs) (len 0))
 267                        (if (null? vs)
 268                            len
 269                            (loop (cdr vs) (+ len (vector-length (car vs)))))))
 270          (result (make-vector result-len)))
 271     (let loop ((vs vs) (pos 0))
 272       (unless (null? vs)
 273         (let* ((v (car vs))
 274                (len (vector-length v)))
 275           (vector-move-left! v 0 len result pos)
 276           (loop (cdr vs) (+ pos len)))))
 277     result))
 278
 279 (define vector-append
 280   (case-lambda
 281     "(vector-append vec ...) -> vector
 282
 283 Return a newly allocated vector that contains all elements in order
 284 from the subsequent locations in VEC ..."
 285     (() (vector))
 286     ((v)
 287      (assert-vector v 'vector-append)
 288      (guile-vector-copy v))
 289     ((v1 v2)
 290      (assert-vector v1 'vector-append)
 291      (assert-vector v2 'vector-append)
 292      (let ((len1 (vector-length v1))
 293            (len2 (vector-length v2)))
 294        (let ((result (make-vector (+ len1 len2))))
 295          (vector-move-left! v1 0 len1 result 0)
 296          (vector-move-left! v2 0 len2 result len1)
 297          result)))
 298     (vs
 299      (assert-vectors vs 'vector-append)
 300      (%vector-concatenate vs))))
 301
 302 (define (vector-concatenate vs)
 303   "(vector-concatenate list-of-vectors) -> vector
 304
 305 Append each vector in LIST-OF-VECTORS.  Equivalent to:
 306   (apply vector-append LIST-OF-VECTORS)"
 307   (assert-vectors vs 'vector-append)
 308   (%vector-concatenate vs))
 309
 310 (define (vector-empty? vec)
 311   "(vector-empty? vec) -> boolean
 312
 313 Return true if VEC is empty, i.e. its length is 0, and false if not."
 314   (assert-vector vec 'vector-empty?)
 315   (zero? (vector-length vec)))
 316
 317 (define vector=
 318   (let ()
 319     (define (all-of-length? len vs)
 320       (or (null? vs)
 321           (and (= len (vector-length (car vs)))
 322                (all-of-length? len (cdr vs)))))
 323     (define (=up-to? i elt=? v1 v2)
 324       (or (negative? i)
 325           (let ((x1 (vector-ref v1 i))
 326                 (x2 (vector-ref v2 i)))
 327             (and (or (eq? x1 x2) (elt=? x1 x2))
 328                  (=up-to? (- i 1) elt=? v1 v2)))))
 329     (case-lambda
 330       "(vector= elt=? vec ...) -> boolean
 331
 332 Return true if the vectors VEC ... have equal lengths and equal
 333 elements according to ELT=?.  ELT=? is always applied to two
 334 arguments.  Element comparison must be consistent with eq?, in the
 335 following sense: if (eq? a b) returns true, then (elt=? a b) must also
 336 return true.  The order in which comparisons are performed is
 337 unspecified."
 338       ((elt=?)
 339        (assert-procedure elt=? 'vector=)
 340        #t)
 341       ((elt=? v)
 342        (assert-procedure elt=? 'vector=)
 343        (assert-vector v 'vector=)
 344        #t)
 345       ((elt=? v1 v2)
 346        (assert-procedure elt=? 'vector=)
 347        (assert-vector v1 'vector=)
 348        (assert-vector v2 'vector=)
 349        (let ((len (vector-length v1)))
 350          (and (= len (vector-length v2))
 351               (=up-to? (- len 1) elt=? v1 v2))))
 352       ((elt=? v1 . vs)
 353        (assert-procedure elt=? 'vector=)
 354        (assert-vector  v1 'vector=)
 355        (assert-vectors vs 'vector=)
 356        (let ((len (vector-length v1)))
 357          (and (all-of-length? len vs)
 358               (let loop ((vs vs))
 359                 (or (null? vs)
 360                     (and (=up-to? (- len 1) elt=? v1 (car vs))
 361                          (loop (cdr vs)))))))))))
 362
 363 (define vector-fold
 364   (case-lambda
 365     "(vector-fold kons knil vec1 vec2 ...) -> value
 366
 367 The fundamental vector iterator.  KONS is iterated over each index in
 368 all of the vectors, stopping at the end of the shortest; KONS is
 369 applied as (KONS i state (vector-ref VEC1 i) (vector-ref VEC2 i) ...)
 370 where STATE is the current state value, and I is the current index.
 371 The current state value begins with KNIL, and becomes whatever KONS
 372 returned at the respective iteration.  The iteration is strictly
 373 left-to-right."
 374     ((kcons knil v)
 375      (assert-procedure kcons 'vector-fold)
 376      (assert-vector v 'vector-fold)
 377      (let ((len (vector-length v)))
 378        (let loop ((i 0) (state knil))
 379          (if (= i len)
 380              state
 381              (loop (+ i 1) (kcons i state (vector-ref v i)))))))
 382     ((kcons knil v1 v2)
 383      (assert-procedure kcons 'vector-fold)
 384      (assert-vector v1 'vector-fold)
 385      (assert-vector v2 'vector-fold)
 386      (let ((len (min (vector-length v1) (vector-length v2))))
 387        (let loop ((i 0) (state knil))
 388          (if (= i len)
 389              state
 390              (loop (+ i 1)
 391                    (kcons i state (vector-ref v1 i) (vector-ref v2 i)))))))
 392     ((kcons knil . vs)
 393      (assert-procedure kcons 'vector-fold)
 394      (assert-vectors vs 'vector-fold)
 395      (let ((len (min-length vs)))
 396        (let loop ((i 0) (state knil))
 397          (if (= i len)
 398              state
 399              (loop (+ i 1) (apply kcons i state (vectors-ref vs i)))))))))
 400
 401 (define vector-fold-right
 402   (case-lambda
 403     "(vector-fold-right kons knil vec1 vec2 ...) -> value
 404
 405 The fundamental vector iterator.  KONS is iterated over each index in
 406 all of the vectors, starting at the end of the shortest; KONS is
 407 applied as (KONS i state (vector-ref VEC1 i) (vector-ref VEC2 i) ...)
 408 where STATE is the current state value, and I is the current index.
 409 The current state value begins with KNIL, and becomes whatever KONS
 410 returned at the respective iteration.  The iteration is strictly
 411 right-to-left."
 412     ((kcons knil v)
 413      (assert-procedure kcons 'vector-fold-right)
 414      (assert-vector v 'vector-fold-right)
 415      (let ((len (vector-length v)))
 416        (let loop ((i (- len 1)) (state knil))
 417          (if (negative? i)
 418              state
 419              (loop (- i 1) (kcons i state (vector-ref v i)))))))
 420     ((kcons knil v1 v2)
 421      (assert-procedure kcons 'vector-fold-right)
 422      (assert-vector v1 'vector-fold-right)
 423      (assert-vector v2 'vector-fold-right)
 424      (let ((len (min (vector-length v1) (vector-length v2))))
 425        (let loop ((i (- len 1)) (state knil))
 426          (if (negative? i)
 427              state
 428              (loop (- i 1)
 429                    (kcons i state (vector-ref v1 i) (vector-ref v2 i)))))))
 430     ((kcons knil . vs)
 431      (assert-procedure kcons 'vector-fold-right)
 432      (assert-vectors vs 'vector-fold-right)
 433      (let ((len (min-length vs)))
 434        (let loop ((i (- len 1)) (state knil))
 435          (if (negative? i)
 436              state
 437              (loop (- i 1) (apply kcons i state (vectors-ref vs i)))))))))
 438
 439 (define vector-map
 440   (case-lambda
 441     "(vector-map f vec2 vec2 ...) -> vector
 442
 443 Return a new vector of the shortest size of the vector arguments.
 444 Each element at index i of the new vector is mapped from the old
 445 vectors by (F i (vector-ref VEC1 i) (vector-ref VEC2 i) ...).  The
 446 dynamic order of application of F is unspecified."
 447     ((f v)
 448      (assert-procedure f 'vector-map)
 449      (assert-vector v 'vector-map)
 450      (let* ((len (vector-length v))
 451             (result (make-vector len)))
 452        (let loop ((i 0))
 453          (unless (= i len)
 454            (vector-set! result i (f i (vector-ref v i)))
 455            (loop (+ i 1))))
 456        result))
 457     ((f v1 v2)
 458      (assert-procedure f 'vector-map)
 459      (assert-vector v1 'vector-map)
 460      (assert-vector v2 'vector-map)
 461      (let* ((len (min (vector-length v1) (vector-length v2)))
 462             (result (make-vector len)))
 463        (let loop ((i 0))
 464          (unless (= i len)
 465            (vector-set! result i (f i (vector-ref v1 i) (vector-ref v2 i)))
 466            (loop (+ i 1))))
 467        result))
 468     ((f . vs)
 469      (assert-procedure f 'vector-map)
 470      (assert-vectors vs 'vector-map)
 471      (let* ((len (min-length vs))
 472             (result (make-vector len)))
 473        (let loop ((i 0))
 474          (unless (= i len)
 475            (vector-set! result i (apply f i (vectors-ref vs i)))
 476            (loop (+ i 1))))
 477        result))))
 478
 479 (define vector-map!
 480   (case-lambda
 481     "(vector-map! f vec2 vec2 ...) -> unspecified
 482
 483 Similar to vector-map, but rather than mapping the new elements into a
 484 new vector, the new mapped elements are destructively inserted into
 485 VEC1.  The dynamic order of application of F is unspecified."
 486     ((f v)
 487      (assert-procedure f 'vector-map!)
 488      (assert-vector v 'vector-map!)
 489      (let ((len (vector-length v)))
 490        (let loop ((i 0))
 491          (unless (= i len)
 492            (vector-set! v i (f i (vector-ref v i)))
 493            (loop (+ i 1))))))
 494     ((f v1 v2)
 495      (assert-procedure f 'vector-map!)
 496      (assert-vector v1 'vector-map!)
 497      (assert-vector v2 'vector-map!)
 498      (let ((len (min (vector-length v1) (vector-length v2))))
 499        (let loop ((i 0))
 500          (unless (= i len)
 501            (vector-set! v1 i (f i (vector-ref v1 i) (vector-ref v2 i)))
 502            (loop (+ i 1))))))
 503     ((f . vs)
 504      (assert-procedure f 'vector-map!)
 505      (assert-vectors vs 'vector-map!)
 506      (let ((len (min-length vs))
 507            (v1 (car vs)))
 508        (let loop ((i 0))
 509          (unless (= i len)
 510            (vector-set! v1 i (apply f i (vectors-ref vs i)))
 511            (loop (+ i 1))))))))
 512
 513 (define vector-for-each
 514   (case-lambda
 515     "(vector-for-each f vec1 vec2 ...) -> unspecified
 516
 517 Call (F i VEC1[i] VEC2[i] ...) for each index i less than the length
 518 of the shortest vector passed.  The iteration is strictly
 519 left-to-right."
 520     ((f v)
 521      (assert-procedure f 'vector-for-each)
 522      (assert-vector v 'vector-for-each)
 523      (let ((len (vector-length v)))
 524        (let loop ((i 0))
 525          (unless (= i len)
 526            (f i (vector-ref v i))
 527            (loop (+ i 1))))))
 528     ((f v1 v2)
 529      (assert-procedure f 'vector-for-each)
 530      (assert-vector v1 'vector-for-each)
 531      (assert-vector v2 'vector-for-each)
 532      (let ((len (min (vector-length v1)
 533                      (vector-length v2))))
 534        (let loop ((i 0))
 535          (unless (= i len)
 536            (f i (vector-ref v1 i) (vector-ref v2 i))
 537            (loop (+ i 1))))))
 538     ((f . vs)
 539      (assert-procedure f 'vector-for-each)
 540      (assert-vectors vs 'vector-for-each)
 541      (let ((len (min-length vs)))
 542        (let loop ((i 0))
 543          (unless (= i len)
 544            (apply f i (vectors-ref vs i))
 545            (loop (+ i 1))))))))
 546
 547 (define vector-count
 548   (case-lambda
 549     "(vector-count pred? vec1 vec2 ...) -> exact nonnegative integer
 550
 551 Count the number of indices i for which (PRED? VEC1[i] VEC2[i] ...)
 552 returns true, where i is less than the length of the shortest vector
 553 passed."
 554     ((pred? v)
 555      (assert-procedure pred? 'vector-count)
 556      (assert-vector v 'vector-count)
 557      (let ((len (vector-length v)))
 558        (let loop ((i 0) (count 0))
 559          (cond ((= i len) count)
 560                ((pred? i (vector-ref v i))
 561                 (loop (+ i 1) (+ count 1)))
 562                (else
 563                 (loop (+ i 1) count))))))
 564     ((pred? v1 v2)
 565      (assert-procedure pred? 'vector-count)
 566      (assert-vector v1 'vector-count)
 567      (assert-vector v2 'vector-count)
 568      (let ((len (min (vector-length v1)
 569                      (vector-length v2))))
 570        (let loop ((i 0) (count 0))
 571          (cond ((= i len) count)
 572                ((pred? i (vector-ref v1 i) (vector-ref v2 i))
 573                 (loop (+ i 1) (+ count 1)))
 574                (else
 575                 (loop (+ i 1) count))))))
 576     ((pred? . vs)
 577      (assert-procedure pred? 'vector-count)
 578      (assert-vectors vs 'vector-count)
 579      (let ((len (min-length vs)))
 580        (let loop ((i 0) (count 0))
 581          (cond ((= i len) count)
 582                ((apply pred? i (vectors-ref vs i))
 583                 (loop (+ i 1) (+ count 1)))
 584                (else
 585                 (loop (+ i 1) count))))))))
 586
 587 (define vector-index
 588   (case-lambda
 589     "(vector-index pred? vec1 vec2 ...) -> exact nonnegative integer or #f
 590
 591 Find and return the index of the first elements in VEC1 VEC2 ... that
 592 satisfy PRED?.  If no matching element is found by the end of the
 593 shortest vector, return #f."
 594     ((pred? v)
 595      (assert-procedure pred? 'vector-index)
 596      (assert-vector v 'vector-index)
 597      (let ((len (vector-length v)))
 598        (let loop ((i 0))
 599          (and (< i len)
 600               (if (pred? (vector-ref v i))
 601                   i
 602                   (loop (+ i 1)))))))
 603     ((pred? v1 v2)
 604      (assert-procedure pred? 'vector-index)
 605      (assert-vector v1 'vector-index)
 606      (assert-vector v2 'vector-index)
 607      (let ((len (min (vector-length v1)
 608                      (vector-length v2))))
 609        (let loop ((i 0))
 610          (and (< i len)
 611               (if (pred? (vector-ref v1 i)
 612                          (vector-ref v2 i))
 613                   i
 614                   (loop (+ i 1)))))))
 615     ((pred? . vs)
 616      (assert-procedure pred? 'vector-index)
 617      (assert-vectors vs 'vector-index)
 618      (let ((len (min-length vs)))
 619        (let loop ((i 0))
 620          (and (< i len)
 621               (if (apply pred? (vectors-ref vs i))
 622                   i
 623                   (loop (+ i 1)))))))))
 624
 625 (define vector-index-right
 626   (case-lambda
 627     "(vector-index-right pred? vec1 vec2 ...) -> exact nonnegative integer or #f
 628
 629 Find and return the index of the last elements in VEC1 VEC2 ... that
 630 satisfy PRED?, searching from right-to-left.  If no matching element
 631 is found before the end of the shortest vector, return #f."
 632     ((pred? v)
 633      (assert-procedure pred? 'vector-index-right)
 634      (assert-vector v 'vector-index-right)
 635      (let ((len (vector-length v)))
 636        (let loop ((i (- len 1)))
 637          (and (>= i 0)
 638               (if (pred? (vector-ref v i))
 639                   i
 640                   (loop (- i 1)))))))
 641     ((pred? v1 v2)
 642      (assert-procedure pred? 'vector-index-right)
 643      (assert-vector v1 'vector-index-right)
 644      (assert-vector v2 'vector-index-right)
 645      (let ((len (min (vector-length v1)
 646                      (vector-length v2))))
 647        (let loop ((i (- len 1)))
 648          (and (>= i 0)
 649               (if (pred? (vector-ref v1 i)
 650                          (vector-ref v2 i))
 651                   i
 652                   (loop (- i 1)))))))
 653     ((pred? . vs)
 654      (assert-procedure pred? 'vector-index-right)
 655      (assert-vectors vs 'vector-index-right)
 656      (let ((len (min-length vs)))
 657        (let loop ((i (- len 1)))
 658          (and (>= i 0)
 659               (if (apply pred? (vectors-ref vs i))
 660                   i
 661                   (loop (- i 1)))))))))
 662
 663 (define vector-skip
 664   (case-lambda
 665     "(vector-skip pred? vec1 vec2 ...) -> exact nonnegative integer or #f
 666
 667 Find and return the index of the first elements in VEC1 VEC2 ... that
 668 do not satisfy PRED?.  If no matching element is found by the end of
 669 the shortest vector, return #f."
 670     ((pred? v)
 671      (assert-procedure pred? 'vector-skip)
 672      (assert-vector v 'vector-skip)
 673      (let ((len (vector-length v)))
 674        (let loop ((i 0))
 675          (and (< i len)
 676               (if (pred? (vector-ref v i))
 677                   (loop (+ i 1))
 678                   i)))))
 679     ((pred? v1 v2)
 680      (assert-procedure pred? 'vector-skip)
 681      (assert-vector v1 'vector-skip)
 682      (assert-vector v2 'vector-skip)
 683      (let ((len (min (vector-length v1)
 684                      (vector-length v2))))
 685        (let loop ((i 0))
 686          (and (< i len)
 687               (if (pred? (vector-ref v1 i)
 688                          (vector-ref v2 i))
 689                   (loop (+ i 1))
 690                   i)))))
 691     ((pred? . vs)
 692      (assert-procedure pred? 'vector-skip)
 693      (assert-vectors vs 'vector-skip)
 694      (let ((len (min-length vs)))
 695        (let loop ((i 0))
 696          (and (< i len)
 697               (if (apply pred? (vectors-ref vs i))
 698                   (loop (+ i 1))
 699                   i)))))))
 700
 701 (define vector-skip-right
 702   (case-lambda
 703     "(vector-skip-right pred? vec1 vec2 ...) -> exact nonnegative integer or #f
 704
 705 Find and return the index of the last elements in VEC1 VEC2 ... that
 706 do not satisfy PRED?, searching from right-to-left.  If no matching
 707 element is found before the end of the shortest vector, return #f."
 708     ((pred? v)
 709      (assert-procedure pred? 'vector-skip-right)
 710      (assert-vector v 'vector-skip-right)
 711      (let ((len (vector-length v)))
 712        (let loop ((i (- len 1)))
 713          (and (not (negative? i))
 714               (if (pred? (vector-ref v i))
 715                   (loop (- i 1))
 716                   i)))))
 717     ((pred? v1 v2)
 718      (assert-procedure pred? 'vector-skip-right)
 719      (assert-vector v1 'vector-skip-right)
 720      (assert-vector v2 'vector-skip-right)
 721      (let ((len (min (vector-length v1)
 722                      (vector-length v2))))
 723        (let loop ((i (- len 1)))
 724          (and (not (negative? i))
 725               (if (pred? (vector-ref v1 i)
 726                          (vector-ref v2 i))
 727                   (loop (- i 1))
 728                   i)))))
 729     ((pred? . vs)
 730      (assert-procedure pred? 'vector-skip-right)
 731      (assert-vectors vs 'vector-skip-right)
 732      (let ((len (min-length vs)))
 733        (let loop ((i (- len 1)))
 734          (and (not (negative? i))
 735               (if (apply pred? (vectors-ref vs i))
 736                   (loop (- i 1))
 737                   i)))))))
 738
 739 (define vector-binary-search
 740   (let ()
 741     (define (%vector-binary-search vec value cmp start end)
 742       (let loop ((lo start) (hi end))
 743         (and (< lo hi)
 744              (let* ((i (quotient (+ lo hi) 2))
 745                     (x (vector-ref vec i))
 746                     (c (cmp x value)))
 747                (cond ((zero? c) i)
 748                      ((positive? c) (loop lo i))
 749                      ((negative? c) (loop (+ i 1) hi)))))))
 750     (case-lambda
 751       "(vector-binary-search vec value cmp [start [end]]) -> exact nonnegative integer or #f
 752
 753 Find and return an index of VEC between START and END whose value is
 754 VALUE using a binary search.  If no matching element is found, return
 755 #f.  The default START is 0 and the default END is the length of VEC.
 756 CMP must be a procedure of two arguments such that (CMP A B) returns
 757 a negative integer if A < B, a positive integer if A > B, or zero if
 758 A = B.  The elements of VEC must be sorted in non-decreasing order
 759 according to CMP."
 760       ((vec value cmp)
 761        (assert-vector vec 'vector-binary-search)
 762        (assert-procedure cmp 'vector-binary-search)
 763        (%vector-binary-search vec value cmp 0 (vector-length vec)))
 764
 765       ((vec value cmp start)
 766        (assert-vector vec 'vector-binary-search)
 767        (let ((len (vector-length vec)))
 768          (assert-valid-start start len 'vector-binary-search)
 769          (%vector-binary-search vec value cmp start len)))
 770
 771       ((vec value cmp start end)
 772        (assert-vector vec 'vector-binary-search)
 773        (let ((len (vector-length vec)))
 774          (assert-valid-range start end len 'vector-binary-search)
 775          (%vector-binary-search vec value cmp start end))))))
 776
 777 (define vector-any
 778   (case-lambda
 779     "(vector-any pred? vec1 vec2 ...) -> value or #f
 780
 781 Find the first parallel set of elements from VEC1 VEC2 ... for which
 782 PRED? returns a true value.  If such a parallel set of elements
 783 exists, vector-any returns the value that PRED? returned for that set
 784 of elements.  The iteration is strictly left-to-right."
 785     ((pred? v)
 786      (assert-procedure pred? 'vector-any)
 787      (assert-vector v 'vector-any)
 788      (let ((len (vector-length v)))
 789        (let loop ((i 0))
 790          (and (< i len)
 791               (or (pred? (vector-ref v i))
 792                   (loop (+ i 1)))))))
 793     ((pred? v1 v2)
 794      (assert-procedure pred? 'vector-any)
 795      (assert-vector v1 'vector-any)
 796      (assert-vector v2 'vector-any)
 797      (let ((len (min (vector-length v1)
 798                      (vector-length v2))))
 799        (let loop ((i 0))
 800          (and (< i len)
 801               (or (pred? (vector-ref v1 i)
 802                          (vector-ref v2 i))
 803                   (loop (+ i 1)))))))
 804     ((pred? . vs)
 805      (assert-procedure pred? 'vector-any)
 806      (assert-vectors vs 'vector-any)
 807      (let ((len (min-length vs)))
 808        (let loop ((i 0))
 809          (and (< i len)
 810               (or (apply pred? (vectors-ref vs i))
 811                   (loop (+ i 1)))))))))
 812
 813 (define vector-every
 814   (case-lambda
 815     "(vector-every pred? vec1 vec2 ...) -> value or #f
 816
 817 If, for every index i less than the length of the shortest vector
 818 argument, the set of elements VEC1[i] VEC2[i] ... satisfies PRED?,
 819 vector-every returns the value that PRED? returned for the last set of
 820 elements, at the last index of the shortest vector.  The iteration is
 821 strictly left-to-right."
 822     ((pred? v)
 823      (assert-procedure pred? 'vector-every)
 824      (assert-vector v 'vector-every)
 825      (let ((len (vector-length v)))
 826        (or (zero? len)
 827            (let loop ((i 0))
 828              (let ((val (pred? (vector-ref v i)))
 829                    (next-i (+ i 1)))
 830                (if (or (not val) (= next-i len))
 831                    val
 832                    (loop next-i)))))))
 833     ((pred? v1 v2)
 834      (assert-procedure pred? 'vector-every)
 835      (assert-vector v1 'vector-every)
 836      (assert-vector v2 'vector-every)
 837      (let ((len (min (vector-length v1)
 838                      (vector-length v2))))
 839        (or (zero? len)
 840            (let loop ((i 0))
 841              (let ((val (pred? (vector-ref v1 i)
 842                                (vector-ref v2 i)))
 843                    (next-i (+ i 1)))
 844                (if (or (not val) (= next-i len))
 845                    val
 846                    (loop next-i)))))))
 847     ((pred? . vs)
 848      (assert-procedure pred? 'vector-every)
 849      (assert-vectors vs 'vector-every)
 850      (let ((len (min-length vs)))
 851        (or (zero? len)
 852            (let loop ((i 0))
 853              (let ((val (apply pred? (vectors-ref vs i)))
 854                    (next-i (+ i 1)))
 855                (if (or (not val) (= next-i len))
 856                    val
 857                    (loop next-i)))))))))
 858
 859 (define (vector-swap! vec i j)
 860   "(vector-swap! vec i j) -> unspecified
 861
 862 Swap the values of the locations in VEC at I and J."
 863   (assert-vector vec 'vector-swap!)
 864   (let ((len (vector-length vec)))
 865     (assert-valid-index i len 'vector-swap!)
 866     (assert-valid-index j len 'vector-swap!)
 867     (let ((tmp (vector-ref vec i)))
 868       (vector-set! vec i (vector-ref vec j))
 869       (vector-set! vec j tmp))))
 870
 871 ;; TODO: Enhance Guile core 'vector-fill!' to do this.
 872 (define vector-fill!
 873   (let ()
 874     (define guile-vector-fill!
 875       (@ (guile) vector-fill!))
 876     (define (%vector-fill! vec fill start end)
 877       (let loop ((i start))
 878         (when (< i end)
 879           (vector-set! vec i fill)
 880           (loop (+ i 1)))))
 881     (case-lambda
 882       "(vector-fill! vec fill [start [end]]) -> unspecified
 883
 884 Assign the value of every location in VEC between START and END to
 885 FILL.  START defaults to 0 and END defaults to the length of VEC."
 886       ((vec fill)
 887        (guile-vector-fill! vec fill))
 888       ((vec fill start)
 889        (assert-vector vec 'vector-fill!)
 890        (let ((len (vector-length vec)))
 891          (assert-valid-start start len 'vector-fill!)
 892          (%vector-fill! vec fill start len)))
 893       ((vec fill start end)
 894        (assert-vector vec 'vector-fill!)
 895        (let ((len (vector-length vec)))
 896          (assert-valid-range start end len 'vector-fill!)
 897          (%vector-fill! vec fill start end))))))
 898
 899 (define (%vector-reverse! vec start end)
 900   (let loop ((i start) (j (- end 1)))
 901     (when (< i j)
 902       (let ((tmp (vector-ref vec i)))
 903         (vector-set! vec i (vector-ref vec j))
 904         (vector-set! vec j tmp)
 905         (loop (+ i 1) (- j 1))))))
 906
 907 (define vector-reverse!
 908   (case-lambda
 909     "(vector-reverse! vec [start [end]]) -> unspecified
 910
 911 Destructively reverse the contents of VEC between START and END.
 912 START defaults to 0 and END defaults to the length of VEC."
 913     ((vec)
 914      (assert-vector vec 'vector-reverse!)
 915      (%vector-reverse! vec 0 (vector-length vec)))
 916     ((vec start)
 917      (assert-vector vec 'vector-reverse!)
 918      (let ((len (vector-length vec)))
 919        (assert-valid-start start len 'vector-reverse!)
 920        (%vector-reverse! vec start len)))
 921     ((vec start end)
 922      (assert-vector vec 'vector-reverse!)
 923      (let ((len (vector-length vec)))
 924        (assert-valid-range start end len 'vector-reverse!)
 925        (%vector-reverse! vec start end)))))
 926
 927 (define-syntax-rule (define-vector-copier! copy! docstring inner-proc)
 928   (define copy!
 929     (let ((%copy! inner-proc))
 930       (case-lambda
 931         docstring
 932         ((target tstart source)
 933          (assert-vector target 'copy!)
 934          (assert-vector source 'copy!)
 935          (let ((tlen (vector-length target))
 936                (slen (vector-length source)))
 937            (assert-valid-start tstart tlen 'copy!)
 938            (unless (>= tlen (+ tstart slen))
 939              (error-from 'copy! "would write past end of target"))
 940            (%copy! target tstart source 0 slen)))
 941
 942         ((target tstart source sstart)
 943          (assert-vector target 'copy!)
 944          (assert-vector source 'copy!)
 945          (let ((tlen (vector-length target))
 946                (slen (vector-length source)))
 947            (assert-valid-start tstart tlen 'copy!)
 948            (assert-valid-start sstart slen 'copy!)
 949            (unless (>= tlen (+ tstart (- slen sstart)))
 950              (error-from 'copy! "would write past end of target"))
 951            (%copy! target tstart source sstart slen)))
 952
 953         ((target tstart source sstart send)
 954          (assert-vector target 'copy!)
 955          (assert-vector source 'copy!)
 956          (let ((tlen (vector-length target))
 957                (slen (vector-length source)))
 958            (assert-valid-start tstart tlen 'copy!)
 959            (assert-valid-range sstart send slen 'copy!)
 960            (unless (>= tlen (+ tstart (- send sstart)))
 961              (error-from 'copy! "would write past end of target"))
 962            (%copy! target tstart source sstart send)))))))
 963
 964 (define-vector-copier! vector-copy!
 965   "(vector-copy! target tstart source [sstart [send]]) -> unspecified
 966
 967 Copy a block of elements from SOURCE to TARGET, both of which must be
 968 vectors, starting in TARGET at TSTART and starting in SOURCE at
 969 SSTART, ending when SEND - SSTART elements have been copied.  It is an
 970 error for TARGET to have a length less than TSTART + (SEND - SSTART).
 971 SSTART defaults to 0 and SEND defaults to the length of SOURCE."
 972   (lambda (target tstart source sstart send)
 973     (if (< tstart sstart)
 974         (vector-move-left!  source sstart send target tstart)
 975         (vector-move-right! source sstart send target tstart))))
 976
 977 (define-vector-copier! vector-reverse-copy!
 978   "(vector-reverse-copy! target tstart source [sstart [send]]) -> unspecified
 979
 980 Like vector-copy!, but copy the elements in the reverse order.  It is
 981 an error if TARGET and SOURCE are identical vectors and the TARGET and
 982 SOURCE ranges overlap; however, if TSTART = SSTART,
 983 vector-reverse-copy! behaves as (vector-reverse! TARGET TSTART SEND)
 984 would."
 985   (lambda (target tstart source sstart send)
 986     (if (and (eq? target source) (= tstart sstart))
 987         (%vector-reverse! target sstart send)
 988         (let loop ((i tstart) (j (- send 1)))
 989           (when (>= j sstart)
 990             (vector-set! target i (vector-ref source j))
 991             (loop (+ i 1) (- j 1)))))))
 992
 993 (define vector->list
 994   (let ()
 995     (define (%vector->list vec start end)
 996       (let loop ((i (- end 1))
 997                  (result '()))
 998         (if (< i start)
 999             result
1000             (loop (- i 1) (cons (vector-ref vec i) result)))))
1001     (case-lambda
1002       "(vector->list vec [start [end]]) -> proper-list
1003
1004 Return a newly allocated list containing the elements in VEC between
1005 START and END.  START defaults to 0 and END defaults to the length of
1006 VEC."
1007       ((vec)
1008        (assert-vector vec 'vector->list)
1009        (%vector->list vec 0 (vector-length vec)))
1010       ((vec start)
1011        (assert-vector vec 'vector->list)
1012        (let ((len (vector-length vec)))
1013          (assert-valid-start start len 'vector->list)
1014          (%vector->list vec start len)))
1015       ((vec start end)
1016        (assert-vector vec 'vector->list)
1017        (let ((len (vector-length vec)))
1018          (assert-valid-range start end len 'vector->list)
1019          (%vector->list vec start end))))))
1020
1021 (define reverse-vector->list
1022   (let ()
1023     (define (%reverse-vector->list vec start end)
1024       (let loop ((i start)
1025                  (result '()))
1026         (if (>= i end)
1027             result
1028             (loop (+ i 1) (cons (vector-ref vec i) result)))))
1029     (case-lambda
1030       "(reverse-vector->list vec [start [end]]) -> proper-list
1031
1032 Return a newly allocated list containing the elements in VEC between
1033 START and END in reverse order.  START defaults to 0 and END defaults
1034 to the length of VEC."
1035       ((vec)
1036        (assert-vector vec 'reverse-vector->list)
1037        (%reverse-vector->list vec 0 (vector-length vec)))
1038       ((vec start)
1039        (assert-vector vec 'reverse-vector->list)
1040        (let ((len (vector-length vec)))
1041          (assert-valid-start start len 'reverse-vector->list)
1042          (%reverse-vector->list vec start len)))
1043       ((vec start end)
1044        (assert-vector vec 'reverse-vector->list)
1045        (let ((len (vector-length vec)))
1046          (assert-valid-range start end len 'reverse-vector->list)
1047          (%reverse-vector->list vec start end))))))
1048
1049 ;; TODO: change to use 'case-lambda' and improve error checking.
1050 (define* (list->vector lst #:optional (start 0) (end (length lst)))
1051   "(list->vector proper-list [start [end]]) -> vector
1052
1053 Return a newly allocated vector of the elements from PROPER-LIST with
1054 indices between START and END.  START defaults to 0 and END defaults
1055 to the length of PROPER-LIST."
1056   (let* ((len (- end start))
1057          (result (make-vector len)))
1058     (let loop ((i 0) (lst (drop lst start)))
1059       (if (= i len)
1060           result
1061           (begin (vector-set! result i (car lst))
1062                  (loop (+ i 1) (cdr lst)))))))
1063
1064 ;; TODO: change to use 'case-lambda' and improve error checking.
1065 (define* (reverse-list->vector lst #:optional (start 0) (end (length lst)))
1066   "(reverse-list->vector proper-list [start [end]]) -> vector
1067
1068 Return a newly allocated vector of the elements from PROPER-LIST with
1069 indices between START and END, in reverse order.  START defaults to 0
1070 and END defaults to the length of PROPER-LIST."
1071   (let* ((len (- end start))
1072          (result (make-vector len)))
1073     (let loop ((i (- len 1)) (lst (drop lst start)))
1074       (if (negative? i)
1075           result
1076           (begin (vector-set! result i (car lst))
1077                  (loop (- i 1) (cdr lst)))))))