source: project/release/5/vector-lib/trunk/vector-lib.scm @ 35587

Last change on this file since 35587 was 35587, checked in by evhan, 15 months ago

vector-lib: Add C5 port and tag as version 1.3

File size: 54.9 KB
Line 
1;;; SRFI 43: Vector library
2;;; Taylor Campbell's reference implementation ported to Chicken Scheme.
3
4;; The reference implementation now includes all fixes that were formerly
5;; applied to this file.
6
7;; These changes were made for Chicken:
8;; Removed redundant offset checks in VECTOR-COPY and VECTOR-REVERSE-COPY
9;; Import receive and let-optionals from Chicken
10;; check-type uses native type checking
11;; Procedures pass symbol, not procedure object, as callee
12;; Clean up error display on Chicken
13
14; Copyright (c) 2005, 2006, 2007, 2008 Jim Ursetto.  All rights reserved.
15;
16; Redistribution and use in source and binary forms, with or without
17; modification, are permitted provided that the following conditions are met:
18;
19;   Redistributions of source code must retain the above copyright notice,
20;   this list of conditions and the following disclaimer. Redistributions in
21;   binary form must reproduce the above copyright notice, this list of
22;   conditions and the following disclaimer in the documentation and/or
23;   other materials provided with the distribution. Neither the name of the
24;   author nor the names of its contributors may be used to endorse or
25;   promote products derived from this software without specific prior
26;   written permission.
27;
28; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
29; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
30; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
31; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
32; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
33; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
34; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
35; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
36; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
37; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
38; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
39
40(declare
41  (unit vector-lib)
42  (fixnum))
43
44(cond-expand
45  (paranoia)
46  (else (declare (no-bound-checks))))
47
48(import (only (chicken platform) register-feature!))
49
50(register-feature! 'srfi-43)
51
52;;; -------- Exported procedure index --------
53(module vector-lib
54  (
55;;; * Constructors
56 ; make-vector                     vector
57   vector-unfold                   vector-unfold-right
58   vector-copy                     vector-reverse-copy
59   vector-append                   vector-concatenate
60;;; * Predicates
61 ; vector?
62   vector-empty?
63   vector=
64;;; * Selectors
65 ; vector-ref                      vector-length
66;;; * Iteration
67   vector-fold                     vector-fold-right
68   vector-map                      vector-map!
69   vector-for-each
70   vector-count
71;;; * Searching
72   vector-index                    vector-skip
73   vector-index-right              vector-skip-right
74   vector-binary-search
75   vector-any                      vector-every
76;;; * Mutators
77 ; vector-set!
78   vector-swap!
79   vector-fill!
80   vector-reverse!
81   vector-copy!                    vector-reverse-copy!
82   vector-reverse!
83;;; * Conversion
84   vector->list                    reverse-vector->list
85   list->vector                    reverse-list->vector)
86
87  ;; This jujitsu with the standard bindings lets us avoid multiply-defined
88  ;; messages and unconditionally overwriting standard bindings at toplevel.
89  ;; It is subject to change as the Chicken module system evolves.
90  (import (except (scheme) list->vector vector->list vector-fill!)
91          (prefix (only (scheme) list->vector vector->list vector-fill!) %)
92          (only (chicken base) let-optionals receive)
93          (only (chicken string) conc))
94
95;;; Taylor Campbell wrote this code; he places it in the public domain.
96
97
98
99;;; --------------------
100;;; Commentary on efficiency of the code
101
102;;; This code is somewhat tuned for efficiency.  There are several
103;;; internal routines that can be optimized greatly to greatly improve
104;;; the performance of much of the library.  These internal procedures
105;;; are already carefully tuned for performance, and lambda-lifted by
106;;; hand.  Some other routines are lambda-lifted by hand, but only the
107;;; loops are lambda-lifted, and only if some routine has two possible
108;;; loops -- a fast path and an n-ary case --, whereas _all_ of the
109;;; internal routines' loops are lambda-lifted so as to never cons a
110;;; closure in their body (VECTOR-PARSE-START+END doesn't have a loop),
111;;; even in Scheme systems that perform no loop optimization (which is
112;;; most of them, unfortunately).
113;;;
114;;; Fast paths are provided for common cases in most of the loops in
115;;; this library.
116;;;
117;;; All calls to primitive vector operations are protected by a prior
118;;; type check; they can be safely converted to use unsafe equivalents
119;;; of the operations, if available.  Ideally, the compiler should be
120;;; able to determine this, but the state of Scheme compilers today is
121;;; not a happy one.
122;;;
123;;; Efficiency of the actual algorithms is a rather mundane point to
124;;; mention; vector operations are rarely beyond being straightforward.
125
126
127
128;;; --------------------
129;;; Utilities
130
131(define (between? x y z)
132  (and (<  x y)
133       (<= y z)))
134
135(define (unspecified-value) (if #f #f))
136
137;++ This should be implemented more efficiently.  It shouldn't cons a
138;++ closure, and the cons cells used in the loops when using this could
139;++ be reused.
140(define (vectors-ref vectors i)
141  (map (lambda (v) (vector-ref v i)) vectors))
142
143
144
145;;; --------------------
146;;; Error checking
147
148;;; Error signalling (not checking) is done in a way that tries to be
149;;; as helpful to the person who gets the debugging prompt as possible.
150;;; That said, error _checking_ tries to be as unredundant as possible.
151
152;;; I don't use any sort of general condition mechanism; I use simply
153;;; SRFI 23's ERROR, even in cases where it might be better to use such
154;;; a general condition mechanism.  Fix that when porting this to a
155;;; Scheme implementation that has its own condition system.
156
157;;; In argument checks, upon receiving an invalid argument, the checker
158;;; procedure recursively calls itself, but in one of the arguments to
159;;; itself is a call to ERROR; this mechanism is used in the hopes that
160;;; the user may be thrown into a debugger prompt, proceed with another
161;;; value, and let it be checked again.
162
163;;; Type checking is pretty basic, but easily factored out and replaced
164;;; with whatever your implementation's preferred type checking method
165;;; is.  I doubt there will be many other methods of index checking,
166;;; though the index checkers might be better implemented natively.
167
168(cond-expand [unsafe
169  (eval-when (compile)
170    (define-inline (check-type pred? value callee) value)
171    (define-inline (check-index vec index callee) index)
172    (define-inline (check-indices vec start start-name end end-name callee)
173      (values start end)))]
174
175[else
176
177;;; (CHECK-TYPE <type-predicate?> <value> <callee>) -> value
178;;;   Ensure that VALUE satisfies TYPE-PREDICATE?; if not, signal an
179;;;   error stating that VALUE did not satisfy TYPE-PREDICATE?, showing
180;;;   that this happened while calling CALLEE.  Return VALUE if no
181;;;   error was signalled.
182
183(import (only (chicken base) when))
184(define-syntax check-type
185  (syntax-rules (vector? integer? list? nonneg-int? procedure?)
186    ((_ vector? value callee)     (begin (##sys#check-vector value callee) value))
187    ((_ integer? value callee)    (begin (##sys#check-exact value callee) value))
188    ((_ list? value callee)       (begin (##sys#check-list value callee) value))
189    ((_ nonneg-int? value callee) (begin (##sys#check-exact value callee)
190                                         (when (< value 0)
191                                           (##sys#error callee "value is negative" value))
192                                         value))
193    ((_ procedure? value callee)  value)))
194
195;;; (CHECK-INDEX <vector> <index> <callee>) -> index
196;;;   Ensure that INDEX is a valid index into VECTOR; if not, signal an
197;;;   error stating that it is not and that this happened in a call to
198;;;   CALLEE.  Return INDEX when it is valid.  (Note that this does NOT
199;;;   check that VECTOR is indeed a vector.)
200(define (check-index vec index callee)
201  (let ((index (check-type integer? index callee)))
202    (cond ((< index 0)
203           (check-index vec
204                        (##sys#error callee "vector index too low"
205                                     `(index ,index)
206                                     `(vector ,vec))
207                        callee))
208          ((>= index (vector-length vec))
209           (check-index vec
210                        (##sys#error callee "vector index too high"
211                                     `(index ,index)
212                                     `(vector ,vec))
213                        callee))
214          (else index))))
215
216;;; (CHECK-INDICES <vector>
217;;;                <start> <start-name>
218;;;                <end> <end-name>
219;;;                <caller>) -> [start end]
220;;;   Ensure that START and END are valid bounds of a range within
221;;;   VECTOR; if not, signal an error stating that they are not, with
222;;;   the message being informative about what the argument names were
223;;;   called -- by using START-NAME & END-NAME --, and that it occurred
224;;;   while calling CALLEE.  Also ensure that VEC is in fact a vector.
225;;;   Returns no useful value.
226(define (check-indices vec start start-name end end-name callee)
227  (let ((lose (lambda (why . other-info)
228                (apply ##sys#error `(,callee ,(conc "vector range out of bounds: " why)
229                                             ,@other-info
230                                             (,start-name ,start)
231                                             (,end-name ,end)
232                                             (vector ,vec)))))
233        (start (check-type integer? start callee))
234        (end   (check-type integer? end   callee)))
235    (cond ((> start end)
236           ;; I'm not sure how well this will work.  The intent is that
237           ;; the programmer tells the debugger to proceed with both a
238           ;; new START & a new END by returning multiple values
239           ;; somewhere.
240           (receive (new-start new-end)
241                    (lose `(,end-name < ,start-name))
242             (check-indices vec
243                            new-start start-name
244                            new-end end-name
245                            callee)))
246          ((< start 0)
247           (check-indices vec
248                          (lose `(,start-name < 0))
249                          start-name
250                          end end-name
251                          callee))
252          ((>= start (vector-length vec))
253           (check-indices vec
254                          (lose `(,start-name > len)
255                                `(len ,(vector-length vec)))
256                          start-name
257                          end end-name
258                          callee))
259          ((> end (vector-length vec))
260           (check-indices vec
261                          start start-name
262                          (lose `(,end-name > len)
263                                `(len ,(vector-length vec)))
264                          end-name
265                          callee))
266          (else
267           (values start end)))))
268
269])  ;; cond-expand unsafe
270
271
272;;; --------------------
273;;; Internal routines
274
275;;; These should all be integrated, native, or otherwise optimized --
276;;; they're used a _lot_ --.  All of the loops and LETs inside loops
277;;; are lambda-lifted by hand, just so as not to cons closures in the
278;;; loops.  (If your compiler can do better than that if they're not
279;;; lambda-lifted, then lambda-drop (?) them.)
280
281;;; (VECTOR-PARSE-START+END <vector> <arguments>
282;;;                         <start-name> <end-name>
283;;;                         <callee>)
284;;;       -> [start end]
285;;;   Return two values, composing a valid range within VECTOR, as
286;;;   extracted from ARGUMENTS or defaulted from VECTOR -- 0 for START
287;;;   and the length of VECTOR for END --; START-NAME and END-NAME are
288;;;   purely for error checking.
289(define (vector-parse-start+end vec args start-name end-name callee)
290  (let ((len (vector-length vec)))
291    (cond ((null? args)
292           (values 0 len))
293          ((null? (cdr args))
294           (check-indices vec
295                          (car args) start-name
296                          len end-name
297                          callee))
298          ((null? (cddr args))
299           (check-indices vec
300                          (car  args) start-name
301                          (cadr args) end-name
302                          callee))
303          (else
304           (##sys#error callee "too many arguments" (cddr args))))))
305
306(define-syntax let-vector-start+end
307  (syntax-rules ()
308    ((let-vector-start+end callee vec args (start end) body1 body2 ...)
309     (let ((vec (check-type vector? vec callee)))
310       (receive (start end)
311                (vector-parse-start+end vec args 'start 'end
312                                        callee)
313         body1 body2 ...)))))
314
315;;; (%SMALLEST-LENGTH <vector-list> <default-length> <callee>)
316;;;       -> exact, nonnegative integer
317;;;   Compute the smallest length of VECTOR-LIST.  DEFAULT-LENGTH is
318;;;   the length that is returned if VECTOR-LIST is empty.  Common use
319;;;   of this is in n-ary vector routines:
320;;;     (define (f vec . vectors)
321;;;       (let ((vec (check-type vector? vec f)))
322;;;         ...(%smallest-length vectors (vector-length vec) f)...))
323;;;   %SMALLEST-LENGTH takes care of the type checking -- which is what
324;;;   the CALLEE argument is for --; thus, the design is tuned for
325;;;   avoiding redundant type checks.
326(define %smallest-length
327  (letrec ((loop (lambda (vector-list length callee)
328                   (if (null? vector-list)
329                       length
330                       (loop (cdr vector-list)
331                             (min (vector-length
332                                   (check-type vector?
333                                               (car vector-list)
334                                               callee))
335                                  length)
336                             callee)))))
337    loop))
338
339;;; (%VECTOR-COPY! <target> <tstart> <source> <sstart> <send>)
340;;;   Copy elements at locations SSTART to SEND from SOURCE to TARGET,
341;;;   starting at TSTART in TARGET.
342;;;
343;;; Optimize this!  Probably with some combination of:
344;;;   - Force it to be integrated.
345;;;   - Let it use unsafe vector element dereferencing routines: bounds
346;;;     checking already happens outside of it.  (Or use a compiler
347;;;     that figures this out, but Olin Shivers' PhD thesis seems to
348;;;     have been largely ignored in actual implementations...)
349;;;   - Implement it natively as a VM primitive: the VM can undoubtedly
350;;;     perform much faster than it can make Scheme perform, even with
351;;;     bounds checking.
352;;;   - Implement it in assembly: you _want_ the fine control that
353;;;     assembly can give you for this.
354;;; I already lambda-lift it by hand, but you should be able to make it
355;;; even better than that.
356(define %vector-copy!
357  (letrec ((loop/l->r (lambda (target source send i j)
358                        (cond ((< i send)
359                               (vector-set! target j
360                                            (vector-ref source i))
361                               (loop/l->r target source send
362                                          (+ i 1) (+ j 1))))))
363           (loop/r->l (lambda (target source sstart i j)
364                        (cond ((>= i sstart)
365                               (vector-set! target j
366                                            (vector-ref source i))
367                               (loop/r->l target source sstart
368                                          (- i 1) (- j 1)))))))
369    (lambda (target tstart source sstart send)
370      (if (> sstart tstart)             ; Make sure we don't copy over
371                                        ;   ourselves.
372          (loop/l->r target source send sstart tstart)
373          (loop/r->l target source sstart (- send 1)
374                     (+ -1 tstart send (- sstart)))))))
375
376;;; (%VECTOR-REVERSE-COPY! <target> <tstart> <source> <sstart> <send>)
377;;;   Copy elements from SSTART to SEND from SOURCE to TARGET, in the
378;;;   reverse order.
379(define %vector-reverse-copy!
380  (letrec ((loop (lambda (target source sstart i j)
381                   (cond ((>= i sstart)
382                          (vector-set! target j (vector-ref source i))
383                          (loop target source sstart
384                                (- i 1)
385                                (+ j 1)))))))
386    (lambda (target tstart source sstart send)
387      (loop target source sstart
388            (- send 1)
389            tstart))))
390
391(define %vector-reverse!
392  (letrec ((loop (lambda (vec i j)
393                   (cond ((<= i j)
394                          (let ((v (vector-ref vec i)))
395                            (vector-set! vec i (vector-ref vec j))
396                            (vector-set! vec j v)
397                            (loop vec (+ i 1) (- j 1))))))))
398    (lambda (vec start end)
399      (loop vec start (- end 1)))))
400
401(define %vector-fold1
402  (letrec ((loop (lambda (kons knil len vec i)
403                   (if (= i len)
404                       knil
405                       (loop kons
406                             (kons i knil (vector-ref vec i))
407                             len vec (+ i 1))))))
408    (lambda (kons knil len vec)
409      (loop kons knil len vec 0))))
410
411(define %vector-fold2+
412  (letrec ((loop (lambda (kons knil len vectors i)
413                   (if (= i len)
414                       knil
415                       (loop kons
416                             (apply kons i knil
417                                    (vectors-ref vectors i))
418                             len vectors (+ i 1))))))
419    (lambda (kons knil len vectors)
420      (loop kons knil len vectors 0))))
421
422(define %vector-map1!
423  (letrec ((loop (lambda (f target vec i)
424                   (if (zero? i)
425                       target
426                       (let ((j (- i 1)))
427                         (vector-set! target j
428                                      (f j (vector-ref vec j)))
429                         (loop f target vec j))))))
430    (lambda (f target vec len)
431      (loop f target vec len))))
432
433(define %vector-map2+!
434  (letrec ((loop (lambda (f target vectors i)
435                   (if (zero? i)
436                       target
437                       (let ((j (- i 1)))
438                         (vector-set! target j
439                           (apply f j (vectors-ref vectors j)))
440                         (loop f target vectors j))))))
441    (lambda (f target vectors len)
442      (loop f target vectors len))))
443
444
445
446;;;;;;;;;;;;;;;;;;;;;;;; ***** vector-lib ***** ;;;;;;;;;;;;;;;;;;;;;;;
447
448;;; --------------------
449;;; Constructors
450
451;;; (MAKE-VECTOR <size> [<fill>]) -> vector
452;;;   [R5RS] Create a vector of length LENGTH.  If FILL is present,
453;;;   initialize each slot in the vector with it; if not, the vector's
454;;;   initial contents are unspecified.
455; (define make-vector make-vector)
456
457;;; (VECTOR <elt> ...) -> vector
458;;;   [R5RS] Create a vector containing ELEMENT ..., in order.
459; (define vector vector)
460
461;;; This ought to be able to be implemented much more efficiently -- if
462;;; we have the number of arguments available to us, we can create the
463;;; vector without using LENGTH to determine the number of elements it
464;;; should have.
465;(define (vector . elements) (list->vector elements))
466
467;;; (VECTOR-UNFOLD <f> <length> <initial-seed> ...) -> vector
468;;;     (F <index> <seed> ...) -> [elt seed' ...]
469;;;   The fundamental vector constructor.  Creates a vector whose
470;;;   length is LENGTH and iterates across each index K between 0 and
471;;;   LENGTH, applying F at each iteration to the current index and the
472;;;   current seeds to receive N+1 values: first, the element to put in
473;;;   the Kth slot and then N new seeds for the next iteration.
474(define vector-unfold
475  (letrec ((tabulate!                   ; Special zero-seed case.
476            (lambda (f vec i len)
477              (cond ((< i len)
478                     (vector-set! vec i (f i))
479                     (tabulate! f vec (+ i 1) len)))))
480           (unfold1!                    ; Fast path for one seed.
481            (lambda (f vec i len seed)
482              (if (< i len)
483                  (receive (elt new-seed)
484                           (f i seed)
485                    (vector-set! vec i elt)
486                    (unfold1! f vec (+ i 1) len new-seed)))))
487           (unfold2+!                   ; Slower variant for N seeds.
488            (lambda (f vec i len seeds)
489              (if (< i len)
490                  (receive (elt . new-seeds)
491                           (apply f i seeds)
492                    (vector-set! vec i elt)
493                    (unfold2+! f vec (+ i 1) len new-seeds))))))
494    (lambda (f len . initial-seeds)
495      (let ((f   (check-type procedure?  f   'vector-unfold))
496            (len (check-type nonneg-int? len 'vector-unfold)))
497        (let ((vec (make-vector len)))
498          (cond ((null? initial-seeds)
499                 (tabulate! f vec 0 len))
500                ((null? (cdr initial-seeds))
501                 (unfold1! f vec 0 len (car initial-seeds)))
502                (else
503                 (unfold2+! f vec 0 len initial-seeds)))
504          vec)))))
505
506;;; (VECTOR-UNFOLD-RIGHT <f> <length> <initial-seed> ...) -> vector
507;;;     (F <index> <seed> ...) -> [seed' ...]
508;;;   Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0
509;;;   (still exclusive with  LENGTH and inclusive with 0), not 0 to
510;;;   LENGTH as with VECTOR-UNFOLD.
511(define vector-unfold-right
512  (letrec ((tabulate!
513            (lambda (f vec i)
514              (cond ((>= i 0)
515                     (vector-set! vec i (f i))
516                     (tabulate! f vec (- i 1))))))
517           (unfold1!
518            (lambda (f vec i seed)
519              (if (>= i 0)
520                  (receive (elt new-seed)
521                           (f i seed)
522                    (vector-set! vec i elt)
523                    (unfold1! f vec (- i 1) new-seed)))))
524           (unfold2+!
525            (lambda (f vec i seeds)
526              (if (>= i 0)
527                  (receive (elt . new-seeds)
528                           (apply f i seeds)
529                    (vector-set! vec i elt)
530                    (unfold2+! f vec (- i 1) new-seeds))))))
531    (lambda (f len . initial-seeds)
532      (let ((f   (check-type procedure?  f   'vector-unfold-right))
533            (len (check-type nonneg-int? len 'vector-unfold-right)))
534        (let ((vec (make-vector len))
535              (i (- len 1)))
536          (cond ((null? initial-seeds)
537                 (tabulate! f vec i))
538                ((null? (cdr initial-seeds))
539                 (unfold1!  f vec i (car initial-seeds)))
540                (else
541                 (unfold2+! f vec i initial-seeds)))
542          vec)))))
543
544;;; (VECTOR-COPY <vector> [<start> <end> <fill>]) -> vector
545;;;   Create a newly allocated vector containing the elements from the
546;;;   range [START,END) in VECTOR.  START defaults to 0; END defaults
547;;;   to the length of VECTOR.  END may be greater than the length of
548;;;   VECTOR, in which case the vector is enlarged; if FILL is passed,
549;;;   the new locations from which there is no respective element in
550;;;   VECTOR are filled with FILL.
551(define (vector-copy vec . args)
552  (let ((vec (check-type vector? vec 'vector-copy)))
553    ;; We can't use LET-VECTOR-START+END, because we have one more
554    ;; argument, and we want finer control, too.
555    ;;
556    ;; Olin's implementation of LET*-OPTIONALS would prove useful here:
557    ;; the built-in argument-checks-as-you-go-along produces almost
558    ;; _exactly_ the same code as VECTOR-COPY:PARSE-ARGS.
559    (receive (start end fill)
560             (vector-copy:parse-args vec args)
561      (let ((new-vector (make-vector (- end start) fill)))
562        (%vector-copy! new-vector 0
563                       vec        start
564                       (if (> end (vector-length vec))
565                           (vector-length vec)
566                           end))
567        new-vector))))
568
569;;; Auxiliary for VECTOR-COPY.
570(define (vector-copy:parse-args vec args)
571  (if (null? args)
572      (values 0 (vector-length vec) (unspecified-value))
573      (let ((start (check-index vec (car args) 'vector-copy)))
574        (if (null? (cdr args))
575            (values start (vector-length vec) (unspecified-value))
576            (let ((end (check-type nonneg-int? (cadr args)
577                                   'vector-copy)))
578              (cond ((>= start (vector-length vec))
579                     (##sys#error 'vector-copy "start bound out of bounds"
580                                  `(start ,start)
581                                  `(end ,end)
582                                  `(vector ,vec)))
583                    ((> start end)
584                     (##sys#error 'vector-copy "can't invert a vector copy!"
585                                  `(start ,start)
586                                  `(end ,end)
587                                  `(vector ,vec)))
588                    ((null? (cddr args))
589                     (values start end (unspecified-value)))
590                    (else
591                     (let ((fill (caddr args)))
592                       (if (null? (cdddr args))
593                           (values start end fill)
594                           (##sys#error 'vector-copy
595                                        "too many arguments"
596                                        (cdddr args)))))))))))
597
598;;; (VECTOR-REVERSE-COPY <vector> [<start> <end>]) -> vector
599;;;   Create a newly allocated vector whose elements are the reversed
600;;;   sequence of elements between START and END in VECTOR.  START's
601;;;   default is 0; END's default is the length of VECTOR.
602(define (vector-reverse-copy vec . maybe-start+end)
603  (let-vector-start+end vector-reverse-copy vec maybe-start+end
604                        (start end)
605    (let ((new (make-vector (- end start))))
606      (%vector-reverse-copy! new 0 vec start end)
607      new)))
608
609;;; (VECTOR-APPEND <vector> ...) -> vector
610;;;   Append VECTOR ... into a newly allocated vector and return that
611;;;   new vector.
612(define (vector-append . vectors)
613  (vector-concatenate:aux vectors vector-append))
614
615;;; (VECTOR-CONCATENATE <vector-list>) -> vector
616;;;   Concatenate the vectors in VECTOR-LIST.  This is equivalent to
617;;;     (apply vector-append VECTOR-LIST)
618;;;   but VECTOR-APPEND tends to be implemented in terms of
619;;;   VECTOR-CONCATENATE, and some Schemes bork when the list to apply
620;;;   a function to is too long.
621;;;
622;;; Actually, they're both implemented in terms of an internal routine.
623(define (vector-concatenate vector-list)
624  (vector-concatenate:aux vector-list vector-concatenate))
625
626;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE
627(define vector-concatenate:aux
628  (letrec ((compute-length
629            (lambda (vectors len callee)
630              (if (null? vectors)
631                  len
632                  (let ((vec (check-type vector? (car vectors)
633                                         callee)))
634                    (compute-length (cdr vectors)
635                                    (+ (vector-length vec) len)
636                                    callee)))))
637           (concatenate!
638            (lambda (vectors target to)
639              (if (null? vectors)
640                  target
641                  (let* ((vec1 (car vectors))
642                         (len (vector-length vec1)))
643                    (%vector-copy! target to vec1 0 len)
644                    (concatenate! (cdr vectors) target
645                                  (+ to len)))))))
646    (lambda (vectors callee)
647      (cond ((null? vectors)            ;+++
648             (make-vector 0))
649            ((null? (cdr vectors))      ;+++
650             ;; Blech, we still have to allocate a new one.
651             (let* ((vec (check-type vector? (car vectors) callee))
652                    (len (vector-length vec))
653                    (new (make-vector len)))
654               (%vector-copy! new 0 vec 0 len)
655               new))
656            (else
657             (let ((new-vector
658                    (make-vector (compute-length vectors 0 callee))))
659               (concatenate! vectors new-vector 0)
660               new-vector))))))
661
662
663
664;;; --------------------
665;;; Predicates
666
667;;; (VECTOR? <value>) -> boolean
668;;;   [R5RS] Return #T if VALUE is a vector and #F if not.
669;(define vector? vector?)
670
671;;; (VECTOR-EMPTY? <vector>) -> boolean
672;;;   Return #T if VECTOR has zero elements in it, i.e. VECTOR's length
673;;;   is 0, and #F if not.
674(define (vector-empty? vec)
675  (let ((vec (check-type vector? vec 'vector-empty?)))
676    (zero? (vector-length vec))))
677
678;;; (VECTOR= <elt=?> <vector> ...) -> boolean
679;;;     (ELT=? <value> <value>) -> boolean
680;;;   Determine vector equality generalized across element comparators.
681;;;   Vectors A and B are equal iff their lengths are the same and for
682;;;   each respective elements E_a and E_b (element=? E_a E_b) returns
683;;;   a true value.  ELT=? is always applied to two arguments.  Element
684;;;   comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b)
685;;;   results in a true value, then (ELEMENT=? E_a E_b) must result in a
686;;;   true value.  This may be exploited to avoid multiple unnecessary
687;;;   element comparisons.  (This implementation does, but does not deal
688;;;   with the situation that ELEMENT=? is EQ? to avoid more unnecessary
689;;;   comparisons, but I believe this optimization is probably fairly
690;;;   insignificant.)
691;;;   
692;;;   If the number of vector arguments is zero or one, then #T is
693;;;   automatically returned.  If there are N vector arguments,
694;;;   VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are
695;;;   compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N
696;;;   are compared.  The precise order in which ELT=? is applied is not
697;;;   specified.
698(define (vector= elt=? . vectors)
699  (let ((elt=? (check-type procedure? elt=? 'vector=)))
700    (cond ((null? vectors)
701           #t)
702          ((null? (cdr vectors))
703           (check-type vector? (car vectors) 'vector=)
704           #t)
705          (else
706           (let loop ((vecs vectors))
707             (let ((vec1 (check-type vector? (car vecs) 'vector=))
708                   (vec2+ (cdr vecs)))
709               (or (null? vec2+)
710                   (and (binary-vector= elt=? vec1 (car vec2+))
711                        (loop vec2+)))))))))
712(define (binary-vector= elt=? vector-a vector-b)
713  (or (eq? vector-a vector-b)           ;+++
714      (let ((length-a (vector-length vector-a))
715            (length-b (vector-length vector-b)))
716        (letrec ((loop (lambda (i)
717                         (or (= i length-a)
718                             (and (< i length-b)
719                                  (test (vector-ref vector-a i)
720                                        (vector-ref vector-b i)
721                                        i)))))
722                 (test (lambda (elt-a elt-b i)
723                         (and (or (eq? elt-a elt-b) ;+++
724                                  (elt=? elt-a elt-b))
725                              (loop (+ i 1))))))
726          (and (= length-a length-b)
727               (loop 0))))))
728
729
730
731;;; --------------------
732;;; Selectors
733
734;;; (VECTOR-REF <vector> <index>) -> value
735;;;   [R5RS] Return the value that the location in VECTOR at INDEX is
736;;;   mapped to in the store.
737; (define vector-ref vector-ref)
738
739;;; (VECTOR-LENGTH <vector>) -> exact, nonnegative integer
740;;;   [R5RS] Return the length of VECTOR.
741; (define vector-length vector-length)
742
743
744
745;;; --------------------
746;;; Iteration
747
748;;; (VECTOR-FOLD <kons> <initial-knil> <vector> ...) -> knil
749;;;     (KONS <knil> <elt> ...) -> knil' ; N vectors -> N+1 args
750;;;   The fundamental vector iterator.  KONS is iterated over each
751;;;   index in all of the vectors in parallel, stopping at the end of
752;;;   the shortest; KONS is applied to an argument list of (list I
753;;;   STATE (vector-ref VEC I) ...), where STATE is the current state
754;;;   value -- the state value begins with KNIL and becomes whatever
755;;;   KONS returned at the respective iteration --, and I is the
756;;;   current index in the iteration.  The iteration is strictly left-
757;;;   to-right.
758;;;     (vector-fold KONS KNIL (vector E_1 E_2 ... E_N))
759;;;       <=>
760;;;     (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N)
761(define (vector-fold kons knil vec . vectors)
762  (let ((kons (check-type procedure? kons 'vector-fold))
763        (vec  (check-type vector?    vec  'vector-fold)))
764    (if (null? vectors)
765        (%vector-fold1 kons knil (vector-length vec) vec)
766        (%vector-fold2+ kons knil
767                        (%smallest-length vectors
768                                          (vector-length vec)
769                                          vector-fold)
770                        (cons vec vectors)))))
771
772;;; (VECTOR-FOLD-RIGHT <kons> <initial-knil> <vector> ...) -> knil
773;;;     (KONS <knil> <elt> ...) -> knil' ; N vectors => N+1 args
774;;;   The fundamental vector recursor.  Iterates in parallel across
775;;;   VECTOR ... right to left, applying KONS to the elements and the
776;;;   current state value; the state value becomes what KONS returns
777;;;   at each next iteration.  KNIL is the initial state value.
778;;;     (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N))
779;;;       <=>
780;;;     (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1)
781;;;
782;;; Not implemented in terms of a more primitive operations that might
783;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very
784;;; useful elsewhere.
785(define vector-fold-right
786  (letrec ((loop1 (lambda (kons knil vec i)
787                    (if (negative? i)
788                        knil
789                        (loop1 kons (kons i knil (vector-ref vec i))
790                               vec
791                               (- i 1)))))
792           (loop2+ (lambda (kons knil vectors i)
793                     (if (negative? i)
794                         knil
795                         (loop2+ kons
796                                 (apply kons i knil
797                                        (vectors-ref vectors i))
798                                 vectors
799                                 (- i 1))))))
800    (lambda (kons knil vec . vectors)
801      (let ((kons (check-type procedure? kons 'vector-fold-right))
802            (vec  (check-type vector?    vec  'vector-fold-right)))
803        (if (null? vectors)
804            (loop1  kons knil vec (- (vector-length vec) 1))
805            (loop2+ kons knil (cons vec vectors)
806                    (- (%smallest-length vectors
807                                         (vector-length vec)
808                                         vector-fold-right)
809                       1)))))))
810
811;;; (VECTOR-MAP <f> <vector> ...) -> vector
812;;;     (F <elt> ...) -> value ; N vectors -> N args
813;;;   Constructs a new vector of the shortest length of the vector
814;;;   arguments.  Each element at index I of the new vector is mapped
815;;;   from the old vectors by (F I (vector-ref VECTOR I) ...).  The
816;;;   dynamic order of application of F is unspecified.
817(define (vector-map f vec . vectors)
818  (let ((f   (check-type procedure? f   'vector-map))
819        (vec (check-type vector?    vec 'vector-map)))
820    (if (null? vectors)
821        (let ((len (vector-length vec)))
822          (%vector-map1! f (make-vector len) vec len))
823        (let ((len (%smallest-length vectors
824                                     (vector-length vec)
825                                     vector-map)))
826          (%vector-map2+! f (make-vector len) (cons vec vectors)
827                          len)))))
828
829;;; (VECTOR-MAP! <f> <vector> ...) -> unspecified
830;;;     (F <elt> ...) -> element' ; N vectors -> N args
831;;;   Similar to VECTOR-MAP, but rather than mapping the new elements
832;;;   into a new vector, the new mapped elements are destructively
833;;;   inserted into the first vector.  Again, the dynamic order of
834;;;   application of F is unspecified, so it is dangerous for F to
835;;;   manipulate the first VECTOR.
836(define (vector-map! f vec . vectors)
837  (let ((f   (check-type procedure? f   'vector-map!))
838        (vec (check-type vector?    vec 'vector-map!)))
839    (if (null? vectors)
840        (%vector-map1!  f vec vec (vector-length vec))
841        (%vector-map2+! f vec (cons vec vectors)
842                        (%smallest-length vectors
843                                          (vector-length vec)
844                                          vector-map!)))
845    (unspecified-value)))
846
847;;; (VECTOR-FOR-EACH <f> <vector> ...) -> unspecified
848;;;     (F <elt> ...) ; N vectors -> N args
849;;;   Simple vector iterator: applies F to each index in the range [0,
850;;;   LENGTH), where LENGTH is the length of the smallest vector
851;;;   argument passed, and the respective element at that index.  In
852;;;   contrast with VECTOR-MAP, F is reliably applied to each
853;;;   subsequent elements, starting at index 0 from left to right, in
854;;;   the vectors.
855(define vector-for-each
856  (letrec ((for-each1
857            (lambda (f vec i len)
858              (cond ((< i len)
859                     (f i (vector-ref vec i))
860                     (for-each1 f vec (+ i 1) len)))))
861           (for-each2+
862            (lambda (f vecs i len)
863              (cond ((< i len)
864                     (apply f i (vectors-ref vecs i))
865                     (for-each2+ f vecs (+ i 1) len))))))
866    (lambda (f vec . vectors)
867      (let ((f   (check-type procedure? f   'vector-for-each))
868            (vec (check-type vector?    vec 'vector-for-each)))
869        (if (null? vectors)
870            (for-each1 f vec 0 (vector-length vec))
871            (for-each2+ f (cons vec vectors) 0
872                        (%smallest-length vectors
873                                          (vector-length vec)
874                                          vector-for-each)))))))
875
876;;; (VECTOR-COUNT <predicate?> <vector> ...)
877;;;       -> exact, nonnegative integer
878;;;     (PREDICATE? <index> <value> ...) ; N vectors -> N+1 args
879;;;   PREDICATE? is applied element-wise to the elements of VECTOR ...,
880;;;   and a count is tallied of the number of elements for which a
881;;;   true value is produced by PREDICATE?.  This count is returned.
882(define (vector-count pred? vec . vectors)
883  (let ((pred? (check-type procedure? pred? 'vector-count))
884        (vec   (check-type vector?    vec   'vector-count)))
885    (if (null? vectors)
886        (%vector-fold1 (lambda (index count elt)
887                         (if (pred? index elt)
888                             (+ count 1)
889                             count))
890                       0
891                       (vector-length vec)
892                       vec)
893        (%vector-fold2+ (lambda (index count . elts)
894                          (if (apply pred? index elts)
895                              (+ count 1)
896                              count))
897                        0
898                        (%smallest-length vectors
899                                          (vector-length vec)
900                                          vector-count)
901                        (cons vec vectors)))))
902
903
904
905;;; --------------------
906;;; Searching
907
908;;; (VECTOR-INDEX <predicate?> <vector> ...)
909;;;       -> exact, nonnegative integer or #F
910;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
911;;;   Search left-to-right across VECTOR ... in parallel, returning the
912;;;   index of the first set of values VALUE ... such that (PREDICATE?
913;;;   VALUE ...) returns a true value; if no such set of elements is
914;;;   reached, return #F.
915(define (vector-index pred? vec . vectors)
916  (vector-index/skip pred? vec vectors vector-index))
917
918;;; (VECTOR-SKIP <predicate?> <vector> ...)
919;;;       -> exact, nonnegative integer or #F
920;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
921;;;   (vector-index (lambda elts (not (apply PREDICATE? elts)))
922;;;                 VECTOR ...)
923;;;   Like VECTOR-INDEX, but find the index of the first set of values
924;;;   that do _not_ satisfy PREDICATE?.
925(define (vector-skip pred? vec . vectors)
926  (vector-index/skip (lambda elts (not (apply pred? elts)))
927                     vec vectors
928                     vector-skip))
929
930;;; Auxiliary for VECTOR-INDEX & VECTOR-SKIP
931(define vector-index/skip
932  (letrec ((loop1  (lambda (pred? vec len i)
933                     (cond ((= i len) #f)
934                           ((pred? (vector-ref vec i)) i)
935                           (else (loop1 pred? vec len (+ i 1))))))
936           (loop2+ (lambda (pred? vectors len i)
937                     (cond ((= i len) #f)
938                           ((apply pred? (vectors-ref vectors i)) i)
939                           (else (loop2+ pred? vectors len
940                                         (+ i 1)))))))
941    (lambda (pred? vec vectors callee)
942      (let ((pred? (check-type procedure? pred? callee))
943            (vec   (check-type vector?    vec   callee)))
944        (if (null? vectors)
945            (loop1 pred? vec (vector-length vec) 0)
946            (loop2+ pred? (cons vec vectors)
947                    (%smallest-length vectors
948                                      (vector-length vec)
949                                      callee)
950                    0))))))
951
952;;; (VECTOR-INDEX-RIGHT <predicate?> <vector> ...)
953;;;       -> exact, nonnegative integer or #F
954;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
955;;;   Right-to-left variant of VECTOR-INDEX.
956(define (vector-index-right pred? vec . vectors)
957  (vector-index/skip-right pred? vec vectors vector-index-right))
958
959;;; (VECTOR-SKIP-RIGHT <predicate?> <vector> ...)
960;;;       -> exact, nonnegative integer or #F
961;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
962;;;   Right-to-left variant of VECTOR-SKIP.
963(define (vector-skip-right pred? vec . vectors)
964  (vector-index/skip-right (lambda elts (not (apply pred? elts)))
965                           vec vectors
966                           vector-index-right))
967
968(define vector-index/skip-right
969  (letrec ((loop1  (lambda (pred? vec i)
970                     (cond ((negative? i) #f)
971                           ((pred? (vector-ref vec i)) i)
972                           (else (loop1 pred? vec (- i 1))))))
973           (loop2+ (lambda (pred? vectors i)
974                     (cond ((negative? i) #f)
975                           ((apply pred? (vectors-ref vectors i)) i)
976                           (else (loop2+ pred? vectors (- i 1)))))))
977    (lambda (pred? vec vectors callee)
978      (let ((pred? (check-type procedure? pred? callee))
979            (vec   (check-type vector?    vec   callee)))
980        (if (null? vectors)
981            (loop1 pred? vec (- (vector-length vec) 1))
982            (loop2+ pred? (cons vec vectors)
983                    (- (%smallest-length vectors
984                                         (vector-length vec)
985                                         callee)
986                       1)))))))
987
988;;; (VECTOR-BINARY-SEARCH <vector> <value> <cmp> [<start> <end>])
989;;;       -> exact, nonnegative integer or #F
990;;;     (CMP <value1> <value2>) -> integer
991;;;       positive -> VALUE1 > VALUE2
992;;;       zero     -> VALUE1 = VALUE2
993;;;       negative -> VALUE1 < VALUE2
994;;;   Perform a binary search through VECTOR for VALUE, comparing each
995;;;   element to VALUE with CMP.
996(define (vector-binary-search vec value cmp . maybe-start+end)
997  (let ((cmp (check-type procedure? cmp 'vector-binary-search)))
998    (let-vector-start+end vector-binary-search vec maybe-start+end
999                          (start end)
1000      (let loop ((start start) (end end) (j #f))
1001        (let ((i (quotient (+ start end) 2)))
1002          (if (or (= start end) (and j (= i j)))
1003              #f
1004              (let ((comparison
1005                     (check-type integer?
1006                                 (cmp (vector-ref vec i) value)
1007                                 'vector-binary-search:cmp)))
1008                (cond ((zero?     comparison) i)
1009                      ((positive? comparison) (loop start i i))
1010                      (else                   (loop i end i))))))))))
1011
1012;;; (VECTOR-ANY <pred?> <vector> ...) -> value
1013;;;   Apply PRED? to each parallel element in each VECTOR ...; if PRED?
1014;;;   should ever return a true value, immediately stop and return that
1015;;;   value; otherwise, when the shortest vector runs out, return #F.
1016;;;   The iteration and order of application of PRED? across elements
1017;;;   is of the vectors is strictly left-to-right.
1018(define vector-any
1019  (letrec ((loop1 (lambda (pred? vec i len len-1)
1020                    (and (not (= i len))
1021                         (if (= i len-1)
1022                             (pred? (vector-ref vec i))
1023                             (or (pred? (vector-ref vec i))
1024                                 (loop1 pred? vec (+ i 1)
1025                                        len len-1))))))
1026           (loop2+ (lambda (pred? vectors i len len-1)
1027                     (and (not (= i len))
1028                          (if (= i len-1)
1029                              (apply pred? (vectors-ref vectors i))
1030                              (or (apply pred? (vectors-ref vectors i))
1031                                  (loop2+ pred? vectors (+ i 1)
1032                                         len len-1)))))))
1033    (lambda (pred? vec . vectors)
1034      (let ((pred? (check-type procedure? pred? 'vector-any))
1035            (vec   (check-type vector?    vec   'vector-any)))
1036        (if (null? vectors)
1037            (let ((len (vector-length vec)))
1038              (loop1 pred? vec 0 len (- len 1)))
1039            (let ((len (%smallest-length vectors
1040                                         (vector-length vec)
1041                                         vector-any)))
1042              (loop2+ pred? (cons vec vectors) 0 len (- len 1))))))))
1043
1044;;; (VECTOR-EVERY <pred?> <vector> ...) -> value
1045;;;   Apply PRED? to each parallel value in each VECTOR ...; if PRED?
1046;;;   should ever return #F, immediately stop and return #F; otherwise,
1047;;;   if PRED? should return a true value for each element, stopping at
1048;;;   the end of the shortest vector, return the last value that PRED?
1049;;;   returned.  In the case that there is an empty vector, return #T.
1050;;;   The iteration and order of application of PRED? across elements
1051;;;   is of the vectors is strictly left-to-right.
1052(define vector-every
1053  (letrec ((loop1 (lambda (pred? vec i len len-1)
1054                    (or (= i len)
1055                        (if (= i len-1)
1056                            (pred? (vector-ref vec i))
1057                            (and (pred? (vector-ref vec i))
1058                                 (loop1 pred? vec (+ i 1)
1059                                        len len-1))))))
1060           (loop2+ (lambda (pred? vectors i len len-1)
1061                     (or (= i len)
1062                         (if (= i len-1)
1063                             (apply pred? (vectors-ref vectors i))
1064                             (and (apply pred? (vectors-ref vectors i))
1065                                  (loop2+ pred? vectors (+ i 1)
1066                                          len len-1)))))))
1067    (lambda (pred? vec . vectors)
1068      (let ((pred? (check-type procedure? pred? 'vector-every))
1069            (vec   (check-type vector?    vec   'vector-every)))
1070        (if (null? vectors)
1071            (let ((len (vector-length vec)))
1072              (loop1 pred? vec 0 len (- len 1)))
1073            (let ((len (%smallest-length vectors
1074                                         (vector-length vec)
1075                                         vector-every)))
1076              (loop2+ pred? (cons vec vectors) 0 len (- len 1))))))))
1077
1078
1079
1080;;; --------------------
1081;;; Mutators
1082
1083;;; (VECTOR-SET! <vector> <index> <value>) -> unspecified
1084;;;   [R5RS] Assign the location at INDEX in VECTOR to VALUE.
1085; (define vector-set! vector-set!)
1086
1087;;; (VECTOR-SWAP! <vector> <index1> <index2>) -> unspecified
1088;;;   Swap the values in the locations at INDEX1 and INDEX2.
1089(define (vector-swap! vec i j)
1090  (let ((vec (check-type vector? vec 'vector-swap!)))
1091    (let ((i (check-index vec i 'vector-swap!))
1092          (j (check-index vec j 'vector-swap!)))
1093      (let ((x (vector-ref vec i)))
1094        (vector-set! vec i (vector-ref vec j))
1095        (vector-set! vec j x)))))
1096
1097;;; (VECTOR-FILL! <vector> <value> [<start> <end>]) -> unspecified
1098;;;   [R5RS+] Fill the locations in VECTOR between START, whose default
1099;;;   is 0, and END, whose default is the length of VECTOR, with VALUE.
1100;;;
1101;;; This one can probably be made really fast natively.
1102(define vector-fill!
1103  (lambda (vec value . maybe-start+end)
1104    (if (null? maybe-start+end)
1105        (%vector-fill! vec value)       ;+++
1106        (let-vector-start+end vector-fill! vec maybe-start+end
1107                              (start end)
1108                              (do ((i start (+ i 1)))
1109                                  ((= i end))
1110                                (vector-set! vec i value))))))
1111
1112;;; (VECTOR-COPY! <target> <tstart> <source> [<sstart> <send>])
1113;;;       -> unspecified
1114;;;   Copy the values in the locations in [SSTART,SEND) from SOURCE
1115;;;   to TARGET, starting at TSTART in TARGET.
1116;; (Note: removed start+end offset checks that can never be triggered,
1117;;  as the checks are already done in let-vector-start+end.)
1118(define (vector-copy! target tstart source . maybe-sstart+send)
1119  (let* ((target (check-type vector? target 'vector-copy!))
1120         (tstart (check-index target tstart 'vector-copy!)))
1121    (let-vector-start+end vector-copy! source maybe-sstart+send
1122                          (sstart send)
1123      (%vector-copy! target tstart source sstart send))))
1124
1125;;; (VECTOR-REVERSE-COPY! <target> <tstart> <source> [<sstart> <send>])
1126;; (Note: removed start+end offset checks that can never be triggered,
1127;;  as the checks are already done in let-vector-start+end.)
1128(define (vector-reverse-copy! target tstart source . maybe-sstart+send)
1129  (let* ((target (check-type vector? target 'vector-reverse-copy!))
1130         (tstart (check-index target tstart 'vector-reverse-copy!)))
1131    (let-vector-start+end vector-reverse-copy source maybe-sstart+send
1132                          (sstart send)
1133      (cond ((and (eq? target source)
1134                  (= sstart tstart))
1135             (%vector-reverse! target tstart send))
1136            ((and (eq? target source)
1137                  (or (between? sstart tstart send)
1138                      (between? sstart (+ tstart (- send sstart))
1139                                send)))
1140             (##sys#error 'vector-reverse-copy!
1141                          "vector range for self-copying overlaps"
1142                          `(vector ,target)
1143                          `(tstart ,tstart)
1144                          `(sstart ,sstart)
1145                          `(send   ,send)))
1146            (else
1147             (%vector-reverse-copy! target tstart
1148                                    source sstart send))))))
1149
1150;;; (VECTOR-REVERSE! <vector> [<start> <end>]) -> unspecified
1151;;;   Destructively reverse the contents of the sequence of locations
1152;;;   in VECTOR between START, whose default is 0, and END, whose
1153;;;   default is the length of VECTOR.
1154(define (vector-reverse! vec . start+end)
1155  (let-vector-start+end vector-reverse! vec start+end
1156                        (start end)
1157    (%vector-reverse! vec start end)))
1158
1159
1160
1161;;; --------------------
1162;;; Conversion
1163
1164;;; (VECTOR->LIST <vector> [<start> <end>]) -> list
1165;;;   [R5RS+] Produce a list containing the elements in the locations
1166;;;   between START, whose default is 0, and END, whose default is the
1167;;;   length of VECTOR, from VECTOR.
1168(define vector->list
1169  (lambda (vec . maybe-start+end)
1170    (if (null? maybe-start+end)         ; Oughta use CASE-LAMBDA.
1171        (%vector->list vec)             ;+++
1172        (let-vector-start+end
1173         vector->list vec maybe-start+end (start end)
1174         ;;(unfold (lambda (i)        ; No SRFI 1.
1175         ;;          (< i start))
1176         ;;        (lambda (i) (vector-ref vec i))
1177         ;;        (lambda (i) (- i 1))
1178         ;;        (- end 1))
1179         (do ((i (- end 1) (- i 1))
1180              (result '() (cons (vector-ref vec i) result)))
1181             ((< i start) result))))))
1182
1183;;; (REVERSE-VECTOR->LIST <vector> [<start> <end>]) -> list
1184;;;   Produce a list containing the elements in the locations between
1185;;;   START, whose default is 0, and END, whose default is the length
1186;;;   of VECTOR, from VECTOR, in reverse order.
1187(define (reverse-vector->list vec . maybe-start+end)
1188  (let-vector-start+end reverse-vector->list vec maybe-start+end
1189                        (start end)
1190    ;(unfold (lambda (i) (= i end))     ; No SRFI 1.
1191    ;        (lambda (i) (vector-ref vec i))
1192    ;        (lambda (i) (+ i 1))
1193    ;        start)
1194    (do ((i start (+ i 1))
1195         (result '() (cons (vector-ref vec i) result)))
1196        ((= i end) result))))
1197
1198;;; (LIST->VECTOR <list> [<start> <end>]) -> vector
1199;;;   [R5RS+] Produce a vector containing the elements in LIST, which
1200;;;   must be a proper list, between START, whose default is 0, & END,
1201;;;   whose default is the length of LIST.  It is suggested that if the
1202;;;   length of LIST is known in advance, the START and END arguments
1203;;;   be passed, so that LIST->VECTOR need not call LENGTH to determine
1204;;;   the length.
1205;;;
1206;;; This implementation diverges on circular lists, unless LENGTH fails
1207;;; and causes - to fail as well.  Given a LENGTH* that computes the
1208;;; length of a list's cycle, this wouldn't diverge, and would work
1209;;; great for circular lists.
1210
1211(define list->vector
1212  (lambda (lst . maybe-start+end)
1213    ;; Checking the type of a proper list is expensive, so we do it
1214    ;; amortizedly, or let %LIST->VECTOR or LIST-TAIL do it.
1215    (if (null? maybe-start+end)         ; Oughta use CASE-LAMBDA.
1216        (%list->vector lst)             ;+++
1217        ;; We can't use LET-VECTOR-START+END, because we're using the
1218        ;; bounds of a _list_, not a vector.
1219        (let ((lst (check-type list? lst 'list->vector)))
1220          (let-optionals maybe-start+end
1221                         ((start 0)
1222                          (end (length lst))) ; Ugh -- LENGTH
1223                         (let ((start (check-type nonneg-int? start 'list->vector))
1224                               (end   (check-type nonneg-int? end   'list->vector)))
1225                           ((lambda (f)
1226                              (vector-unfold f (- end start) (list-tail lst start)))
1227                            (lambda (index l)
1228                              (cond ((null? l)
1229                                     (##sys#error 'list->vector "list too short"
1230                                                  `(list ,lst)
1231                                                  `(attempted end ,end)))
1232                                    ((pair? l)
1233                                     (values (car l) (cdr l)))
1234                                    (else
1235                                     (##sys#not-a-proper-list-error lst 'list->vector)))))))))))
1236
1237;;; (REVERSE-LIST->VECTOR <list> [<start> <end>]) -> vector
1238;;;   Produce a vector containing the elements in LIST, which must be a
1239;;;   proper list, between START, whose default is 0, and END, whose
1240;;;   default is the length of LIST, in reverse order.  It is suggested
1241;;;   that if the length of LIST is known in advance, the START and END
1242;;;   arguments be passed, so that REVERSE-LIST->VECTOR need not call
1243;;;   LENGTH to determine the the length.
1244;;;
1245;;; This also diverges on circular lists unless, again, LENGTH returns
1246;;; something that makes - bork.
1247(define (reverse-list->vector lst . maybe-start+end)
1248  (let-optionals maybe-start+end
1249      ((start 0)
1250       (end (length lst)))              ; Ugh -- LENGTH
1251    (let ((start (check-type nonneg-int? start 'reverse-list->vector))
1252          (end   (check-type nonneg-int? end   'reverse-list->vector)))
1253      ((lambda (f)
1254         (vector-unfold-right f (- end start) (list-tail lst start)))
1255       (lambda (index l)
1256         (cond ((null? l)
1257                (##sys#error 'reverse-list->vector "list too short"
1258                             `(list ,lst)
1259                             `(attempted end ,end)))
1260               ((pair? l)
1261                (values (car l) (cdr l)))
1262               (else
1263                (##sys#not-a-proper-list-error lst 'reverse-list->vector)))))))))
Note: See TracBrowser for help on using the repository browser.