cs/rumble/vector.ss

1 (define/who make-vector
3    [(n) (make-vector n 0)]
7       (guard-large-allocation who 'vector n (foreign-sizeof 'void*)))
8     (#2%make-vector n v)]))
12 (define (vector-immutable . args)
14       (vector->immutable-vector '#())
15       (let ([vec (apply vector args)])
16         (#%$vector-set-immutable! vec)
21 (define (vector? v)
22   (or (#%vector? v)
24            (#%vector? (impersonator-val v)))))
26 (define (mutable-vector? v)
27   (or (#%mutable-vector? v)
29            (#%mutable-vector? (impersonator-val v)))))
33 (define-record vector-chaperone chaperone (ref set))
34 (define-record vector-impersonator impersonator (ref set))
36 (define/who (chaperone-vector vec ref set . props)
37   (check who vector? vec)
38   (do-impersonate-vector who make-vector-chaperone vec ref set
39                          make-props-chaperone props))
41 (define/who (impersonate-vector vec ref set . props)
42   (check who mutable-vector? :contract "(and/c vector? (not/c immutable?))" vec)
43   (do-impersonate-vector who make-vector-impersonator vec ref set
44                          make-props-impersonator props))
46 (define (do-impersonate-vector who make-vector-impersonator vec ref set
47                                make-props-impersonator props)
50   (check-vector-wrapper-consistent who ref set)
60         (make-vector-impersonator val vec props ref set)
61         (make-props-impersonator val vec props))))
63 (define (set-vector-impersonator-hash!)
64   (record-type-hash-procedure (record-type-descriptor vector-chaperone)
66                                 (hash-code (vector-copy c))))
67   (record-type-hash-procedure (record-type-descriptor vector-impersonator)
69                                 (hash-code (vector-copy i)))))
71 (define (check-vector-wrapper-consistent who ref set)
80 (define-record vector*-chaperone vector-chaperone ())
81 (define-record vector*-impersonator vector-impersonator ())
83 (define/who (chaperone-vector* vec ref set . props)
84   (check who vector? vec)
85   (do-impersonate-vector* who make-vector*-chaperone vec ref set
86                           make-props-chaperone props))
88 (define/who (impersonate-vector* vec ref set . props)
89   (check who mutable-vector? :contract "(and/c vector? (not/c immutable?))" vec)
90   (do-impersonate-vector* who make-vector*-impersonator vec ref set
91                           make-props-impersonator props))
93 (define (do-impersonate-vector* who make-vector*-impersonator vec ref set
94                                 make-props-impersonator props)
97   (check-vector-wrapper-consistent who ref set)
107         (make-vector*-impersonator val vec props ref set)
108         (make-props-impersonator val vec props))))
112 (define-record vector-unsafe-chaperone chaperone (vec))
113 (define-record vector-unsafe-impersonator impersonator (vec))
115 (define/who (unsafe-impersonate-vector vec alt-vec . props)
116   (check who mutable-vector? :contract "(and/c vector? (not/c immutable?))" vec)
117   (check who (lambda (p) (and (vector? p) (not (impersonator? p))))
118          :contract "(and/c vector? (not/c impersonator?))"
120   (do-unsafe-impersonate-vector who make-vector-unsafe-impersonator vec alt-vec props))
122 (define/who (unsafe-chaperone-vector vec alt-vec . props)
123   (check who vector? vec)
124   (check who (lambda (p) (and (vector? p) (not (impersonator? p))))
125          :contract "(and/c vector? (not/c impersonator?))"
127   (do-unsafe-impersonate-vector who make-vector-unsafe-chaperone vec alt-vec props))
129 (define (do-unsafe-impersonate-vector who make-vector-unsafe-impersonator vec alt-vec props)
138     (make-vector-unsafe-impersonator val vec props alt-vec)))
142 (define (vector-length vec)
143   (if (#%vector? vec)
144       (#3%vector-length vec)
145       (#%$app/no-inline impersonate-vector-length vec)))
147 (define (unsafe-vector-length vec)
148   (vector-length vec))
150 (define (vector*-length vec)
151   (if (#%vector? vec)
152       (#3%vector-length vec)
153       (#%$app/no-inline bad-vector*-for-length vec)))
155 (define (bad-vector*-for-length vec)
156   (raise-argument-error 'vector*-length "(and/c vector? (not impersonator?))" vec))
158 (define (impersonate-vector-length vec)
160            (#%vector? (impersonator-val vec)))
162        [(vector-unsafe-chaperone? vec)
163         (#%vector-length (vector-unsafe-chaperone-vec vec))]
164        [(vector-unsafe-impersonator? vec)
165         (#%vector-length (vector-unsafe-impersonator-vec vec))]
167         (#%vector-length (impersonator-val vec))])
169       (#2%vector-length vec)))
173 (define (vector-ref vec idx)
174   (if (#%$vector-ref-check? vec idx)
175       (#3%vector-ref vec idx)
176       (#%$app/no-inline impersonate-vector-ref vec idx)))
178 (define (unsafe-vector-ref vec idx)
179   (if (#%vector? vec)
180       (#3%vector-ref vec idx)
181       (#%$app/no-inline impersonate-vector-ref vec idx)))
183 (define/who (vector*-ref vec idx)
184   (if (#%$vector-ref-check? vec idx)
185       (#3%vector-ref vec idx)
186       (#%$app/no-inline bad-vector*-ref vec idx)))
188 (define (bad-vector*-ref vec idx)
189   (bad-vector*-op 'vector*-ref #f vec idx))
191 (define (bad-vector*-op who set? vec idx)
194     (unless (#%mutable-vector? vec)
195       (raise-argument-error who "(and/c vector? (not immutable?) (not impersonator?))" vec))]
197     (unless (#%vector? vec)
198       (raise-argument-error who "(and/c vector? (not impersonator?))" vec))])
200   (check-range who "vector" vec idx #f (fx- (#%vector-length vec) 1)))
202 (define (impersonate-vector-ref orig idx)
204            (#%vector? (impersonator-val orig)))
207          [(#%vector? o) (#2%vector-ref o idx)]
208          [(vector-chaperone? o)
211                  [new-val (if (vector*-chaperone? o)
212                               (|#%app| (vector-chaperone-ref o) orig o-next idx val)
213                               (|#%app| (vector-chaperone-ref o) o-next idx val))])
215               (raise-arguments-error 'vector-ref
220          [(vector-impersonator? o)
223             (if (vector*-impersonator? o)
224                 (|#%app| (vector-impersonator-ref o) orig o-next idx val)
225                 (|#%app| (vector-impersonator-ref o) o-next idx val)))]
226          [(vector-unsafe-impersonator? o)
227           (vector-ref (vector-unsafe-impersonator-vec o)  idx)]
228          [(vector-unsafe-chaperone? o)
229           (vector-ref (vector-unsafe-chaperone-vec o)  idx)]
232       (#2%vector-ref orig idx)))
236 (define (vector-set! vec idx val)
237   (if (#%$vector-set!-check? vec idx)
238       (#3%vector-set! vec idx val)
239       (#%$app/no-inline impersonate-vector-set! vec idx val)))
241 (define (unsafe-vector-set! vec idx val)
242   (if (#%vector? vec)
243       (#3%vector-set! vec idx val)
244       (#%$app/no-inline impersonate-vector-set! vec idx val)))
246 (define/who (vector*-set! vec idx val)
247   (if (#%$vector-set!-check? vec idx)
248       (#3%vector-set! vec idx val)
249       (#%$app/no-inline bad-vector*-set! vec idx val)))
251 (define (bad-vector*-set! vec idx val)
252   (bad-vector*-op 'vector*-set! #t vec idx))
254 (define (impersonate-vector-set! orig idx val)
257               (mutable-vector? (impersonator-val orig))))
259     (#2%vector-set! orig idx val)]
261         (>= idx (vector-length (impersonator-val orig))))
263     (#2%vector-set! (impersonator-val orig) idx val)]
267        [(#%vector? o) (#2%vector-set! o idx val)]
271            [(vector-chaperone? o)
272             (let ([new-val (if (vector*-chaperone? o)
273                                (|#%app| (vector-chaperone-set o) orig next idx val)
274                                (|#%app| (vector-chaperone-set o) next idx val))])
276                 (raise-arguments-error 'vector-set!
281            [(vector-impersonator? o)
283                   (if (vector*-impersonator? o)
284                       (|#%app| (vector-impersonator-set o) orig next idx val)
285                       (|#%app| (vector-impersonator-set o) next idx val)))]
286            [(vector-unsafe-impersonator? o)
287             (#2%vector-set! (vector-unsafe-impersonator-vec o) idx val)]
288            [(vector-unsafe-chaperone? o)
289             (#2%vector-set! (vector-unsafe-chaperone-vec o) idx val)]
294 (define/who (vector->list vec)
296    [(#%vector? vec)
297     (#3%vector->list vec)]
298    [(vector? vec)
299     (let ([len (vector-length vec)])
305             (loop i (cons (vector-ref vec i) accum)))])))]
307     (raise-argument-error who "vector?" vec)]))
311 (define/who (vector-copy vec)
313    [(#%vector? vec)
314     (#3%vector-copy vec)]
315    [(vector? vec)
316     (let* ([len (vector-length vec)]
317            [vec2 (make-vector len)])
318       (vector-copy! vec2 0 vec)
321     (raise-argument-error who "vector?" vec)]))
323 (define/who vector-copy!
326     (vector-copy! dest d-start src 0 (and (vector? src) (vector-length src)))]
328     (vector-copy! dest d-start src s-start (and (vector? src) (vector-length src)))]
330     (check who mutable-vector? :contract "(and/c vector? (not/c immutable?))" dest)
332     (check who vector? src)
335     (let ([d-len (vector-length dest)])
336       (check-range who "vector" dest d-start #f d-len)
337       (check-range who "vector" src s-start s-end (vector-length src))
339         (check-space who "vector" d-start d-len len)
341          [(and (#%vector? src) (#%vector? dest))
342           (vector*-copy! dest d-start src s-start s-end)]
349               (vector-set! dest (fx+ d-start i) (vector-ref src (fx+ s-start i)))
355                 (vector-set! dest (fx+ d-start i) (vector-ref src (fx+ s-start i)))
358 ;; Like `vector-copy!`, but doesn't work on impersonators, and doesn't
359 ;; add its own tests on the vector or range (so unsafe if Rumble is
361 (define/who vector*-copy!
364     (vector*-copy! dest dest-start src 0 (#%vector-length src))]
366     (vector*-copy! dest dest-start src src-start (#%vector-length src))]
376             (#%vector-set! dest (fx+ dest-start i) (vector-ref src (fx+ src-start i)))
382               (#%vector-set! dest (fx+ dest-start i) (vector-ref src (fx+ src-start i)))
385 (define/who vector->values
388     (check who vector? vec)
389      (let ([len (vector-length vec)])
392         [(fx= len 1) (vector-ref vec 0)]
393         [(fx= len 2) (values (vector-ref vec 0) (vector-ref vec 1))]
394         [(fx= len 3) (values (vector-ref vec 0) (vector-ref vec 1) (vector-ref vec 2))]
395         [else (chez:apply values (vector->list vec))]))]
397     (vector->values vec start (and (vector? vec) (vector-length vec)))]
399     (check who vector? vec)
402     (check-range who "vector" vec start end (vector-length vec))
407                    [else (cons (vector-ref vec start)
410 (define/who (vector-fill! vec v)
412    [(#%vector? vec)
413     (#3%vector-fill! vec v)]
414    [(vector? vec)
415     (check who mutable-vector? :contract "(and/c vector? (not immutable?))" v)
416     (let ([len (vector-length vec)])
419           (vector-set! vec i v)
422     (raise-argument-error who "vector?" vec)]))
424 (define/who (vector->immutable-vector v)
426    [(#%vector? v)
427     (#3%vector->immutable-vector v)]
428    [(vector? v)
429     (if (mutable-vector? v)
430         (#3%vector->immutable-vector
431          (vector-copy v))
434     (raise-argument-error who "vector?" v)]))
439 (define make-shared-fxvector
441    [(size) (make-shared-fxvector size 0)]
443     (register-place-shared (make-fxvector size init))]))