diff --git a/collects/scribblings/reference/chaperones.scrbl b/collects/scribblings/reference/chaperones.scrbl index f404af7102..13fc9dae53 100644 --- a/collects/scribblings/reference/chaperones.scrbl +++ b/collects/scribblings/reference/chaperones.scrbl @@ -189,7 +189,10 @@ The protocol for a @racket[redirect-proc] depends on the corresponding @racket[_field-v] that @racket[orig-proc] produces for @racket[v]; it must return a replacement for @racket[_field-v]. The corresponding field must not be - immutable.} + immutable, and either the field's structure type must be + accessible via the current @tech{inspector} or one of the other + @racket[orig-proc]s must be a structure-field mutator for the + same field.} @item{A structure-field mutator: @racket[redirect-proc] must accept two arguments, @racket[v] and the value @racket[_field-v] diff --git a/collects/tests/racket/chaperone.rktl b/collects/tests/racket/chaperone.rktl index 890f1658f6..6ba6fcae97 100644 --- a/collects/tests/racket/chaperone.rktl +++ b/collects/tests/racket/chaperone.rktl @@ -414,12 +414,18 @@ (define-values (prop:green green? green-ref) (make-struct-type-property 'green 'can-impersonate)) (define-struct a ([x #:mutable] y)) (define-struct (b a) ([z #:mutable])) + (define-struct (c b) ([n #:mutable]) #:transparent) (define-struct p (u) #:property prop:green 'green) (define-struct (q p) (v w)) - (test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v))) - (test #t chaperone?/impersonator (chaperone-struct (make-b 1 2 3) a-x (lambda (a v) v))) + (test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v) + set-a-x! (lambda (a v) v))) + (test #t chaperone?/impersonator (chaperone-struct (make-b 1 2 3) a-x (lambda (a v) v) + set-a-x! (lambda (a v) v))) (test #t chaperone?/impersonator (chaperone-struct (make-p 1) green-ref (lambda (a v) v))) - (test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue)) + (test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v) + set-a-x! (lambda (a v) v) + prop:blue 'blue)) + (test #t chaperone?/impersonator (chaperone-struct (make-c 1 2 3 4) c-n (lambda (b v) v))) (when is-chaperone (test #t chaperone?/impersonator (chaperone-struct (chaperone-struct (make-a 1 2) a-x (lambda (a v) v) prop:blue 'blue) @@ -555,10 +561,11 @@ ([chaperone-procedure impersonate-procedure]) (let () (define (test-sub linear? rev?) - (define-struct a (x [y #:mutable]) #:property prop:procedure 0) + (define-struct a (x [y #:mutable]) #:property prop:procedure 0) (let* ([a1 (make-a (lambda (x) (list x x)) 10)] [get #f] - [a2 (chaperone-struct a1 a-y (lambda (a v) (set! get v) v))] + [a2 (chaperone-struct a1 a-y (lambda (a v) (set! get v) v) + set-a-y! (lambda (a v) v))] [pre #f] [post #f] [a3 (chaperone-procedure (if linear? a2 a1) @@ -569,7 +576,8 @@ r) z)))] [a2 (if rev? - (chaperone-struct a3 a-y (lambda (a v) (set! get v) v)) + (chaperone-struct a3 a-y (lambda (a v) (set! get v) v) + set-a-y! (lambda (a v) v)) a2)]) (test #t a? a1) (test #t a? a2) diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index d83d990d98..55038e204c 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -4,6 +4,9 @@ Added raise-argument-error, raise-result-error, raise-arguments-error, raise-range-error racket/contract: added procedure-arity-includes/c racket/sandbox: added sandbox-propagate-exceptions +Changed impersonate-struct so that accessor impersonation requires + work only if the field is accessible via the current impersonator + or a mutator for the same field is also impersonated Version 5.3.0.8 Required modules are instantiated in the order that they are required diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 9e87dbd608..45c366d9ee 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -5155,10 +5155,10 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, Scheme_Object *val = argv[0], *proc; Scheme_Object *redirects, *prop, *si_chaperone = scheme_false; Struct_Proc_Info *pi; - Scheme_Object *a[1]; + Scheme_Object *a[1], *inspector, *getter_positions = scheme_null; int i, offset, arity, non_applicable_op, repeat_op; const char *kind; - Scheme_Hash_Tree *props = NULL, *red_props = NULL; + Scheme_Hash_Tree *props = NULL, *red_props = NULL, *setter_positions = NULL; if (argc == 1) return argv[0]; @@ -5175,6 +5175,11 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, redirects = NULL; } + if (is_impersonator) + inspector = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR); + else + inspector = NULL; + for (i = 1; i < argc; i++) { proc = argv[i]; @@ -5254,16 +5259,33 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, repeat_op = 1; else { if (is_impersonator) { + intptr_t field_pos; + field_pos = pi->field - (pi->struct_type->name_pos + ? pi->struct_type->parent_types[pi->struct_type->name_pos - 1]->num_slots + : 0); /* Must not be an immutable field. */ if (stype->immutables) { - if (stype->immutables[pi->field - (pi->struct_type->name_pos - ? pi->struct_type->parent_types[pi->struct_type->name_pos - 1]->num_slots - : 0)]) + if (stype->immutables[field_pos]) scheme_contract_error(name, "cannot replace operation for an immutable field", "operation kind", 0, kind, "operation procedure", 1, a[0], - NULL); + NULL); + } + if (!offset) { + /* impersonating a getter is allowed only if the structure type is + transparent or if the setter is also impersonated (which would prove + that the code creating the impersonator has suitable access). */ + if (!scheme_inspector_sees_part(argv[0], inspector, pi->field)) { + getter_positions = scheme_make_pair(scheme_make_pair(scheme_make_integer(pi->field), a[0]), + getter_positions); + } + } else { + if (!scheme_inspector_sees_part(argv[0], inspector, pi->field)) { + if (!setter_positions) + setter_positions = scheme_make_hash_tree(0); + setter_positions = scheme_hash_tree_set(setter_positions, scheme_make_integer(pi->field), scheme_true); + } } } } @@ -5314,6 +5336,25 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, else si_chaperone = proc; } + + if (is_impersonator) { + /* For each getter for a non-transparent field, check that a witness + setter was provided */ + getter_positions = scheme_reverse(getter_positions); + while (!SCHEME_NULLP(getter_positions)) { + prop = SCHEME_CAR(getter_positions); + if (!setter_positions + || !scheme_hash_tree_get(setter_positions, SCHEME_CAR(prop))) { + scheme_contract_error(name, + "accessor redirection for a non-transparent field requires a mutator redirection", + "explanaion", 0, "a mutator redirection acts as a witness that access is allowed", + "accessor", 1, SCHEME_CDR(prop), + "value to impersonate", 1, argv[0], + NULL); + } + getter_positions = SCHEME_CDR(getter_positions); + } + } if (!redirects) { /* a non-structure chaperone */