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

chaperones: allow struct chaperones that supply no redirections

Browse Source 
(as requested by Asumu)

A witness accessor or mutator is still required to create a structure
chaperone, but `#f` can be provided in place of a redirection, and
then impersonator properties can be attached to the chaperone.

At the same time, adjust `(chaperone-of? v1 v2)` so that `v1` as a
chaperone is not required to preserve non-redirecting chaperones of
`v2`.

The overall consequence is that a redirection procedure can cooperate
with a (suitably protected) impersonator property to override
redirection behavior without running afoul of the chaperone invariant
and without requiring O(N) space for O(N) overrides. For example, the
contract system can implement the re-application of a contract with
different blame information by overriding blame information as
represented by properties, instead of adding a new chaperone layer
every time that blame changes.

... and all the same for non-chaperone impersonators, of course.
This commit is contained in:
Matthew Flatt 2014-09-21 10:20:56 -05:00
parent 9681032783
commit 1f1a10db87
5 changed files with 152 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl
View File

@ -89,12 +89,43 @@ impersonators to @racket[v2].
For values that include no impersonators, @racket[v1] and @racket[v2] can
be considered impersonators of each other if they are @racket[equal?].
Otherwise, all impersonators of @racket[v2] must be intact in @racket[v1],
in the sense that parts of @racket[v2] must be derived from
@racket[v1] through one of the impersonator constructors (e.g.,
@racket[impersonate-procedure] or @racket[chaperone-procedure]).
Otherwise, impersonators within @racket[v2] must be intact within
@racket[v1]:
See also @racket[prop:impersonator-of].}
@itemlist[
@item{If a part of @racket[v2] is an impersonator created from one of
the impersonator constructors (e.g.,
@racket[impersonate-procedure] or
@racket[chaperone-procedure]), and if the impersonator is
constructed with at least one redirection procedure (i.e., a
value other than @racket[#f] was supplied for a redirection
procedure), then the corresponding part of @racket[v1] must be
one of the following:
@itemlist[
@item{the same value that is a part of @racket[v2];}
@item{a value further derived from the part of @racket[v2]
value using an impersonator constructor; or}
@item{a value with the @racket[prop:impersonator-of] property
whose procedure produces an impersonator of the value
that is a part of @racket[v2].}
]}
@item{If a part of @racket[v2] is a structure impersonator that was
created with no redirection procedures (i.e, @racket[#f] in
place of all redirection procedures for specified operations),
then the impersonated value is considered in place of that part
of @racket[v2]. In other words, an impersonator construction
that does not redirect any access or mutation (but that
includes some @tech{impersonator properties}) need not be
preserved in @racket[v1].}
]}
@defproc[(chaperone-of? [v1 any/c] [v2 any/c]) boolean?]{
@ -107,10 +138,11 @@ be considered chaperones of each other if they are @racket[equal?],
except that the mutability of vectors and boxes with @racket[v1] and
@racket[v2] must be the same.
Otherwise, all chaperones of @racket[v2] must be intact in
@racket[v1], in the sense that parts of @racket[v2] must be derived
from @racket[v1] through one of the chaperone constructors (e.g.,
@racket[chaperone-procedure]).}
Otherwise, chaperones within @racket[v2] must be intact within
@racket[v1] analogous to way that @racket[impersonator-of?] requires
that impersonators are preserved, except that @racket[prop:impersonator-of]
has no analog for @racket[chaperone-of].}
@defproc[(impersonator-ephemeron [v any/c]) ephemeron?]{
@ -183,7 +215,7 @@ of impersonators with respect to wrapping impersonators to be detected within
[orig-proc (or/c struct-accessor-procedure?
struct-mutator-procedure?
struct-type-property-accessor-procedure?)]
[redirect-proc procedure?] ... ...
[redirect-proc (or/c procedure? #f)] ... ...
[prop impersonator-property?]
[prop-val any] ... ...)
any/c]{
@ -221,13 +253,21 @@ The protocol for a @racket[redirect-proc] depends on the corresponding
]
When a @racket[redirect-proc] is @racket[#f], the corresponding
@racket[orig-proc] is unaffected. Supplying @racket[#f] for a
@racket[redirect-proc] is useful to allow its @racket[orig-proc] to
act as a ``witness'' of @racket[v]'s representation and enable the
addition of @racket[prop]s.
Pairs of @racket[prop] and @racket[prop-val] (the number of arguments
to @racket[impersonate-struct] must be odd) add impersonator properties
or override impersonator-property values of @racket[v].
Each @racket[orig-proc] must indicate a distinct operation. If no
@racket[orig-proc]s are supplied, then no @racket[prop]s must be
supplied, and @racket[v] is returned unimpersonated.
supplied. If @racket[orig-proc]s are supplied only with @racket[#f]
@racket[redirect-proc]s and no @racket[prop]s are supplied, then
@racket[v] is returned unimpersonated.
If any @racket[orig-proc] is itself an impersonator, then a use of the
accessor or mutator that @racket[orig-proc] impersonates is redirected
@ -536,7 +576,7 @@ order of the supplied arguments' keywords.}
struct-mutator-procedure?
struct-type-property-accessor-procedure?
(one-of/c struct-info))]
[redirect-proc procedure?] ... ...
[redirect-proc (or/c procedure? #f)] ... ...
[prop impersonator-property?]
[prop-val any] ... ...)
any/c]{

26
pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl
View File

@ -1449,6 +1449,8 @@
;; ----------------------------------------
(let ()
(define-values (prop:blue blue? blue-ref) (make-impersonator-property 'blue))
(define-values (prop:green green? green-ref) (make-struct-type-property 'green 'can-impersonate))
(define (a-impersonator-of v) (a-x v))
(define a-equal+hash (list
(lambda (v1 v2 equal?)
@ -1459,7 +1461,8 @@
(hash (aa-y v2)))))
(define (aa-y v) (if (a? v) (a-y v) (pre-a-y v)))
(define-struct pre-a (x y)
#:property prop:equal+hash a-equal+hash)
#:property prop:equal+hash a-equal+hash
#:property prop:green 'color)
(define-struct a (x y)
#:property prop:impersonator-of a-impersonator-of
#:property prop:equal+hash a-equal+hash)
@ -1492,6 +1495,27 @@
(err/rt-test (impersonator-of? (make-a-new-impersonator a1 1) a1))
(err/rt-test (impersonator-of? (make-a-new-equal a1 1) a1))
(err/rt-test (equal? (make-a-new-equal a1 1) a1))
(define a-pre-a (chaperone-struct (make-pre-a 17 1) pre-a-y (lambda (a v) v)))
(test 1 pre-a-y a-pre-a)
(test #t chaperone-of? a-pre-a a-pre-a)
(test #t chaperone-of? (make-pre-a 17 1) (chaperone-struct (make-pre-a 17 1) pre-a-y #f prop:blue 'color))
(test #f chaperone-of? (make-pre-a 17 1) (chaperone-struct a-pre-a pre-a-y #f prop:blue 'color))
(test #t chaperone-of? a-pre-a (chaperone-struct a-pre-a pre-a-y #f prop:blue 'color))
(test #t chaperone-of? (chaperone-struct a-pre-a pre-a-y #f prop:blue 'color) a-pre-a)
(test #f chaperone-of? a-pre-a (chaperone-struct a-pre-a pre-a-y (lambda (a v) v) prop:blue 'color))
(test #f chaperone-of? a-pre-a (chaperone-struct a-pre-a green-ref (lambda (a v) v)))
(define (exn:second-time? e) (and (exn? e) (regexp-match? #rx"same value as" (exn-message e))))
(err/rt-test (chaperone-struct (make-pre-a 1 2) pre-a-y #f pre-a-y #f) exn:second-time?)
(err/rt-test (chaperone-struct (make-pre-a 1 2) pre-a-y (lambda (a v) v) pre-a-y #f) exn:second-time?)
(err/rt-test (chaperone-struct (make-pre-a 1 2) pre-a-y #f pre-a-y (lambda (a v) v)) exn:second-time?)
(eq? a-pre-a (chaperone-struct a-pre-a pre-a-y #f))
(eq? a-pre-a (chaperone-struct a-pre-a green-ref #f))
(test #t impersonator-of? (make-pre-a 17 1) (chaperone-struct (make-pre-a 17 1) pre-a-y #f prop:blue 'color))
(test #f impersonator-of? (make-pre-a 17 1) (chaperone-struct a-pre-a pre-a-y #f prop:blue 'color))
(void)))
;; ----------------------------------------

7
racket/src/racket/src/bool.c
View File

@ -564,6 +564,13 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
if (cmp > -1)
return cmp;
if (eql->for_chaperone
&& SCHEME_CHAPERONEP(obj2)
&& scheme_is_noninterposing_chaperone(obj2)) {
obj2 = ((Scheme_Chaperone *)obj2)->prev;
goto top_after_next;
}
if (eql->for_chaperone
&& SCHEME_CHAPERONEP(obj1)
&& (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR)

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

@ -1023,6 +1023,8 @@ void scheme_chaperone_hash_set(Scheme_Object *table, Scheme_Object *key, Scheme_
Scheme_Object *scheme_chaperone_not_undefined(Scheme_Object *orig_val);
int scheme_is_noninterposing_chaperone(Scheme_Object *obj);
/*========================================================================*/
/* syntax objects */
/*========================================================================*/

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

@ -2197,9 +2197,9 @@ static void chaperone_struct_set(const char *who, Scheme_Object *prim,
return;
}
}
} if (SCHEME_VECTORP(px->redirects)
&& !(SCHEME_VEC_SIZE(px->redirects) & 1)
&& SAME_OBJ(SCHEME_VEC_ELS(px->redirects)[1], scheme_undefined)) {
} else if (SCHEME_VECTORP(px->redirects)
&& !(SCHEME_VEC_SIZE(px->redirects) & 1)
&& SAME_OBJ(SCHEME_VEC_ELS(px->redirects)[1], scheme_undefined)) {
/* chaperone on every field: check that current value is not undefined
--- unless check is disabled by a mark (bit it's faster to check
for `undefined` before checking the mark) */
@ -2226,6 +2226,31 @@ void scheme_struct_set(Scheme_Object *sv, int pos, Scheme_Object *v)
}
}
int scheme_is_noninterposing_chaperone(Scheme_Object *o)
/* Checks whether the immediate impersonator layer for `o` is known to
interpose on no operations (i.e., it's for impersonator properties,
only) */
{
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
int i;
if (!SCHEME_VECTORP(px->redirects))
return 0;
if (SCHEME_VEC_SIZE(px->redirects) & 1)
return 0;
if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0]))
return 0;
for (i = SCHEME_VEC_SIZE(px->redirects); i-- > PRE_REDIRECTS; ) {
if (!SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[i]))
return 0;
}
return 1;
}
static Scheme_Object **apply_guards(Scheme_Struct_Type *stype, int argc, Scheme_Object **args,
int *_chaperone_undefined)
{
@ -5714,8 +5739,9 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
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, *setter_positions = NULL;
Scheme_Hash_Tree *props = NULL, *red_props = NULL, *empty_red_props = NULL, *setter_positions = NULL;
intptr_t field_pos;
int empty_si_chaperone = 0, *empty_redirects = NULL;
if (argc == 1) return argv[0];
@ -5778,7 +5804,7 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
repeat_op = 0;
if (offset == -2) {
if (SCHEME_TRUEP(si_chaperone))
if (SCHEME_TRUEP(si_chaperone) || empty_si_chaperone)
scheme_contract_error(name,
"struct-info procedure supplied a second time",
"procedure", 1, a[0],
@ -5804,10 +5830,9 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
non_applicable_op = 1;
arity = 0;
} else {
if (!red_props)
red_props = scheme_make_hash_tree(0);
if (scheme_hash_tree_get(red_props, prop))
if (red_props && scheme_hash_tree_get(red_props, prop))
repeat_op = 1;
if (empty_red_props && scheme_hash_tree_get(empty_red_props, prop))
repeat_op = 1;
arity = 2;
@ -5821,6 +5846,8 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
non_applicable_op = 1;
else if (SCHEME_TRUEP(SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos]))
repeat_op = 1;
else if (empty_redirects && empty_redirects[offset + field_pos])
repeat_op = 1;
else {
if (is_impersonator) {
intptr_t loc_field_pos;
@ -5881,9 +5908,10 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
NULL);
proc = argv[i];
if (!scheme_check_proc_arity(NULL, arity, i, argc, argv)) {
char buf[32];
sprintf(buf, "(procedure-arity-includes/c %d)", arity);
if (SCHEME_TRUEP(proc)
&& !scheme_check_proc_arity(NULL, arity, i, argc, argv)) {
char buf[64];
sprintf(buf, "(or/c (procedure-arity-includes/c %d) #f)", arity);
scheme_contract_error(name,
"operation's redirection procedure does not match the expected arity",
"given", 1, proc,
@ -5894,8 +5922,8 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
}
/* If the operation to chaperone was itself a chaperone, we need to
preserve and use he chaperoned variant of the operation. */
if (SCHEME_CHAPERONEP(a[0])) {
preserve and use the chaperoned variant of the operation. */
if (SCHEME_CHAPERONEP(a[0]) && SCHEME_TRUEP(proc)) {
Scheme_Chaperone *ppx = (Scheme_Chaperone *)a[0];
if (!is_impersonator
&& (SCHEME_CHAPERONE_FLAGS(ppx) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
@ -5907,12 +5935,30 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
proc = scheme_make_pair(a[0], proc);
}
if (prop)
red_props = scheme_hash_tree_set(red_props, prop, proc);
else if (st)
SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos] = proc;
else
si_chaperone = proc;
if (prop) {
if (SCHEME_TRUEP(prop)) {
if (!red_props)
red_props = scheme_make_hash_tree(0);
red_props = scheme_hash_tree_set(red_props, prop, proc);
} else {
if (!empty_red_props)
empty_red_props = scheme_make_hash_tree(0);
empty_red_props = scheme_hash_tree_set(empty_red_props, prop, proc);
}
} else if (st) {
if (SCHEME_TRUEP(proc))
SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos] = proc;
else {
if (!empty_redirects)
empty_redirects = MALLOC_N_ATOMIC(int, 2 * stype->num_slots);
empty_redirects[offset + field_pos] = 1;
}
} else {
if (SCHEME_TRUEP(proc))
si_chaperone = proc;
else
empty_si_chaperone = 1;
}
}
if (is_impersonator) {