From b268f77ae9cf7d922ec7c9609e493300bdb526ad Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 20 May 2019 14:22:59 -0600 Subject: [PATCH] cs: fix `vector-set!` and `set-box!` impersonation Use the result from an interposition to install into the vector or box, instead of the original value. --- .../tests/racket/chaperone.rktl | 44 +++++++++++++++++++ racket/src/cs/rumble/box.ss | 6 +-- racket/src/cs/rumble/hash.ss | 18 ++++---- racket/src/cs/rumble/vector.ss | 18 ++++---- 4 files changed, 65 insertions(+), 21 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/chaperone.rktl b/pkgs/racket-test-core/tests/racket/chaperone.rktl index 46ca4821d5..7b1e6d5c90 100644 --- a/pkgs/racket-test-core/tests/racket/chaperone.rktl +++ b/pkgs/racket-test-core/tests/racket/chaperone.rktl @@ -149,6 +149,28 @@ (test #f unbox b) (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))) @@ -217,6 +239,28 @@ (test #f vector-ref b2 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: (let ([b (vector 0)]) (let ([b2 (impersonate-vector b diff --git a/racket/src/cs/rumble/box.ss b/racket/src/cs/rumble/box.ss index 9cb3a0055b..ba6b8a4d4e 100644 --- a/racket/src/cs/rumble/box.ss +++ b/racket/src/cs/rumble/box.ss @@ -91,7 +91,7 @@ [(#%box? o) (#%unbox o)] [(box-chaperone? 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) (raise-arguments-error 'unbox "chaperone produced a result that is not a chaperone of the original result" @@ -120,13 +120,13 @@ (let ([next (impersonator-next o)]) (cond [(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) (raise-arguments-error 'set-box! "chaperone produced a result that is not a chaperone of the original result" "chaperone result" new-val "original result" val)) - (loop next val))] + (loop next new-val))] [(box-impersonator? o) (loop next ((box-impersonator-set o) next val))] [else (loop next val)]))]))]))) diff --git a/racket/src/cs/rumble/hash.ss b/racket/src/cs/rumble/hash.ss index 6c32dde976..743056184f 100644 --- a/racket/src/cs/rumble/hash.ss +++ b/racket/src/cs/rumble/hash.ss @@ -1064,7 +1064,7 @@ (impersonate-hash-ref/set 'hash-ref #f (lambda (ht k v) (hash-ref ht k none)) (lambda (procs ht k none-v) - ((hash-procs-ref procs) ht k)) + (|#%app| (hash-procs-ref procs) ht k)) hash-procs-ref ht k none)) @@ -1072,7 +1072,7 @@ (impersonate-hash-ref/set 'hash-set! #t hash-set! (lambda (procs ht k v) - ((hash-procs-set procs) ht k v)) + (|#%app| (hash-procs-set procs) ht k v)) hash-procs-set ht k v)) @@ -1080,7 +1080,7 @@ (impersonate-hash-ref/set 'hash-set #t hash-set (lambda (procs ht k v) - ((hash-procs-set procs) ht k v)) + (|#%app| (hash-procs-set procs) ht k v)) hash-procs-set ht k v)) @@ -1088,7 +1088,7 @@ (impersonate-hash-ref/set 'hash-remove! #t (lambda (ht k false-v) (hash-remove! ht k)) (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 ht k #f)) @@ -1096,7 +1096,7 @@ (impersonate-hash-ref/set 'hash-remove #t (lambda (ht k false-v) (hash-remove ht k)) (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 ht k #f)) @@ -1172,7 +1172,7 @@ (define (extend-get-k who get-k procs next-ht chaperone?) (lambda (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)) (raise-chaperone-error who "key" new-k k)) new-k))) @@ -1189,7 +1189,7 @@ (let ([clear (hash-procs-clear procs)]) (cond [clear - (clear next-ht) + (|#%app| clear next-ht) (if mutable? (loop next-ht) (let ([r (loop next-ht)]) @@ -1268,12 +1268,12 @@ [(hash-impersonator? ht) (let ([procs (hash-impersonator-procs ht)] [ht (impersonator-next ht)]) - ((hash-procs-key procs) ht (loop ht)))] + (|#%app| (hash-procs-key procs) ht (loop ht)))] [(hash-chaperone? ht) (let ([procs (hash-chaperone-procs ht)] [ht (impersonator-next 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) (raise-chaperone-error who "key" new-k k)) new-k))] diff --git a/racket/src/cs/rumble/vector.ss b/racket/src/cs/rumble/vector.ss index 02330c8574..2a324b3252 100644 --- a/racket/src/cs/rumble/vector.ss +++ b/racket/src/cs/rumble/vector.ss @@ -208,8 +208,8 @@ (let* ([o-next (impersonator-next o)] [val (loop o-next)] [new-val (if (vector*-chaperone? o) - ((vector-chaperone-ref o) orig o-next idx val) - ((vector-chaperone-ref o) o-next idx val))]) + (|#%app| (vector-chaperone-ref o) orig o-next idx val) + (|#%app| (vector-chaperone-ref o) o-next idx val))]) (unless (chaperone-of? new-val val) (raise-arguments-error 'vector-ref "chaperone produced a result that is not a chaperone of the original result" @@ -220,8 +220,8 @@ (let* ([o-next (impersonator-next o)] [val (loop o-next)]) (if (vector*-impersonator? o) - ((vector-impersonator-ref o) orig o-next idx val) - ((vector-impersonator-ref o) o-next idx val)))] + (|#%app| (vector-impersonator-ref o) orig o-next idx val) + (|#%app| (vector-impersonator-ref o) o-next idx val)))] [(vector-unsafe-impersonator? o) (vector-ref (vector-unsafe-impersonator-vec o) idx)] [(vector-unsafe-chaperone? o) @@ -267,19 +267,19 @@ (cond [(vector-chaperone? o) (let ([new-val (if (vector*-chaperone? o) - ((vector-chaperone-set o) orig next idx val) - ((vector-chaperone-set o) next idx val))]) + (|#%app| (vector-chaperone-set o) orig next idx val) + (|#%app| (vector-chaperone-set o) next idx val))]) (unless (chaperone-of? new-val val) (raise-arguments-error 'vector-set! "chaperone produced a result that is not a chaperone of the original result" "chaperone result" new-val "original result" val)) - (loop next val))] + (loop next new-val))] [(vector-impersonator? o) (loop next (if (vector*-impersonator? o) - ((vector-impersonator-set o) orig next idx val) - ((vector-impersonator-set o) next idx val)))] + (|#%app| (vector-impersonator-set o) orig next idx val) + (|#%app| (vector-impersonator-set o) next idx val)))] [(vector-unsafe-impersonator? o) (#2%vector-set! (vector-unsafe-impersonator-vec o) idx val)] [(vector-unsafe-chaperone? o)