suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add chaperone-vector*, unsafe-chaperone-vector, and property-only vector chaperones.

Browse Source 
By analogy with the procedure chaperone equivalents.
This commit is contained in:
Vincent St-Amour 2017-04-25 13:21:46 -05:00
parent 541015ba3b
commit 13443dec92
13 changed files with 2022 additions and 1245 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "6.9.0.1")
(define version "6.9.0.2")
(define deps `("racket-lib"
["racket" #:version ,version]))

49
pkgs/racket-doc/scribblings/reference/chaperones.scrbl
View File

@ -397,8 +397,8 @@ after @racket[redirect-proc] (in the case of a mutator).
@defproc[(impersonate-vector [vec (and/c vector? (not/c immutable?))]
[ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
[set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
[ref-proc (or/c (vector? exact-nonnegative-integer? any/c . -> . any/c) #f)]
[set-proc (or/c (vector? exact-nonnegative-integer? any/c . -> . any/c) #f)]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c vector? impersonator?)]{
@ -406,13 +406,17 @@ after @racket[redirect-proc] (in the case of a mutator).
Returns an impersonator of @racket[vec], which redirects the
@racket[vector-ref] and @racket[vector-set!] operations.
The @racket[ref-proc] must accept @racket[vec], an index passed to
The @racket[ref-proc] and @racket[set-proc] arguments must either both be procedures
or both be @racket[#f]. If they are @racket[#f] then @racket[impersonate-vector] does not interpose
on @racket[vec], but still allows attaching impersonator properties.
If @racket[ref-proc] is a procedure it must accept @racket[vec], an index passed to
@racket[vector-ref], and the value that @racket[vector-ref] on
@racket[vec] produces for the given index; it must produce a
replacement for the value, which is the result of @racket[vector-ref]
on the impersonator.
The @racket[set-proc] must accept @racket[vec], an index passed to
If @racket[set-proc] is a procedure it must accept @racket[vec], an index passed to
@racket[vector-set!], and the value passed to @racket[vector-set!]; it
must produce a replacement for the value, which is used
with @racket[vector-set!] on the original @racket[vec] to install the
@ -420,7 +424,26 @@ value.
Pairs of @racket[prop] and @racket[prop-val] (the number of arguments
to @racket[impersonate-vector] must be odd) add impersonator properties
or override impersonator-property values of @racket[vec].}
or override impersonator-property values of @racket[vec].
@history[#:changed "6.9.0.2"]{Added non-interposing vector impersonators.}
}
@defproc[(impersonate-vector* [vec (and/c vector? (not/c immutable?))]
[ref-proc (or/c (vector? vector? exact-nonnegative-integer? any/c . -> . any/c) #f)]
[set-proc (or/c (vector? vector? exact-nonnegative-integer? any/c . -> . any/c) #f)]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c vector? impersonator?)]{
Like @racket[impersonate-vector], except that @racket[ref-proc] and @racket[set-proc] each receive
an additional vector as argument before other arguments. The additional argument is the original
impersonated vector, access to which triggered interposition in the first place.
The additional vector argument might be useful so that @racket[ref-proc] or @racket[set-proc]
can extract impersonator properties that are overridden by further impersonators, for example.
@history[#:added "6.9.0.2"]
}
@defproc[(impersonate-box [box (and/c box? (not/c immutable?))]
[unbox-proc (box? any/c . -> . any/c)]
@ -792,8 +815,8 @@ or structure type.
argument.}]}
@defproc[(chaperone-vector [vec vector?]
[ref-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
[set-proc (vector? exact-nonnegative-integer? any/c . -> . any/c)]
[ref-proc (or/c (vector? exact-nonnegative-integer? any/c . -> . any/c) #f)]
[set-proc (or/c (vector? exact-nonnegative-integer? any/c . -> . any/c) #f)]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c vector? chaperone?)]{
@ -804,6 +827,18 @@ of the original value, and @racket[set-proc] must produce the value
that is given or a chaperone of the value. The @racket[set-proc] will
not be used if @racket[vec] is immutable.}
@defproc[(chaperone-vector* [vec (and/c vector? (not/c immutable?))]
[ref-proc (or/c (vector? vector? exact-nonnegative-integer? any/c . -> . any/c) #f)]
[set-proc (or/c (vector? vector? exact-nonnegative-integer? any/c . -> . any/c) #f)]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c vector? chaperone?)]{
Like @racket[chaperone-vector], but @racket[ref-proc] and @racket[set-proc] receive an extra argument
as with @racket[impersonate-vector*].
@history[#:added "6.9.0.2"]
}
@defproc[(chaperone-box [box box?]
[unbox-proc (box? any/c . -> . any/c)]
[set-proc (box? any/c . -> . any/c)]

22
pkgs/racket-doc/scribblings/reference/unsafe.scrbl
View File

@ -626,6 +626,28 @@ fixnum).}
@history[#:added "6.4.0.4"]
}
@defproc[(unsafe-impersonate-vector [vec vector?]
[replacement-vec (and/c vector? (not/c impersonator?))]
[prop impersonator-property?]
[prop-val any/c] ... ...)
(and/c vector? impersonator?)]{
Like @racket[impersonate-vector], but instead of going through interposition procedures, all
accesses to the impersonator are dispatched to @racket[replacement-vec].
The result of @racket[unsafe-impersonate-vector] is an impersonator of @racket[vec].
@history[#:added "6.9.0.2"]
}
@defproc[(unsafe-chaperone-vector [vec vector?]
[replacement-vec (and/c vector? (not/c impersonator?))]
[prop impersonator-property?]
[prop-val any/c] ... ...)
(and/c vector? chaperone?)]{
Like @racket[unsafe-impersonate-vector], but the result of @racket[unsafe-chaperone-vector] is a
chaperone of @racket[vec].
@history[#:added "6.9.0.2"]
}
@; ------------------------------------------------------------------------
@include-section["unsafe-undefined.scrbl"]

562
pkgs/racket-test-core/tests/racket/chaperone.rktl
View File

@ -4,6 +4,8 @@
(Section 'chaperones)
(require (only-in racket/unsafe/ops
unsafe-chaperone-vector
unsafe-impersonate-vector
unsafe-impersonate-procedure
unsafe-chaperone-procedure))
@ -221,6 +223,566 @@
(define-values (a b c) (vector->values b2))
(test '(1 2 3) list a b c)))
;; check property-only chaperones
(as-chaperone-or-impersonator
([chaperone-vector impersonate-vector chaperone-vector* impersonate-vector*]
[chaperone-of? impersonator-of? chaperone-of? impersonator-of?])
(let ()
(define v (vector 1 2 3))
(test #t chaperone-of? (chaperone-vector v #f #f) v)
(test #t chaperone-of? v (chaperone-vector v #f #f))
(define v2 (chaperone-vector v #f #f))
(define v3 (chaperone-vector v2 #f #f))
(test #t chaperone-of? v v2)
(test #t chaperone-of? v2 v)
(test #t chaperone-of? v v3)
(test #t chaperone-of? v3 v)
(test #t chaperone-of? v3 v2)
(test #t chaperone-of? v2 v3)
(define vc1 (chaperone-vector v (lambda args (last args)) (lambda args (last args))))
(define vc2 (chaperone-vector vc1 #f #f))
(define v2c1 (chaperone-vector v2 (lambda args (last args)) (lambda args (last args))))
(define v2c2 (chaperone-vector v2c1 #f #f))
(test #t chaperone-of? vc1 v)
(test #t chaperone-of? vc2 v)
(test #t chaperone-of? v2c1 v)
(test #t chaperone-of? v2c2 v)
(test #t chaperone-of? v2c2 v2c1)
(test #t chaperone-of? v2c1 v2c2)
(test #t chaperone-of? vc2 vc1)
(test #t chaperone-of? vc1 vc2)
(test #f chaperone-of? vc1 v2c1)
(test #f chaperone-of? v2c1 vc1)
(test #f chaperone-of? vc2 v2c2)
(test #f chaperone-of? v2c2 vc2)
(test #t chaperone-of? vc1 v2)
(test #t chaperone-of? vc1 v3)
(test #f chaperone-of? v2 vc1)
(test #f chaperone-of? v3 vc1)
(test #t chaperone-of? vc2 v2)
(test #t chaperone-of? vc2 v3)
(test #f chaperone-of? v2 vc2)
(test #f chaperone-of? v3 vc2)
(test #t chaperone-of? v2c1 v2)
(test #t chaperone-of? v2c1 v3)
(test #f chaperone-of? v2 v2c1)
(test #f chaperone-of? v3 v2c1)
(test #t chaperone-of? v2c2 v2)
(test #t chaperone-of? v2c2 v3)
(test #f chaperone-of? v2 v2c2)
(test #f chaperone-of? v3 v2c2)
(err/rt-test (chaperone-vector v #f (lambda args (last args))))
(err/rt-test (chaperone-vector v (lambda args (last args)) #f))))
;; unsafe-chaperone/impersonate-vector
(as-chaperone-or-impersonator
([unsafe-chaperone-vector unsafe-impersonate-vector]
[chaperone-of? impersonator-of?])
(let ()
(define v1 (vector 0))
(define v2 (vector 7))
(define v (unsafe-chaperone-vector v1 v2))
(test #t chaperone-of? v v1)
#;(void
(let* ([v1 (vector 0)]
[v (unsafe-chaperone-vector v1 (vector 7))])
(equal? v v1)))
(test #t equal? v v1)
(test #t equal? v v2)
(test 7 vector-ref v 0)
))
;; unsafe-impersonate-vector
(let ()
(define v1 (vector 0))
(define v2 (vector 7))
(define vc (unsafe-chaperone-vector v1 v2))
(define vi (unsafe-impersonate-vector v1 v2))
(test #t chaperone-of? vc v1)
(test #f chaperone-of? vc v2)
(test #t impersonator-of? vi v1)
(test #t impersonator-of? vi v2))
;; Properties on vector chaperones and chaperone*
(as-chaperone-or-impersonator
([chaperone-vector impersonate-vector]
[chaperone-vector* impersonate-vector*]
[chaperone-of? impersonator-of?])
(let ()
(define b (box #f))
(define-values (p1 p1? get-p1)
(make-impersonator-property 'p1))
(define-values (p2 p2? get-p2)
(make-impersonator-property 'p2))
(define v (vector 1 2 3))
(define v* (chaperone-vector*
v
(λ (c v i x)
(set-box! b (list 'ref (and (p1? c) (get-p1 c))))
x)
(λ (c v i x)
(set-box! b (list 'set (and (p1? c) (get-p1 c))))
x)))
(define vc1 (chaperone-vector v* #f #f p1 'vc1))
(define w (chaperone-vector* (vector 1)
(λ (c v i x)
(set-box! b (list 'ref (and (p1? c) (get-p1 c))))
x)
(λ (c v i x)
(set-box! b (list 'set (and (p1? c) (get-p1 c))))
x)
p1 'working))
(test #t equal? (unbox b) #f)
(vector-ref w 0)
(test #t equal? (unbox b) '(ref working))
(vector-ref vc1 0)
(test #t equal? (unbox b) '(ref vc1))
(vector-set! vc1 0 2)
(test #t equal? (unbox b) '(set vc1))
))
(define (tails lst)
(let loop ([lst lst] [tails null])
(cond
[(null? lst) (reverse tails)]
[else (loop (cdr lst) (cons lst tails))])))
(as-chaperone-or-impersonator
([chaperone-vector impersonate-vector]
[chaperone-vector* impersonate-vector*]
[chaperone-of? impersonator-of?])
(let ()
(define b-regular (box #f))
(define b-star (box #f))
(define b-top (box #f))
(define (reset-and-test-boxes)
(for-each
(λ (b) (set-box! b #f))
(list b-regular b-star b-top))
(for-each
(λ (b)
(test #t equal? (unbox b) #f))
(list b-regular b-star b-top)))
(define-values (p1 p1? get-p1)
(make-impersonator-property 'p1))
(define-values (p2 p2? get-p2)
(make-impersonator-property 'p2))
(define v (vector 1 2 3))
(define prop-only (chaperone-vector v #f #f p1 'prop-only))
(define regular
(chaperone-vector
prop-only
(λ (v i x)
(set-box! b-regular (list 'ref (and (p1? v) (get-p1 v))))
x)
(λ (v i x)
(set-box! b-regular (list 'set (and (p1? v) (get-p1 v))))
x)))
(define star
(chaperone-vector*
regular
(λ (c v i x)
(set-box! b-star (list 'ref (and (p2? c) (get-p2 c))))
x)
(λ (c v i x)
(set-box! b-star (list 'set (and (p2? c) (get-p2 c))))
x)))
(define top
(chaperone-vector
star
(λ (v i x)
(set-box! b-top (list 'ref (and (p1? v) (not (p2? v)) (get-p1 v))))
x)
(λ (v i x)
(set-box! b-top (list 'set (and (p1? v) (not (p2? v)) (get-p1 v))))
x)
p2 'top))
(reset-and-test-boxes)
(vector-ref top 1)
(test #t equal? (unbox b-regular) '(ref prop-only))
(test #t equal? (unbox b-star) '(ref top))
(test #t equal? (unbox b-top) '(ref prop-only))
(reset-and-test-boxes)
(vector-set! top 1 4)
(test #t equal? (unbox b-regular) '(set prop-only))
(test #t equal? (unbox b-star) '(set top))
(test #t equal? (unbox b-top) '(set prop-only))
(define chaps
(list top
star
regular
prop-only
v))
(for ([chap (in-list chaps)]
[vecs (in-list (tails chaps))])
(for ([vec (in-list vecs)])
(test #t chaperone-of? chap vec)))))
(as-chaperone-or-impersonator
([chaperone-vector impersonate-vector]
[chaperone-vector* impersonate-vector*]
[chaperone-of? impersonator-of?])
(define b-regular (box #f))
(define b-star (box #f))
(define b-top (box #f))
(define (reset-and-test-boxes)
(for-each
(λ (b) (set-box! b #f))
(list b-regular b-star b-top))
(for-each
(λ (b)
(test #t equal? (unbox b) #f))
(list b-regular b-star b-top)))
(define-values (p1 p1? get-p1)
(make-impersonator-property 'p1))
(define-values (p2 p2? get-p2)
(make-impersonator-property 'p2))
(define v (vector 1 2 3))
(define prop-only (chaperone-vector v #f #f p1 'prop-only))
(define regular
(chaperone-vector
prop-only
(λ (v i x)
(set-box! b-regular (list 'ref (and (p1? v) (get-p1 v))))
x)
(λ (v i x)
(set-box! b-regular (list 'set (and (p1? v) (get-p1 v))))
x)))
(define star
(chaperone-vector*
regular
(λ (c v i x)
(set-box! b-star (list 'ref (and (p2? c) (get-p2 c))))
x)
(λ (c v i x)
(set-box! b-star (list 'set (and (p2? c) (get-p2 c))))
x)))
(define prop-only2
(chaperone-vector star #f #f p1 'prop-only2))
(define top
(chaperone-vector
prop-only2
(λ (v i x)
(set-box! b-top (list 'ref (and (p1? v) (not (p2? v)) (get-p1 v))))
x)
(λ (v i x)
(set-box! b-top (list 'set (and (p1? v) (not (p2? v)) (get-p1 v))))
x)
p2 'top))
(reset-and-test-boxes)
(vector-ref top 1)
(test #t equal? (unbox b-regular) '(ref prop-only))
(test #t equal? (unbox b-star) '(ref top))
(test #t equal? (unbox b-top) '(ref prop-only2))
(reset-and-test-boxes)
(vector-set! top 1 4)
(test #t equal? (unbox b-regular) '(set prop-only))
(test #t equal? (unbox b-star) '(set top))
(test #t equal? (unbox b-top) '(set prop-only2))
(define chaps
(list top
prop-only2
star
regular
prop-only
v))
(for ([chap (in-list chaps)]
[vecs (in-list (tails chaps))])
(for ([vec (in-list vecs)])
(test #t chaperone-of? chap vec))))
(as-chaperone-or-impersonator
([chaperone-vector impersonate-vector]
[chaperone-vector* impersonate-vector*]
[chaperone-of? impersonator-of?])
(define b (box #f))
(define (clear) (set-box! b #f))
(define-values (p1 p1? get-p1)
(make-impersonator-property 'p1))
(define-values (p2 p2? get-p2)
(make-impersonator-property 'p2))
(define-values (p3 p3? get-p3)
(make-impersonator-property 'p3))
(define v (vector 1 2 3))
(define c
(chaperone-vector*
v
(λ (c v i x)
(define props
(list 'ref
(and (p1? c) (get-p1 c))
(and (p2? c) (get-p2 c))
(and (p3? c) (get-p3 c))))
(set-box! b props)
x)
(λ (c v i x)
(define props
(list 'set
(and (p1? c) (get-p1 c))
(and (p2? c) (get-p2 c))
(and (p3? c) (get-p3 c))))
(set-box! b props)
x)))
(define (add-chap v . props)
(apply chaperone-vector v #f #f props))
(clear)
(test #f unbox b)
(define c1 (add-chap c p1 'p1))
(vector-ref c1 0)
(test '(ref p1 #f #f) unbox b)
(clear)
(vector-set! c1 0 1)
(test '(set p1 #f #f) unbox b)
(clear)
(test #t p1? c1)
(test #f p2? c1)
(test #f p3? c1)
(define c2 (add-chap c1 p2 'p2))
(clear)
(vector-ref c2 0)
(test '(ref p1 p2 #f) unbox b)
(clear)
(vector-set! c2 0 1)
(test '(set p1 p2 #f) unbox b)
(clear)
(test #t p1? c2)
(test #t p2? c2)
(test #f p3? c2)
(define c3 (add-chap c2 p3 'p3))
(clear)
(vector-ref c3 0)
(test '(ref p1 p2 p3) unbox b)
(clear)
(vector-set! c3 0 1)
(test '(set p1 p2 p3) unbox b)
(clear)
(test #t p1? c3)
(test #t p2? c3)
(test #t p3? c3)
(define c4 (add-chap c3 p3 'p3-new p1 'p1-new))
(clear)
(vector-ref c4 0)
(test '(ref p1-new p2 p3-new) unbox b)
(clear)
(vector-set! c4 0 1)
(test '(set p1-new p2 p3-new) unbox b)
(clear)
(test #t p1? c4)
(test #t p2? c4)
(test #t p3? c4))
;; Properties on unsafe ...
(as-chaperone-or-impersonator
([unsafe-chaperone-vector unsafe-impersonate-vector])
(define-values (p1 p1? get-p1)
(make-impersonator-property 'p1))
(define-values (p2 p2? get-p2)
(make-impersonator-property 'p2))
(define v1 (vector 1 2 3))
(define v2 (vector 2 4 6))
(define uc (unsafe-chaperone-vector v1 v2 p1 'has-p1))
(test #f p1? v1)
(test #f p1? v2)
(test #t p1? uc)
(test 'has-p1 get-p1 uc)
(define v3 (vector 3 6 9))
(define uc2 (unsafe-chaperone-vector uc v3 p2 'has-p2))
(test #t p1? uc2)
(test #t p2? uc2)
(test 'has-p1 get-p1 uc2)
(test 'has-p2 get-p2 uc2))
(as-chaperone-or-impersonator
([unsafe-chaperone-vector unsafe-impersonate-vector])
(define v (unsafe-chaperone-vector (vector 1) (vector 2 3)))
(test 2 vector-length v)
(test "'#(2 3)" (λ (v) (with-output-to-string (λ () (print v)))) v))
(as-chaperone-or-impersonator
([chaperone-vector impersonate-vector]
[chaperone-vector* impersonate-vector*]
[chaperone-of? impersonator-of?])
(define u (unsafe-chaperone-vector (vector 1) (vector 2 3)))
(test #t vector? u)
(test 2 vector-length u)
(define po (chaperone-vector (vector 1) #f #f))
(test #t vector? po)
(test 1 vector-length po)
(define po2 (chaperone-vector* (vector 1) #f #f))
(test #t vector? po2)
(test 1 vector-length po2)
(define c (chaperone-vector (vector 1) (λ (v i x) x) (λ (v i x) x)))
(test #t vector? c)
(test 1 vector-length c)
(define c* (chaperone-vector* (vector 1) (λ (c v i x) x) (λ (c v i x) x)))
(test #t vector? c*)
(test 1 vector-length c*))
(as-chaperone-or-impersonator
([chaperone-vector impersonate-vector]
[chaperone-vector* impersonate-vector*]
[chaperone-of? impersonator-of?])
(define v (vector 1 2 3))
(define ov (vector 4 8 12))
(define-values (p1 p1? get-p1)
(make-impersonator-property 'p1))
(define-values (p2 p2? get-p2)
(make-impersonator-property 'p2))
(define b (box #f))
(define (clear) (set-box! b #f))
(define uc (unsafe-chaperone-vector v ov))
(define c*
(chaperone-vector*
uc
(λ (c v i x)
(define props
(list 'ref
(and (p1? c) (get-p1 c))
(and (p2? c) (get-p2 c))))
(set-box! b props)
x)
(λ (c v i x)
(define props
(list 'set
(and (p1? c) (get-p1 c))
(and (p2? c) (get-p2 c))))
(set-box! b props)
x)))
(define c1 (chaperone-vector c* #f #f p1 'p1-prop))
(test 8 vector-ref c1 1)
(test '(ref p1-prop #f) unbox b)
(clear)
(vector-set! c1 1 11)
(test '(set p1-prop #f) unbox b)
(test 11 vector-ref c1 1)
(clear)
(test #f unbox b)
(define c2 (chaperone-vector c1 #f #f p2 'p2-prop))
(test 11 vector-ref c2 1)
(test '(ref p1-prop p2-prop) unbox b)
(clear)
(vector-set! c2 1 17)
(test '(set p1-prop p2-prop) unbox b)
(test 17 vector-ref c2 1))
(define unsafe-chaperone-vector-name "unsafe-chaperone-vector")
(define unsafe-impersonate-vector-name "unsafe-impersonate-vector")
(as-chaperone-or-impersonator
([chaperone-vector impersonate-vector]
[chaperone-vector* impersonate-vector*]
[unsafe-chaperone-vector unsafe-impersonate-vector]
[chaperone-of? impersonator-of?]
[unsafe-chaperone-vector-name unsafe-impersonate-vector-name])
(define v1 (vector 1 2 3))
(define v2 (vector 7 11 13))
(define-values (p1 p1? get-p1)
(make-impersonator-property 'p1))
(define-values (p2 p2? get-p2)
(make-impersonator-property 'p2))
(define-values (p3 p3? get-p3)
(make-impersonator-property 'p3))
(define-values (p4 p4? get-p4)
(make-impersonator-property 'p4))
(define b (box '()))
(define (clear) (set-box! b '()))
(define (do-chap v tag . rst)
(apply
chaperone-vector*
v
(λ (c v i x)
(define props
(list 'ref tag
(and (p1? c) (get-p1 c))
(and (p2? c) (get-p2 c))
(and (p3? c) (get-p3 c))
(and (p4? c) (get-p4 c))))
(set-box! b (cons props (unbox b)))
x)
(λ (c v i x)
(define props
(list 'set tag
(and (p1? c) (get-p1 c))
(and (p2? c) (get-p2 c))
(and (p3? c) (get-p3 c))
(and (p4? c) (get-p4 c))))
(set-box! b (cons props (unbox b)))
x)
rst))
(define c1 (do-chap v1 'c1 p1 'p1-c1))
(define c2 (do-chap c1 'c2 p2 'p2-c2))
(define t (vector-ref c2 1))
(test #t equal? 2 t)
(test '((ref c2 p1-c1 p2-c2 #f #f) (ref c1 p1-c1 p2-c2 #f #f)) unbox b)
(clear)
(define (add-prop v #:redirect [redirect #f] . rst)
(define interposition (and redirect (λ (v i x) x)))
(apply chaperone-vector v interposition interposition rst))
(define c*1 (do-chap v2 'c*1))
(define pc*1 (add-prop c*1 p1 'p1-pc*1))
(define pc*2 (add-prop pc*1 p2 'p2-pc*2))
(define c*2 (do-chap pc*2 'c*2 p3 'p3-pc*2))
(define pc*3 (add-prop c*2 p4 'p4-pc*3))
(define r (vector-ref pc*3 1))
(test #t equal? 11 r)
(test '((ref c*2 p1-pc*1 p2-pc*2 p3-pc*2 p4-pc*3) (ref c*1 p1-pc*1 p2-pc*2 p3-pc*2 p4-pc*3)) unbox b)
(clear)
(define np1 (add-prop pc*3 p1 'p1-np1))
(define np3 (add-prop np1 p3 'p3-np3))
(vector-set! np3 2 17)
(test '((set c*1 p1-np1 p2-pc*2 p3-np3 p4-pc*3) (set c*2 p1-np1 p2-pc*2 p3-np3 p4-pc*3))
unbox
b)
(define a (vector-ref np3 2))
(test #t equal? 17 a)
(clear)
(define v3 (vector 12 16 20))
(define u3 (do-chap (vector -3 -5) 'u3))
(err/rt-test (unsafe-chaperone-vector v3 u3)
(λ (exn)
(test #t
regexp-match?
(string-append
unsafe-chaperone-vector-name
": contract violation")
(exn-message exn))
(test #t
(regexp-match?
"(and/c vector? (not/c impersonator?))"
(exn-message exn)))))
(clear)
(define vc*1 (do-chap (vector 93 77 26) 'vc*1))
(define cvc*1 (add-prop vc*1 p1 'p1-cvc*1 #:redirect #t))
(define cvc*2 (add-prop cvc*1 p2 'p2-cvc*2 #:redirect #t))
(define vc*2 (do-chap cvc*2 'vc*2 p3 'p3-vc*2))
(define cvc*3 (add-prop vc*2 p4 'p4-cvc*3 #:redirect #t))
(define cvc*3-ref (vector-ref cvc*3 1))
(test #t equal? 77 cvc*3-ref)
(test '((ref vc*2 p1-cvc*1 p2-cvc*2 p3-vc*2 p4-cvc*3) (ref vc*1 p1-cvc*1 p2-cvc*2 p3-vc*2 p4-cvc*3)) unbox b)
)
;; ----------------------------------------
(test #t chaperone?/impersonator (chaperone-procedure (lambda (x) x) (lambda (y) y)))

3
racket/src/racket/src/bool.c
View File

@ -639,7 +639,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
}
if (!eql->for_chaperone) {
if (SCHEME_CHAPERONEP(obj1)) {
obj1 = ((Scheme_Chaperone *)obj1)->val;
/* OPT only use prev for unsafe-chaperone-vector, use val otherwise */
obj1 = ((Scheme_Chaperone *)obj1)->prev;
goto top_after_next;
}
if (SCHEME_CHAPERONEP(obj2)) {

2375
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

3
racket/src/racket/src/fun.c
View File

@ -3649,7 +3649,8 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
initialized to -1) in a vector.
Vector of odd size for redirects means a procedure chaperone,
vector with even slots means a structure chaperone.
vector with non-zero even slots means a structure chaperone,
vector with zero slots means a property-only vector chaperone.
A size of 5 (instead of 3) indicates that the wrapper
procedure accepts a "self" argument. An immutable vector
means that it wraps a chaperone that wants the "self"

43
racket/src/racket/src/jitcommon.c
View File

@ -1049,7 +1049,7 @@ static int generate_apply_proxy(mz_jit_state *jitter, int setter)
original chaperone and index on runstack;
for setter, put back result in R2, vec in R0, and index in V1 */
{
GC_CAN_IGNORE jit_insn *ref, *ref1, *ref2;
GC_CAN_IGNORE jit_insn *ref, *ref1, *ref2, *ref3, *ref_chaperone_of_check, *ref_not_star;
GC_CAN_IGNORE jit_insn *refrts USED_ONLY_FOR_FUTURES;
CHECK_LIMIT();
@ -1058,12 +1058,13 @@ static int generate_apply_proxy(mz_jit_state *jitter, int setter)
/* if chaperone was for properties, only, then we're done */
ref = mz_beqi_t(jit_forward(), JIT_R1, scheme_vector_type, JIT_V1);
/* unsafe vector chaperones also don't have any interposition */
ref1 = mz_beqi_t(jit_forward(), JIT_R1, scheme_false_type, JIT_V1);
if (setter)
jit_ldxi_p(JIT_V1, JIT_R1, &SCHEME_CDR(0x0)); /* rator */
else
jit_ldxi_p(JIT_V1, JIT_R1, &SCHEME_CAR(0x0)); /* rator */
jit_ldxi_p(JIT_R2, JIT_R2, &((Scheme_Chaperone *)0x0)->prev); /* vec */
jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(1)); /* index */
if (setter) {
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(4));
@ -1073,9 +1074,37 @@ static int generate_apply_proxy(mz_jit_state *jitter, int setter)
jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R0); /* save value */
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(3));
}
jit_str_p(JIT_RUNSTACK, JIT_R2);
jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1);
jit_stxi_p(WORDS_TO_BYTES(2), JIT_RUNSTACK, JIT_R0);
jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1);
jit_ldxi_p(JIT_R0, JIT_R2, &((Scheme_Chaperone *)0x0)->prev); /* vec */
jit_str_p(JIT_RUNSTACK, JIT_R0);
/* if we have a chaperone-vector*, fall through and use extra arg */
jit_ldxi_s(JIT_R2, JIT_R2, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso));
ref_not_star = jit_bmci_ul(jit_forward(), JIT_R2, SCHEME_VEC_CHAPERONE_STAR);
/* get outermost from further down the stack */
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1));
if (setter){
jit_ldxi_p(JIT_R0, JIT_RUNSTACK, WORDS_TO_BYTES(5));
} else {
jit_ldxi_p(JIT_R0, JIT_RUNSTACK, WORDS_TO_BYTES(4));
}
jit_str_p(JIT_RUNSTACK, JIT_R0);
CHECK_LIMIT();
JIT_UPDATE_THREAD_RSPTR();
__END_SHORT_JUMPS__(1);
scheme_generate_non_tail_call(jitter, 4, 0, 0, 0, 0, 0, 0, 1, 0, NULL);
__START_SHORT_JUMPS__(1);
CHECK_LIMIT();
if (setter) {
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(5));
} else {
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(4));
}
ref_chaperone_of_check = jit_jmpi(jit_forward());
mz_patch_branch(ref_not_star);
CHECK_LIMIT();
JIT_UPDATE_THREAD_RSPTR();
__END_SHORT_JUMPS__(1);
@ -1088,16 +1117,17 @@ static int generate_apply_proxy(mz_jit_state *jitter, int setter)
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(3));
}
mz_patch_branch(ref_chaperone_of_check);
jit_ldr_p(JIT_R1, JIT_RUNSTACK);
jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso));
/* if impersonator, no chaperone-of check needed */
ref1 = jit_bmsi_ul(jit_forward(), JIT_R2, SCHEME_CHAPERONE_IS_IMPERSONATOR);
ref2 = jit_bmsi_ul(jit_forward(), JIT_R2, SCHEME_CHAPERONE_IS_IMPERSONATOR);
if (setter)
jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(-1)); /* saved value */
else
jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(1)); /* saved value */
ref2 = jit_beqr_p(jit_forward(), JIT_R1, JIT_R0);
ref3 = jit_beqr_p(jit_forward(), JIT_R1, JIT_R0);
CHECK_LIMIT();
jit_prepare(3);
jit_movi_i(JIT_R2, setter);
@ -1112,6 +1142,7 @@ static int generate_apply_proxy(mz_jit_state *jitter, int setter)
mz_patch_branch(ref);
mz_patch_branch(ref1);
mz_patch_branch(ref2);
mz_patch_branch(ref3);
if (setter) {
jit_movr_p(JIT_R2, JIT_R0); /* result needed in R2 for setter */
jit_ldxi_p(JIT_V1, JIT_RUNSTACK, WORDS_TO_BYTES(1)); /* saved index */

4
racket/src/racket/src/schminc.h
View File

@ -14,8 +14,8 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1153
#define EXPECTED_UNSAFE_COUNT 126
#define EXPECTED_PRIM_COUNT 1155
#define EXPECTED_UNSAFE_COUNT 128
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45
#define EXPECTED_FUTURES_COUNT 15

7
racket/src/racket/src/schpriv.h
View File

@ -1166,6 +1166,13 @@ typedef struct Scheme_Chaperone {
#define SCHEME_CHAPERONE_FLAGS(c) MZ_OPT_HASH_KEY(&(c)->iso)
#define SCHEME_CHAPERONE_IS_IMPERSONATOR 0x1
#define SCHEME_PROC_CHAPERONE_CALL_DIRECT 0x2
/*
We use the same bit to indicate either chaperone-vector* as well as
procedure chaperones which do not call interposition procedures.
This is ok because no value is simultaneously a vector and a procedure,
so we can safely reuse the bit.
*/
#define SCHEME_VEC_CHAPERONE_STAR 0x2
#define SCHEME_CHAPERONE_VAL(obj) (((Scheme_Chaperone *)obj)->val)

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.9.0.1"
#define MZSCHEME_VERSION "6.9.0.2"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 9
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 1
#define MZSCHEME_VERSION_W 2
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

5
racket/src/racket/src/struct.c
View File

@ -2465,6 +2465,11 @@ int scheme_is_noninterposing_chaperone(Scheme_Object *o)
return 0;
}
if (SCHEME_VEC_SIZE(px->redirects) == 0) {
/* property-only vector chaperone */
return 1;
}
if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0]))
return 0;

158
racket/src/racket/src/vector.c
View File

@ -51,7 +51,11 @@ static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_vector(int argc, Scheme_Object **argv);
static Scheme_Object *chaperone_vector_star(int argc, Scheme_Object **argv);
static Scheme_Object *impersonate_vector(int argc, Scheme_Object **argv);
static Scheme_Object *impersonate_vector_star(int argc, Scheme_Object **argv);
static Scheme_Object *unsafe_chaperone_vector(int argc, Scheme_Object **argv);
static Scheme_Object *unsafe_impersonate_vector(int argc, Scheme_Object **argv);
static Scheme_Object *unsafe_vector_len (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[]);
@ -168,11 +172,24 @@ scheme_init_vector (Scheme_Env *env)
"chaperone-vector",
3, -1),
env);
scheme_add_global_constant("chaperone-vector*",
scheme_make_prim_w_arity(chaperone_vector_star,
"chaperone-vector*",
3, -1),
env);
scheme_add_global_constant("impersonate-vector",
scheme_make_prim_w_arity(impersonate_vector,
"impersonate-vector",
3, -1),
env);
scheme_add_global_constant("impersonate-vector*",
scheme_make_prim_w_arity(impersonate_vector_star,
"impersonate-vector*",
3, -1),
env);
}
void
@ -272,6 +289,18 @@ scheme_init_unsafe_vector (Scheme_Env *env)
p = scheme_make_immed_prim(unsafe_bytes_set, "unsafe-bytes-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_add_global_constant("unsafe-bytes-set!", p, env);
scheme_add_global_constant("unsafe-impersonate-vector",
scheme_make_prim_w_arity(unsafe_impersonate_vector,
"unsafe-impersonate-vector",
2, -1),
env);
scheme_add_global_constant("unsafe-chaperone-vector",
scheme_make_prim_w_arity(unsafe_chaperone_vector,
"unsafe-chaperone-vector",
2, -1),
env);
}
#define VECTOR_BYTES(size) (sizeof(Scheme_Vector) + ((size) - mzFLEX_DELTA) * sizeof(Scheme_Object *))
@ -445,13 +474,13 @@ static Scheme_Object *chaperone_vector_ref_overflow(Scheme_Object *o, int i)
return scheme_handle_stack_overflow(chaperone_vector_ref_k);
}
Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i)
Scheme_Object *scheme_chaperone_vector_ref2(Scheme_Object *o, int i, Scheme_Object *outermost)
{
if (!SCHEME_NP_CHAPERONEP(o)) {
return SCHEME_VEC_ELS(o)[i];
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[3], *red, *orig;
Scheme_Object *a[4], *red, *orig;
#ifdef DO_STACK_CHECK
{
@ -460,18 +489,33 @@ Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i)
}
#endif
orig = scheme_chaperone_vector_ref(px->prev, i);
if(SCHEME_FALSEP(px->redirects)) {
/* unsafe chaperones */
return scheme_chaperone_vector_ref2(px->val, i, outermost);
}
orig = scheme_chaperone_vector_ref2(px->prev, i, outermost);
if (SCHEME_VECTORP(px->redirects)) {
/* chaperone was on property accessors */
/* or vector chaperone is property only */
return orig;
}
red = SCHEME_CAR(px->redirects);
if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_VEC_CHAPERONE_STAR) {
a[0] = outermost;
a[1] = px->prev;
a[2] = scheme_make_integer(i);
a[3] = orig;
o = _scheme_apply(red, 4, a);
}
else {
a[0] = px->prev;
a[1] = scheme_make_integer(i);
a[2] = orig;
red = SCHEME_CAR(px->redirects);
o = _scheme_apply(red, 3, a);
}
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(o, orig))
@ -481,6 +525,11 @@ Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i)
}
}
Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i)
{
return scheme_chaperone_vector_ref2(o, i, o);
}
Scheme_Object *
scheme_checked_vector_ref (int argc, Scheme_Object *argv[])
{
@ -510,24 +559,46 @@ scheme_checked_vector_ref (int argc, Scheme_Object *argv[])
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v)
{
Scheme_Object *outermost = o;
while (1) {
if (!SCHEME_NP_CHAPERONEP(o)) {
SCHEME_VEC_ELS(o)[i] = v;
return;
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[3], *red;
Scheme_Object *a[4], *red;
int chap_star = SCHEME_CHAPERONE_FLAGS(px) & SCHEME_VEC_CHAPERONE_STAR ? 1 : 0;
red = px->redirects;
if (SCHEME_FALSEP(red)) {
o = px->val;
continue;
}
o = px->prev;
if (!SCHEME_VECTORP(red)) {
/* not a property only chaperone */
red = SCHEME_CDR(px->redirects);
if (chap_star) {
a[0] = outermost;
a[1] = o;
a[2] = scheme_make_integer(i);
a[3] = v;
v = _scheme_apply(red, 4, a);
}
else {
a[0] = o;
a[1] = scheme_make_integer(i);
a[2] = v;
red = SCHEME_CDR(px->redirects);
v = _scheme_apply(red, 3, a);
}
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(v, a[2]))
scheme_wrong_chaperoned("vector-set!", "value", a[2], v);
if (!scheme_chaperone_of(v, a[2 + chap_star]))
scheme_wrong_chaperoned("vector-set!", "value", a[2 + chap_star], v);
}
}
}
}
@ -850,25 +921,58 @@ static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[])
return SCHEME_MULTIPLE_VALUES;
}
static Scheme_Object *do_chaperone_vector(const char *name, int is_impersonator, int argc, Scheme_Object **argv)
static Scheme_Object *do_chaperone_vector(const char *name, int is_impersonator, int pass_self, int unsafe, int argc, Scheme_Object **argv)
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0];
Scheme_Object *redirects;
Scheme_Hash_Tree *props;
if (SCHEME_CHAPERONEP(val))
if (SCHEME_CHAPERONEP(val)) {
val = SCHEME_CHAPERONE_VAL(val);
}
if (!SCHEME_VECTORP(val)
|| (is_impersonator && !SCHEME_MUTABLEP(val)))
scheme_wrong_contract(name, is_impersonator ? "(and/c vector? (not/c immutable?))" : "vector?", 0, argc, argv);
scheme_check_proc_arity(name, 3, 1, argc, argv);
scheme_check_proc_arity(name, 3, 2, argc, argv);
props = scheme_parse_chaperone_props(name, 3, argc, argv);
if (unsafe) {
/* We cannot dispatch the operations on an unsafe vector chaperone to a chaperoned vector because of the invariant
that the val field of a vector chaperone must point to a non-chaperoned vector.
To ensure this we error if the second argument passed to `unsafe-chaperone-vector` is not a unchaperoned vector */
if (!SCHEME_VECTORP(argv[1])) {
scheme_wrong_contract(name, "(and/c vector? (not/c impersonator?))", 1, argc, argv);
}
val = argv[1];
}
else {
/* allow false for interposition procedures */
scheme_check_proc_arity2(name, 3 + (pass_self ? 1 : 0), 1, argc, argv,1);
if (SCHEME_PROCP(argv[1])) {
scheme_check_proc_arity(name, 3 + (pass_self ? 1 : 0), 2, argc, argv);
}
else if (!SCHEME_FALSEP(argv[2])) {
scheme_wrong_contract(name, "#f", 2, argc, argv);
}
}
props = scheme_parse_chaperone_props(name, unsafe ? 2 : 3, argc, argv);
/*
Regular vector chaperones store redirect procedures in a pair, (cons getter setter).
Property only vector chaperones have no redirection procedures, and redirects is assigned an empty vector.
Unsafe vector chaperones dispatch operations to another vector stored in a box in redirects.
*/
if (SCHEME_FALSEP(argv[1])) {
redirects = scheme_make_vector(0, NULL);
}
else if (unsafe) {
redirects = scheme_false;
}
else {
redirects = scheme_make_pair(argv[1], argv[2]);
}
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->iso.so.type = scheme_chaperone_type;
@ -880,17 +984,41 @@ static Scheme_Object *do_chaperone_vector(const char *name, int is_impersonator,
if (is_impersonator)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
/* Use flag to tell if the chaperone is a chaperone* */
if (pass_self) {
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_VEC_CHAPERONE_STAR;
}
return (Scheme_Object *)px;
}
static Scheme_Object *chaperone_vector(int argc, Scheme_Object **argv)
{
return do_chaperone_vector("chaperone-vector", 0, argc, argv);
return do_chaperone_vector("chaperone-vector", 0, 0, 0, argc, argv);
}
static Scheme_Object *chaperone_vector_star(int argc, Scheme_Object **argv)
{
return do_chaperone_vector("chaperone-vector", 0, 1, 0, argc, argv);
}
static Scheme_Object *impersonate_vector(int argc, Scheme_Object **argv)
{
return do_chaperone_vector("impersonate-vector", 1, argc, argv);
return do_chaperone_vector("impersonate-vector", 1, 0, 0, argc, argv);
}
static Scheme_Object *impersonate_vector_star(int argc, Scheme_Object **argv)
{
return do_chaperone_vector("impersonate-vector", 1, 1, 0, argc, argv);
}
static Scheme_Object *unsafe_chaperone_vector(int argc, Scheme_Object **argv)
{
return do_chaperone_vector("unsafe-chaperone-vector", 0, 0, 1, argc, argv);
}
static Scheme_Object *unsafe_impersonate_vector(int argc, Scheme_Object **argv)
{
return do_chaperone_vector("unsafe-impersonate-vector", 1, 0, 1, argc, argv);
}
/************************************************************/