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

cs: fix vector-set! and set-box! impersonation

Browse Source 
Use the result from an interposition to install into the vector or
box, instead of the original value.
This commit is contained in:
Matthew Flatt 2019-05-20 14:22:59 -06:00
parent 7f40729f30
commit b268f77ae9
4 changed files with 65 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -149,6 +149,28 @@
(test #f unbox b) (test #f unbox b)
(test #f unbox b2))) (test #f unbox b2)))
;; check that `set-box!` uses the result of chaperone/impersonator
(as-chaperone-or-impersonator
([chaperone-box impersonate-box])
(let ([b (box (vector 1))])
(let ([b2 (chaperone-box b
(lambda (b v) v)
(lambda (b v)
(chaperone-vector
v
(lambda (b i v) (if (eq? v 'ok)
v
(error "oops")))
(lambda (b i v) #f))))])
(test (void) 'ok-vector-set! (set-box! b2 (vector 8)))
(let ([inner (unbox b2)])
(test 'oops 'bad-vector-ref-from-box
(with-handlers ([exn:fail? (lambda (exn) 'oops)])
(vector-ref inner 0))))
(test (void) 'ok-set-box! (set-box! b2 (vector 'ok)))
(let ([inner (unbox b2)])
(test 'ok 'ok-vector-ref-from-box (vector-ref inner 0))))))
;; ---------------------------------------- ;; ----------------------------------------
(test #t chaperone?/impersonator (chaperone-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v))) (test #t chaperone?/impersonator (chaperone-vector (vector 1 2 3) (lambda (b i v) v) (lambda (b i v) v)))
@ -217,6 +239,28 @@
(test #f vector-ref b2 0) (test #f vector-ref b2 0)
(err/rt-test (vector-set! b2 0 0)))) (err/rt-test (vector-set! b2 0 0))))
;; check that `vector-set!` uses the result of chaperone/impersonator
(as-chaperone-or-impersonator
([chaperone-vector impersonate-vector])
(let ([b (vector (vector 1))])
(let ([b2 (chaperone-vector b
(lambda (b i v) v)
(lambda (b i v)
(chaperone-vector
v
(lambda (b i v) (if (eq? v 'ok)
v
(error "oops")))
(lambda (b i v) #f))))])
(test (void) 'ok-vector-set! (vector-set! b2 0 (vector 8)))
(let ([inner (vector-ref b2 0)])
(test 'oops 'bad-vector-ref
(with-handlers ([exn:fail? (lambda (exn) 'oops)])
(vector-ref inner 0))))
(test (void) 'ok-vector-set! (vector-set! b2 0 (vector 'ok)))
(let ([inner (vector-ref b2 0)])
(test 'ok 'ok-vector-ref (vector-ref inner 0))))))
;; no impersonator-of checks in a impersonator: ;; no impersonator-of checks in a impersonator:
(let ([b (vector 0)]) (let ([b (vector 0)])
(let ([b2 (impersonate-vector b (let ([b2 (impersonate-vector b

6
racket/src/cs/rumble/box.ss
View File

@ -91,7 +91,7 @@
[(#%box? o) (#%unbox o)] [(#%box? o) (#%unbox o)]
[(box-chaperone? o) [(box-chaperone? o)
(let* ([val (loop (impersonator-next o))] (let* ([val (loop (impersonator-next o))]
[new-val ((box-chaperone-ref o) o val)]) [new-val (|#%app| (box-chaperone-ref o) o val)])
(unless (chaperone-of? new-val val) (unless (chaperone-of? new-val val)
(raise-arguments-error 'unbox (raise-arguments-error 'unbox
"chaperone produced a result that is not a chaperone of the original result" "chaperone produced a result that is not a chaperone of the original result"
@ -120,13 +120,13 @@
(let ([next (impersonator-next o)]) (let ([next (impersonator-next o)])
(cond (cond
[(box-chaperone? o) [(box-chaperone? o)
(let ([new-val ((box-chaperone-set o) next val)]) (let ([new-val (|#%app| (box-chaperone-set o) next val)])
(unless (chaperone-of? new-val val) (unless (chaperone-of? new-val val)
(raise-arguments-error 'set-box! (raise-arguments-error 'set-box!
"chaperone produced a result that is not a chaperone of the original result" "chaperone produced a result that is not a chaperone of the original result"
"chaperone result" new-val "chaperone result" new-val
"original result" val)) "original result" val))
(loop next val))] (loop next new-val))]
[(box-impersonator? o) [(box-impersonator? o)
(loop next ((box-impersonator-set o) next val))] (loop next ((box-impersonator-set o) next val))]
[else (loop next val)]))]))]))) [else (loop next val)]))]))])))

18
racket/src/cs/rumble/hash.ss
View File

@ -1064,7 +1064,7 @@
(impersonate-hash-ref/set 'hash-ref #f (impersonate-hash-ref/set 'hash-ref #f
(lambda (ht k v) (hash-ref ht k none)) (lambda (ht k v) (hash-ref ht k none))
(lambda (procs ht k none-v) (lambda (procs ht k none-v)
((hash-procs-ref procs) ht k)) (|#%app| (hash-procs-ref procs) ht k))
hash-procs-ref hash-procs-ref
ht k none)) ht k none))
@ -1072,7 +1072,7 @@
(impersonate-hash-ref/set 'hash-set! #t (impersonate-hash-ref/set 'hash-set! #t
hash-set! hash-set!
(lambda (procs ht k v) (lambda (procs ht k v)
((hash-procs-set procs) ht k v)) (|#%app| (hash-procs-set procs) ht k v))
hash-procs-set hash-procs-set
ht k v)) ht k v))
@ -1080,7 +1080,7 @@
(impersonate-hash-ref/set 'hash-set #t (impersonate-hash-ref/set 'hash-set #t
hash-set hash-set
(lambda (procs ht k v) (lambda (procs ht k v)
((hash-procs-set procs) ht k v)) (|#%app| (hash-procs-set procs) ht k v))
hash-procs-set hash-procs-set
ht k v)) ht k v))
@ -1088,7 +1088,7 @@
(impersonate-hash-ref/set 'hash-remove! #t (impersonate-hash-ref/set 'hash-remove! #t
(lambda (ht k false-v) (hash-remove! ht k)) (lambda (ht k false-v) (hash-remove! ht k))
(lambda (procs ht k false-v) (lambda (procs ht k false-v)
(values ((hash-procs-remove procs) ht k) #f)) (values (|#%app| (hash-procs-remove procs) ht k) #f))
hash-procs-remove hash-procs-remove
ht k #f)) ht k #f))
@ -1096,7 +1096,7 @@
(impersonate-hash-ref/set 'hash-remove #t (impersonate-hash-ref/set 'hash-remove #t
(lambda (ht k false-v) (hash-remove ht k)) (lambda (ht k false-v) (hash-remove ht k))
(lambda (procs ht k false-v) (lambda (procs ht k false-v)
(values ((hash-procs-remove procs) ht k) #f)) (values (|#%app| (hash-procs-remove procs) ht k) #f))
hash-procs-remove hash-procs-remove
ht k #f)) ht k #f))
@ -1172,7 +1172,7 @@
(define (extend-get-k who get-k procs next-ht chaperone?) (define (extend-get-k who get-k procs next-ht chaperone?)
(lambda (k) (lambda (k)
(let* ([k (get-k k)] (let* ([k (get-k k)]
[new-k ((hash-procs-equal-key procs) next-ht k)]) [new-k (|#%app| (hash-procs-equal-key procs) next-ht k)])
(unless (or (not chaperone?) (chaperone-of? new-k k)) (unless (or (not chaperone?) (chaperone-of? new-k k))
(raise-chaperone-error who "key" new-k k)) (raise-chaperone-error who "key" new-k k))
new-k))) new-k)))
@ -1189,7 +1189,7 @@
(let ([clear (hash-procs-clear procs)]) (let ([clear (hash-procs-clear procs)])
(cond (cond
[clear [clear
(clear next-ht) (|#%app| clear next-ht)
(if mutable? (if mutable?
(loop next-ht) (loop next-ht)
(let ([r (loop next-ht)]) (let ([r (loop next-ht)])
@ -1268,12 +1268,12 @@
[(hash-impersonator? ht) [(hash-impersonator? ht)
(let ([procs (hash-impersonator-procs ht)] (let ([procs (hash-impersonator-procs ht)]
[ht (impersonator-next ht)]) [ht (impersonator-next ht)])
((hash-procs-key procs) ht (loop ht)))] (|#%app| (hash-procs-key procs) ht (loop ht)))]
[(hash-chaperone? ht) [(hash-chaperone? ht)
(let ([procs (hash-chaperone-procs ht)] (let ([procs (hash-chaperone-procs ht)]
[ht (impersonator-next ht)]) [ht (impersonator-next ht)])
(let* ([k (loop ht)] (let* ([k (loop ht)]
[new-k ((hash-procs-key procs) ht k)]) [new-k (|#%app| (hash-procs-key procs) ht k)])
(unless (chaperone-of? new-k k) (unless (chaperone-of? new-k k)
(raise-chaperone-error who "key" new-k k)) (raise-chaperone-error who "key" new-k k))
new-k))] new-k))]

18
racket/src/cs/rumble/vector.ss
View File

@ -208,8 +208,8 @@
(let* ([o-next (impersonator-next o)] (let* ([o-next (impersonator-next o)]
[val (loop o-next)] [val (loop o-next)]
[new-val (if (vector*-chaperone? o) [new-val (if (vector*-chaperone? o)
((vector-chaperone-ref o) orig o-next idx val) (|#%app| (vector-chaperone-ref o) orig o-next idx val)
((vector-chaperone-ref o) o-next idx val))]) (|#%app| (vector-chaperone-ref o) o-next idx val))])
(unless (chaperone-of? new-val val) (unless (chaperone-of? new-val val)
(raise-arguments-error 'vector-ref (raise-arguments-error 'vector-ref
"chaperone produced a result that is not a chaperone of the original result" "chaperone produced a result that is not a chaperone of the original result"
@ -220,8 +220,8 @@
(let* ([o-next (impersonator-next o)] (let* ([o-next (impersonator-next o)]
[val (loop o-next)]) [val (loop o-next)])
(if (vector*-impersonator? o) (if (vector*-impersonator? o)
((vector-impersonator-ref o) orig o-next idx val) (|#%app| (vector-impersonator-ref o) orig o-next idx val)
((vector-impersonator-ref o) o-next idx val)))] (|#%app| (vector-impersonator-ref o) o-next idx val)))]
[(vector-unsafe-impersonator? o) [(vector-unsafe-impersonator? o)
(vector-ref (vector-unsafe-impersonator-vec o) idx)] (vector-ref (vector-unsafe-impersonator-vec o) idx)]
[(vector-unsafe-chaperone? o) [(vector-unsafe-chaperone? o)
@ -267,19 +267,19 @@
(cond (cond
[(vector-chaperone? o) [(vector-chaperone? o)
(let ([new-val (if (vector*-chaperone? o) (let ([new-val (if (vector*-chaperone? o)
((vector-chaperone-set o) orig next idx val) (|#%app| (vector-chaperone-set o) orig next idx val)
((vector-chaperone-set o) next idx val))]) (|#%app| (vector-chaperone-set o) next idx val))])
(unless (chaperone-of? new-val val) (unless (chaperone-of? new-val val)
(raise-arguments-error 'vector-set! (raise-arguments-error 'vector-set!
"chaperone produced a result that is not a chaperone of the original result" "chaperone produced a result that is not a chaperone of the original result"
"chaperone result" new-val "chaperone result" new-val
"original result" val)) "original result" val))
(loop next val))] (loop next new-val))]
[(vector-impersonator? o) [(vector-impersonator? o)
(loop next (loop next
(if (vector*-impersonator? o) (if (vector*-impersonator? o)
((vector-impersonator-set o) orig next idx val) (|#%app| (vector-impersonator-set o) orig next idx val)
((vector-impersonator-set o) next idx val)))] (|#%app| (vector-impersonator-set o) next idx val)))]
[(vector-unsafe-impersonator? o) [(vector-unsafe-impersonator? o)
(#2%vector-set! (vector-unsafe-impersonator-vec o) idx val)] (#2%vector-set! (vector-unsafe-impersonator-vec o) idx val)]
[(vector-unsafe-chaperone? o) [(vector-unsafe-chaperone? o)