1 ;;; srfi-43.scm -- SRFI 43 Vector library
3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
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.
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.
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
19 ;;; Author: Mark H Weaver <mhw@netris.org>
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!
26 #:replace (vector-copy vector-fill! list->vector vector->list)
27 #:export (vector-empty? vector= vector-unfold vector-unfold-right
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
36 vector-any vector-every
37 vector-swap! vector-reverse!
38 vector-copy! vector-reverse-copy!
40 reverse-list->vector))
42 (cond-expand-provide (current-module) '(srfi-43))
44 (define (error-from who msg . args)
46 (string-append (symbol->string who) ": " msg)
49 (define-syntax-rule (assert-nonneg-exact-integer k who)
50 (unless (and (exact-integer? k)
52 (error-from who "expected non-negative exact integer, got" k)))
54 (define-syntax-rule (assert-procedure f who)
55 (unless (procedure? f)
56 (error-from who "expected procedure, got" f)))
58 (define-syntax-rule (assert-vector v who)
60 (error-from who "expected vector, got" v)))
62 (define-syntax-rule (assert-valid-index i len who)
63 (unless (and (exact-integer? i)
65 (error-from who "invalid index" i)))
67 (define-syntax-rule (assert-valid-start start len who)
68 (unless (and (exact-integer? start)
70 (error-from who "invalid start index" start)))
72 (define-syntax-rule (assert-valid-range start end len who)
73 (unless (and (exact-integer? start)
76 (error-from who "invalid index range" start end)))
78 (define-syntax-rule (assert-vectors vs who)
81 (assert-vector (car vs) who)
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))))
91 (loop (cdr vs) (min result (vector-length (car vs)))))))
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 '()))
98 (loop (cdr vs) (cons (vector-ref (car vs) i)
101 (define vector-unfold
103 "(vector-unfold f length initial-seed ...) -> vector
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."
112 (assert-procedure f 'vector-unfold)
113 (assert-nonneg-exact-integer len 'vector-unfold)
114 (let ((v (make-vector len)))
117 (vector-set! v i (f i))
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))
126 (receive (x seed) (f i seed)
128 (loop (+ i 1) seed))))
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))
136 (receive (x seed1 seed2) (f i seed1 seed2)
138 (loop (+ i 1) seed1 seed2))))
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))
146 (receive (x . seeds) (apply f i seeds)
148 (loop (+ i 1) seeds))))
151 (define vector-unfold-right
153 "(vector-unfold-right f length initial-seed ...) -> vector
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."
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))
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)
178 (loop (- i 1) seed))))
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)
188 (loop (- i 1) seed1 seed2))))
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)
198 (loop (- i 1) seeds))))
201 (define guile-vector-copy (@ (guile) vector-copy))
203 ;; TODO: Enhance Guile core 'vector-copy' to do this.
206 "(vector-copy vec [start [end [fill]]]) -> vector
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
215 ((v) (guile-vector-copy v))
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)
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)
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)
234 (define vector-reverse-copy
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)))
241 (vector-set! result i (vector-ref vec j))
242 (loop (+ i 1) (- j 1))))
245 "(vector-reverse-copy vec [start [end]]) -> vector
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)."
252 (assert-vector vec 'vector-reverse-copy)
253 (%vector-reverse-copy vec 0 (vector-length vec)))
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)))
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))))))
265 (define (%vector-concatenate vs)
266 (let* ((result-len (let loop ((vs vs) (len 0))
269 (loop (cdr vs) (+ len (vector-length (car vs)))))))
270 (result (make-vector result-len)))
271 (let loop ((vs vs) (pos 0))
274 (len (vector-length v)))
275 (vector-move-left! v 0 len result pos)
276 (loop (cdr vs) (+ pos len)))))
279 (define vector-append
281 "(vector-append vec ...) -> vector
283 Return a newly allocated vector that contains all elements in order
284 from the subsequent locations in VEC ..."
287 (assert-vector v 'vector-append)
288 (guile-vector-copy v))
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)
299 (assert-vectors vs 'vector-append)
300 (%vector-concatenate vs))))
302 (define (vector-concatenate vs)
303 "(vector-concatenate list-of-vectors) -> vector
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))
310 (define (vector-empty? vec)
311 "(vector-empty? vec) -> boolean
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)))
319 (define (all-of-length? len vs)
321 (and (= len (vector-length (car vs)))
322 (all-of-length? len (cdr vs)))))
323 (define (=up-to? i elt=? v1 v2)
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)))))
330 "(vector= elt=? vec ...) -> boolean
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
339 (assert-procedure elt=? 'vector=)
342 (assert-procedure elt=? 'vector=)
343 (assert-vector v 'vector=)
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))))
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)
360 (and (=up-to? (- len 1) elt=? v1 (car vs))
361 (loop (cdr vs)))))))))))
365 "(vector-fold kons knil vec1 vec2 ...) -> value
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
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))
381 (loop (+ i 1) (kcons i state (vector-ref v i)))))))
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))
391 (kcons i state (vector-ref v1 i) (vector-ref v2 i)))))))
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))
399 (loop (+ i 1) (apply kcons i state (vectors-ref vs i)))))))))
401 (define vector-fold-right
403 "(vector-fold-right kons knil vec1 vec2 ...) -> value
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
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))
419 (loop (- i 1) (kcons i state (vector-ref v i)))))))
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))
429 (kcons i state (vector-ref v1 i) (vector-ref v2 i)))))))
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))
437 (loop (- i 1) (apply kcons i state (vectors-ref vs i)))))))))
441 "(vector-map f vec2 vec2 ...) -> vector
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."
448 (assert-procedure f 'vector-map)
449 (assert-vector v 'vector-map)
450 (let* ((len (vector-length v))
451 (result (make-vector len)))
454 (vector-set! result i (f i (vector-ref v i)))
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)))
465 (vector-set! result i (f i (vector-ref v1 i) (vector-ref v2 i)))
469 (assert-procedure f 'vector-map)
470 (assert-vectors vs 'vector-map)
471 (let* ((len (min-length vs))
472 (result (make-vector len)))
475 (vector-set! result i (apply f i (vectors-ref vs i)))
481 "(vector-map! f vec2 vec2 ...) -> unspecified
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."
487 (assert-procedure f 'vector-map!)
488 (assert-vector v 'vector-map!)
489 (let ((len (vector-length v)))
492 (vector-set! v i (f i (vector-ref v i)))
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))))
501 (vector-set! v1 i (f i (vector-ref v1 i) (vector-ref v2 i)))
504 (assert-procedure f 'vector-map!)
505 (assert-vectors vs 'vector-map!)
506 (let ((len (min-length vs))
510 (vector-set! v1 i (apply f i (vectors-ref vs i)))
513 (define vector-for-each
515 "(vector-for-each f vec1 vec2 ...) -> unspecified
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
521 (assert-procedure f 'vector-for-each)
522 (assert-vector v 'vector-for-each)
523 (let ((len (vector-length v)))
526 (f i (vector-ref v i))
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))))
536 (f i (vector-ref v1 i) (vector-ref v2 i))
539 (assert-procedure f 'vector-for-each)
540 (assert-vectors vs 'vector-for-each)
541 (let ((len (min-length vs)))
544 (apply f i (vectors-ref vs i))
549 "(vector-count pred? vec1 vec2 ...) -> exact nonnegative integer
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
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)))
563 (loop (+ i 1) count))))))
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)))
575 (loop (+ i 1) count))))))
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)))
585 (loop (+ i 1) count))))))))
589 "(vector-index pred? vec1 vec2 ...) -> exact nonnegative integer or #f
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."
595 (assert-procedure pred? 'vector-index)
596 (assert-vector v 'vector-index)
597 (let ((len (vector-length v)))
600 (if (pred? (vector-ref v i))
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))))
611 (if (pred? (vector-ref v1 i)
616 (assert-procedure pred? 'vector-index)
617 (assert-vectors vs 'vector-index)
618 (let ((len (min-length vs)))
621 (if (apply pred? (vectors-ref vs i))
623 (loop (+ i 1)))))))))
625 (define vector-index-right
627 "(vector-index-right pred? vec1 vec2 ...) -> exact nonnegative integer or #f
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."
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)))
638 (if (pred? (vector-ref v i))
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)))
649 (if (pred? (vector-ref v1 i)
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)))
659 (if (apply pred? (vectors-ref vs i))
661 (loop (- i 1)))))))))
665 "(vector-skip pred? vec1 vec2 ...) -> exact nonnegative integer or #f
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."
671 (assert-procedure pred? 'vector-skip)
672 (assert-vector v 'vector-skip)
673 (let ((len (vector-length v)))
676 (if (pred? (vector-ref v i))
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))))
687 (if (pred? (vector-ref v1 i)
692 (assert-procedure pred? 'vector-skip)
693 (assert-vectors vs 'vector-skip)
694 (let ((len (min-length vs)))
697 (if (apply pred? (vectors-ref vs i))
701 (define vector-skip-right
703 "(vector-skip-right pred? vec1 vec2 ...) -> exact nonnegative integer or #f
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."
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))
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)
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))
739 (define vector-binary-search
741 (define (%vector-binary-search vec value cmp start end)
742 (let loop ((lo start) (hi end))
744 (let* ((i (quotient (+ lo hi) 2))
745 (x (vector-ref vec i))
748 ((positive? c) (loop lo i))
749 ((negative? c) (loop (+ i 1) hi)))))))
751 "(vector-binary-search vec value cmp [start [end]]) -> exact nonnegative integer or #f
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
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)))
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)))
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))))))
779 "(vector-any pred? vec1 vec2 ...) -> value or #f
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."
786 (assert-procedure pred? 'vector-any)
787 (assert-vector v 'vector-any)
788 (let ((len (vector-length v)))
791 (or (pred? (vector-ref v i))
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))))
801 (or (pred? (vector-ref v1 i)
805 (assert-procedure pred? 'vector-any)
806 (assert-vectors vs 'vector-any)
807 (let ((len (min-length vs)))
810 (or (apply pred? (vectors-ref vs i))
811 (loop (+ i 1)))))))))
815 "(vector-every pred? vec1 vec2 ...) -> value or #f
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."
823 (assert-procedure pred? 'vector-every)
824 (assert-vector v 'vector-every)
825 (let ((len (vector-length v)))
828 (let ((val (pred? (vector-ref v i)))
830 (if (or (not val) (= next-i len))
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))))
841 (let ((val (pred? (vector-ref v1 i)
844 (if (or (not val) (= next-i len))
848 (assert-procedure pred? 'vector-every)
849 (assert-vectors vs 'vector-every)
850 (let ((len (min-length vs)))
853 (let ((val (apply pred? (vectors-ref vs i)))
855 (if (or (not val) (= next-i len))
857 (loop next-i)))))))))
859 (define (vector-swap! vec i j)
860 "(vector-swap! vec i j) -> unspecified
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))))
871 ;; TODO: Enhance Guile core 'vector-fill!' to do this.
874 (define guile-vector-fill!
875 (@ (guile) vector-fill!))
876 (define (%vector-fill! vec fill start end)
877 (let loop ((i start))
879 (vector-set! vec i fill)
882 "(vector-fill! vec fill [start [end]]) -> unspecified
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."
887 (guile-vector-fill! vec fill))
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))))))
899 (define (%vector-reverse! vec start end)
900 (let loop ((i start) (j (- end 1)))
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))))))
907 (define vector-reverse!
909 "(vector-reverse! vec [start [end]]) -> unspecified
911 Destructively reverse the contents of VEC between START and END.
912 START defaults to 0 and END defaults to the length of VEC."
914 (assert-vector vec 'vector-reverse!)
915 (%vector-reverse! vec 0 (vector-length vec)))
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)))
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)))))
927 (define-syntax-rule (define-vector-copier! copy! docstring inner-proc)
929 (let ((%copy! inner-proc))
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)))
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)))
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)))))))
964 (define-vector-copier! vector-copy!
965 "(vector-copy! target tstart source [sstart [send]]) -> unspecified
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))))
977 (define-vector-copier! vector-reverse-copy!
978 "(vector-reverse-copy! target tstart source [sstart [send]]) -> unspecified
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)
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)))
990 (vector-set! target i (vector-ref source j))
991 (loop (+ i 1) (- j 1)))))))
995 (define (%vector->list vec start end)
996 (let loop ((i (- end 1))
1000 (loop (- i 1) (cons (vector-ref vec i) result)))))
1002 "(vector->list vec [start [end]]) -> proper-list
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
1008 (assert-vector vec 'vector->list)
1009 (%vector->list vec 0 (vector-length vec)))
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)))
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))))))
1021 (define reverse-vector->list
1023 (define (%reverse-vector->list vec start end)
1024 (let loop ((i start)
1028 (loop (+ i 1) (cons (vector-ref vec i) result)))))
1030 "(reverse-vector->list vec [start [end]]) -> proper-list
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."
1036 (assert-vector vec 'reverse-vector->list)
1037 (%reverse-vector->list vec 0 (vector-length vec)))
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)))
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))))))
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
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)))
1061 (begin (vector-set! result i (car lst))
1062 (loop (+ i 1) (cdr lst)))))))
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
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)))
1076 (begin (vector-set! result i (car lst))
1077 (loop (- i 1) (cdr lst)))))))