From 90ac2790960313946fbb16bce39fcafc7af33be2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 8 Nov 2010 12:17:34 -0700 Subject: [PATCH] add 'can-impersonate option to `make-struct-type-property' --- .../scribblings/reference/chaperones.scrbl | 18 +++++++++---- collects/scribblings/reference/struct.scrbl | 8 +++++- collects/tests/racket/chaperone.rktl | 5 ++-- src/racket/src/schpriv.h | 2 +- src/racket/src/struct.c | 25 ++++++++++++++----- 5 files changed, 42 insertions(+), 16 deletions(-) diff --git a/collects/scribblings/reference/chaperones.scrbl b/collects/scribblings/reference/chaperones.scrbl index ee11a8f208..c01efe7531 100644 --- a/collects/scribblings/reference/chaperones.scrbl +++ b/collects/scribblings/reference/chaperones.scrbl @@ -167,7 +167,8 @@ of impersonators with respect to wrapping impersonators to be detected within @defproc[(impersonate-struct [v any/c] [orig-proc (or/c struct-accessor-procedure? - struct-mutator-procedure?)] + struct-mutator-procedure? + struct-type-property-accessor-procedure?)] [redirect-proc procedure?] ... ... [prop impersonator-property?] [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[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 @@ -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 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], @scheme[redirect-proc] must accept two arguments, @scheme[v] and the value @scheme[_field-v] supplied to the mutator; it must return a chaperone of @scheme[_field-v] to be propagated to @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 corresponding @scheme[redirect-proc] must accept two values, which are the results of @scheme[struct-info] on @scheme[v]; it diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl index 9aec50ac30..961077fa7a 100644 --- a/collects/scribblings/reference/struct.scrbl +++ b/collects/scribblings/reference/struct.scrbl @@ -288,7 +288,7 @@ A @deftech{structure type property} allows per-type information to be property value with a new value. @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? (any/c . -> . any/c))) 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 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 automatically associated with some structure type when the newly created property is associated to the structure type. Each property in diff --git a/collects/tests/racket/chaperone.rktl b/collects/tests/racket/chaperone.rktl index 11d632dca1..0e01326bfc 100644 --- a/collects/tests/racket/chaperone.rktl +++ b/collects/tests/racket/chaperone.rktl @@ -411,15 +411,14 @@ [chaperone?/impersonator impersonator?]) (let () (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 (b a) ([z #:mutable])) (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))) - (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)) (when is-chaperone (test #t chaperone?/impersonator (chaperone-struct diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 9045e6a25b..3073939415 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -648,7 +648,7 @@ typedef struct Scheme_Inspector { typedef struct Scheme_Struct_Property { Scheme_Object so; 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 ) */ } Scheme_Struct_Property; diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index e22113c18f..4f82cb1f5c 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -1024,7 +1024,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object * Scheme_Struct_Property *p; Scheme_Object *a[1], *v, *supers = scheme_null; char *name; - int len; + int len, can_impersonate = 0; const char *who; 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])) scheme_wrong_type(who, "symbol", 0, argc, argv); 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_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) { supers = argv[2]; @@ -1224,7 +1228,7 @@ static Scheme_Object *guard_property(Scheme_Object *prop, Scheme_Object *v, Sche return orig_v; } else { /* Normal guard handling: */ - if (p->guard) { + if (p->guard && !SCHEME_SYMBOLP(p->guard)) { if(!scheme_defining_primitives) { 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))) { kind = "accessor"; 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"; offset = -1; } 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]; 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, "%s: %s %V does not apply to given object: %V", name,