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

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

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/scribblings/reference/chaperones.scrbl
View File

@ -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

8
collects/scribblings/reference/struct.scrbl
View File

@ -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

5
collects/tests/racket/chaperone.rktl
View File

@ -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

2
src/racket/src/schpriv.h
View File

@ -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 <prop> <proc>) */
} Scheme_Struct_Property;

25
src/racket/src/struct.c
View File

@ -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,