add 'can-impersonate option to `make-struct-type-property'

This commit is contained in:
Matthew Flatt 2010-11-08 12:17:34 -07:00
parent 0237050ae0
commit 90ac279096
5 changed files with 42 additions and 16 deletions

View File

@ -167,7 +167,8 @@ of impersonators with respect to wrapping impersonators to be detected within
@defproc[(impersonate-struct [v any/c] @defproc[(impersonate-struct [v any/c]
[orig-proc (or/c struct-accessor-procedure? [orig-proc (or/c struct-accessor-procedure?
struct-mutator-procedure?)] struct-mutator-procedure?
struct-type-property-accessor-procedure?)]
[redirect-proc procedure?] ... ... [redirect-proc procedure?] ... ...
[prop impersonator-property?] [prop impersonator-property?]
[prop-val any] ... ...) [prop-val any] ... ...)
@ -196,6 +197,11 @@ The protocol for a @scheme[redirect-proc] depends on the corresponding
@scheme[_field-v] to be propagated to @scheme[orig-proc] and @scheme[_field-v] to be propagated to @scheme[orig-proc] and
@scheme[v].} @scheme[v].}
@item{A property accessor: @racket[redirect-proc] uses the same
protocol as for a structure-field accessor. The accessor's
property must have been created with @racket['can-impersonate]
as the second argument to @racket[make-struct-type-property].}
] ]
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
@ -378,16 +384,18 @@ Like @racket[impersonate-struct], but with the following refinements:
@scheme[v]; it must return a chaperone of @scheme[_field-v]. The @scheme[v]; it must return a chaperone of @scheme[_field-v]. The
corresponding field may be immutable.} corresponding field may be immutable.}
@item{A property accessor can be supplied as @racket[orig-proc]. The
corresponding @racket[redirect-proc] uses the same protocol as
for a structure-field selector.}
@item{With structure-field mutator as @racket[orig-proc], @item{With structure-field mutator as @racket[orig-proc],
@scheme[redirect-proc] must accept two arguments, @scheme[v] and @scheme[redirect-proc] must accept two arguments, @scheme[v] and
the value @scheme[_field-v] supplied to the mutator; it must the value @scheme[_field-v] supplied to the mutator; it must
return a chaperone of @scheme[_field-v] to be propagated to return a chaperone of @scheme[_field-v] to be propagated to
@scheme[orig-proc] and @scheme[v].} @scheme[orig-proc] and @scheme[v].}
@item{A property accessor can be supplied as @racket[orig-proc], and
the property need not have been created with
@racket['can-impersonate]. The corresponding
@racket[redirect-proc] uses the same protocol as for a
structure-field accessor.}
@item{With @scheme[struct-info] as @racket[orig-proc], the @item{With @scheme[struct-info] as @racket[orig-proc], the
corresponding @scheme[redirect-proc] must accept two values, corresponding @scheme[redirect-proc] must accept two values,
which are the results of @scheme[struct-info] on @scheme[v]; it which are the results of @scheme[struct-info] on @scheme[v]; it

View File

@ -288,7 +288,7 @@ A @deftech{structure type property} allows per-type information to be
property value with a new value. property value with a new value.
@defproc[(make-struct-type-property [name symbol?] @defproc[(make-struct-type-property [name symbol?]
[guard (or/c procedure? #f) #f] [guard (or/c procedure? #f 'can-impersonate) #f]
[supers (listof (cons/c struct-type-property? [supers (listof (cons/c struct-type-property?
(any/c . -> . any/c))) (any/c . -> . any/c)))
null]) null])
@ -334,6 +334,12 @@ inappropriate for the property), the @racket[guard] can raise an
exception. Such an exception prevents @racket[make-struct-type] from exception. Such an exception prevents @racket[make-struct-type] from
returning a structure type descriptor. returning a structure type descriptor.
If @racket[guard] is @racket['can-impersonate], then the property's
accessor can be redirected through
@racket[impersonate-struct]. Otherwise, redirection of the property
value through an @tech{impersonator} is disallowed, since redirection
is tantamount to mutation.
The optional @racket[supers] argument is a list of properties that are The optional @racket[supers] argument is a list of properties that are
automatically associated with some structure type when the newly automatically associated with some structure type when the newly
created property is associated to the structure type. Each property in created property is associated to the structure type. Each property in

View File

@ -411,15 +411,14 @@
[chaperone?/impersonator impersonator?]) [chaperone?/impersonator impersonator?])
(let () (let ()
(define-values (prop:blue blue? blue-ref) (make-impersonator-property 'blue)) (define-values (prop:blue blue? blue-ref) (make-impersonator-property 'blue))
(define-values (prop:green green? green-ref) (make-struct-type-property 'green)) (define-values (prop:green green? green-ref) (make-struct-type-property 'green 'can-impersonate))
(define-struct a ([x #:mutable] y)) (define-struct a ([x #:mutable] y))
(define-struct (b a) ([z #:mutable])) (define-struct (b a) ([z #:mutable]))
(define-struct p (u) #:property prop:green 'green) (define-struct p (u) #:property prop:green 'green)
(define-struct (q p) (v w)) (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-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-b 1 2 3) a-x (lambda (a v) v)))
(when is-chaperone (test #t chaperone?/impersonator (chaperone-struct (make-p 1) green-ref (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) prop:blue 'blue))
(when is-chaperone (when is-chaperone
(test #t chaperone?/impersonator (chaperone-struct (test #t chaperone?/impersonator (chaperone-struct

View File

@ -648,7 +648,7 @@ typedef struct Scheme_Inspector {
typedef struct Scheme_Struct_Property { typedef struct Scheme_Struct_Property {
Scheme_Object so; Scheme_Object so;
Scheme_Object *name; /* a symbol */ Scheme_Object *name; /* a symbol */
Scheme_Object *guard; /* NULL or a procedure */ Scheme_Object *guard; /* NULL, a procedure, or 'can-impersonate */
Scheme_Object *supers; /* implied properties: listof (cons <prop> <proc>) */ Scheme_Object *supers; /* implied properties: listof (cons <prop> <proc>) */
} Scheme_Struct_Property; } Scheme_Struct_Property;

View File

@ -1024,7 +1024,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *
Scheme_Struct_Property *p; Scheme_Struct_Property *p;
Scheme_Object *a[1], *v, *supers = scheme_null; Scheme_Object *a[1], *v, *supers = scheme_null;
char *name; char *name;
int len; int len, can_impersonate = 0;
const char *who; const char *who;
if (type == scheme_struct_property_type) if (type == scheme_struct_property_type)
@ -1035,9 +1035,13 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *
if (!SCHEME_SYMBOLP(argv[0])) if (!SCHEME_SYMBOLP(argv[0]))
scheme_wrong_type(who, "symbol", 0, argc, argv); scheme_wrong_type(who, "symbol", 0, argc, argv);
if (argc > 1) { if (argc > 1) {
if (SCHEME_TRUEP(argv[1]) if (SCHEME_SYMBOLP(argv[1])
&& !SCHEME_SYM_WEIRDP(argv[1])
&& !strcmp("can-impersonate", SCHEME_SYM_VAL(argv[1])))
can_impersonate = 1;
else if (SCHEME_TRUEP(argv[1])
&& !scheme_check_proc_arity(NULL, 2, 1, argc, argv)) && !scheme_check_proc_arity(NULL, 2, 1, argc, argv))
scheme_wrong_type(who, "procedure (arity 2) or #f", 1, argc, argv); scheme_wrong_type(who, "procedure (arity 2), #f, or 'can-impersonate", 1, argc, argv);
if (argc > 2) { if (argc > 2) {
supers = argv[2]; supers = argv[2];
@ -1224,7 +1228,7 @@ static Scheme_Object *guard_property(Scheme_Object *prop, Scheme_Object *v, Sche
return orig_v; return orig_v;
} else { } else {
/* Normal guard handling: */ /* Normal guard handling: */
if (p->guard) { if (p->guard && !SCHEME_SYMBOLP(p->guard)) {
if(!scheme_defining_primitives) { if(!scheme_defining_primitives) {
Scheme_Object *a[2], *info[mzNUM_ST_INFO], *l; Scheme_Object *a[2], *info[mzNUM_ST_INFO], *l;
@ -5166,7 +5170,7 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
} else if (SCHEME_TRUEP(struct_getter_p(1, a))) { } else if (SCHEME_TRUEP(struct_getter_p(1, a))) {
kind = "accessor"; kind = "accessor";
offset = 0; offset = 0;
} else if (!is_impersonator && SCHEME_TRUEP(struct_prop_getter_p(1, a))) { } else if (SCHEME_TRUEP(struct_prop_getter_p(1, a))) {
kind = "struct-type property accessor"; kind = "struct-type property accessor";
offset = -1; offset = -1;
} else if (!is_impersonator && SAME_OBJ(proc, struct_info_proc)) { } else if (!is_impersonator && SAME_OBJ(proc, struct_info_proc)) {
@ -5194,7 +5198,16 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
prop = SCHEME_PRIM_CLOSURE_ELS(proc)[0]; prop = SCHEME_PRIM_CLOSURE_ELS(proc)[0];
pi = NULL; pi = NULL;
if (!scheme_chaperone_struct_type_property_ref(prop, argv[0])) if (is_impersonator
&& (!((Scheme_Struct_Property *)prop)->guard
|| !SCHEME_SYMBOLP(((Scheme_Struct_Property *)prop)->guard)))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: %s cannot be impersonated: %V",
name,
kind,
a[0]);
if (!scheme_struct_type_property_ref(prop, argv[0]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT, scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: %s %V does not apply to given object: %V", "%s: %s %V does not apply to given object: %V",
name, name,