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

{chaperone,impersonate}-struct: allow structure type as a witness

Browse Source 
Also, do not allow `struct-type` as a wrapped operation in
`chaperone-stuct` without a witness.

Related to PR 14970
This commit is contained in:
Matthew Flatt 2015-02-08 06:46:34 -07:00
parent 8e8c9842fa
commit 2ada651dd3
4 changed files with 77 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -253,6 +253,7 @@ that are overridden by further impersonators, for example.
@defproc[(impersonate-struct [v any/c]
[struct-type struct-type? _unspecified]
[orig-proc (or/c struct-accessor-procedure?
struct-mutator-procedure?
struct-type-property-accessor-procedure?)]
@ -264,7 +265,10 @@ that are overridden by further impersonators, for example.
Returns an impersonator of @racket[v], which redirects certain
operations on the impersonated value. The @racket[orig-proc]s
indicate the operations to redirect, and the corresponding
@racket[redirect-proc]s supply the redirections.
@racket[redirect-proc]s supply the redirections. The optional
@racket[struct-type] argument, when provided, acts as a witness for
the representation of @racket[v], which must be an instance of
@racket[struct-type].
The protocol for a @racket[redirect-proc] depends on the corresponding
@racket[orig-proc], where @racket[_self] refers to the value to which
@ -306,7 +310,7 @@ 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
@racket[struct-type] and no @racket[orig-proc]s are supplied, then no @racket[prop]s must be
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.
@ -320,7 +324,9 @@ after @racket[redirect-proc] (in the case of a mutator).
@history[#:changed "6.1.1.2" @elem{Changed first argument to an
accessor or mutator
@racket[redirect-proc] from
@racket[v] to @racket[_self].}]}
@racket[v] to @racket[_self].}
#:changed "6.1.1.8" @elem{Added optional @racket[struct-type]
argument.}]}
@defproc[(impersonate-vector [vec (and/c vector? (not/c immutable?))]
@ -632,6 +638,7 @@ an extra argument as with @racket[impersonate-procedure*].
@defproc[(chaperone-struct [v any/c]
[struct-type struct-type? _unspecified]
[orig-proc (or/c struct-accessor-procedure?
struct-mutator-procedure?
struct-type-property-accessor-procedure?
@ -671,18 +678,24 @@ a @racket[orig-proc] is originally applied:
must return each values or a chaperone of each value. The
@racket[redirect-proc] is not called if @racket[struct-info]
would return @racket[#f] as its first argument. An
@racket[orig-proc] can be @racket[struct-info] only if some
other @racket[orig-proc] is supplied.}
@racket[orig-proc] can be @racket[struct-info] only if
@racket[struct-type] or some other @racket[orig-proc] is supplied.}
@item{Any accessor or mutator @racket[orig-proc] that is an
@tech{impersonator} must be specifically a @tech{chaperone}.}
]
Supplying a property accessor for @racket[orig-proc] enables
@racket[prop] arguments, the same as supplying an accessor, mutator,
or structure type.
@history[#:changed "6.1.1.2" @elem{Changed first argument to an
accessor or mutator
@racket[redirect-proc] from
@racket[v] to @racket[_self].}]}
@racket[v] to @racket[_self].}
#:changed "6.1.1.8" @elem{Added optional @racket[struct-type]
argument.}]}
@defproc[(chaperone-vector [vec vector?]

11
pkgs/racket-test-core/tests/racket/chaperone.rktl
View File

@ -530,6 +530,12 @@
(define-struct p (u) #:property prop:green 'green)
(define-struct r (t) #:property prop:red 'red)
(define-struct (q p) (v w))
(define-struct specific ())
(test #t chaperone?/impersonator (chaperone-struct (specific) struct:specific prop:blue 'blue))
(test #t chaperone?/impersonator (chaperone-struct (specific)
(chaperone-struct-type struct:specific
values values values)
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)))
(test #t chaperone?/impersonator (chaperone-struct (make-b 1 2 3) a-x (lambda (a v) v)
@ -708,7 +714,10 @@
(test #t eq? p1 (chaperone-struct p1
p-u #f))
(test 0 p-u p2)
(test 'green green-ref p2)))))
(test 'green green-ref p2)))
(err/rt-test (chaperone-struct 10 struct-info void))
(err/rt-test (chaperone-struct 10 struct-info void prop:blue 'blue))))
;; test to see if the guard is actually called even when impersonated
(let ()

1
racket/collects/racket/contract/private/provide.rkt
View File

@ -924,6 +924,7 @@
(let ([struct-name
(λ (constructor-args ...)
(chaperone-struct (#,constructor-id constructor-args ...)
struct:struct-name
struct-info
(λ (struct-type skipped?)
(values -struct:struct-name skipped?))))])

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

@ -5829,7 +5829,7 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
const char *kind;
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, has_redirect = 0;
int empty_si_chaperone = 0, *empty_redirects = NULL, has_redirect = 0, witnessed = 0;
if (argc == 1) return argv[0];
@ -5852,14 +5852,33 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
else
inspector = NULL;
for (i = 1; i < argc; i++) {
i = 1;
if ((i < argc) && (SCHEME_STRUCT_TYPEP(argv[i])
|| (SCHEME_NP_CHAPERONEP(argv[i])
&& SCHEME_STRUCT_TYPEP(SCHEME_CHAPERONE_VAL(argv[i]))))) {
if (!SCHEME_STRUCTP(val) || !scheme_is_struct_instance((SCHEME_NP_CHAPERONEP(argv[i])
? SCHEME_CHAPERONE_VAL(argv[i])
: argv[i]),
val)) {
scheme_contract_error(name,
"given value is not an instance of the given structure type",
"struct type", 1, argv[i],
"value", 1, argv[0],
NULL);
return NULL;
}
i++;
witnessed = 1;
}
for (; i < argc; i++) {
proc = argv[i];
if ((i > 1) && SAME_TYPE(SCHEME_TYPE(proc), scheme_chaperone_property_type)) {
props = scheme_parse_chaperone_props(name, i, argc, argv);
break;
}
a[0] = proc;
if (SCHEME_CHAPERONEP(proc)) proc = SCHEME_CHAPERONE_VAL(proc);
@ -5869,21 +5888,29 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
offset = stype->num_slots;
else
offset = 0;
witnessed = 1;
} else if (SCHEME_TRUEP(struct_getter_p(1, a))) {
kind = "accessor";
offset = 0;
witnessed = 1;
} else if (SCHEME_TRUEP(struct_prop_getter_p(1, a))) {
kind = "struct-type property accessor";
offset = -1;
witnessed = 1;
} else if (!is_impersonator && SAME_OBJ(proc, struct_info_proc)) {
kind = "struct-info";
offset = -2;
} else {
scheme_wrong_contract(name,
"(or/c struct-accessor-procedure?\n"
" struct-mutator-procedure?\n"
" struct-type-property-accessor-procedure?\n"
" (one-of/c struct-info))",
#define CHAP_PROC_CONTRACT_STR(extra) \
("(or/c " extra "struct-accessor-procedure?\n" \
" struct-mutator-procedure?\n" \
" struct-type-property-accessor-procedure?\n" \
" (one-of/c struct-info))")
scheme_wrong_contract(name,
((i == 1)
? CHAP_PROC_CONTRACT_STR("struct-type?\n ")
: CHAP_PROC_CONTRACT_STR("")),
i, argc, argv);
return NULL;
}
@ -6075,6 +6102,18 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
if (!has_redirect && !props)
return argv[0];
if (!witnessed) {
scheme_contract_error(name,
(is_impersonator
? "cannot impersonate value as a structure without a witness"
: "cannot chaperone value as a structure without a witness"),
"explanation", 0, ("a structure type, accessor, or mutator acts as a witness\n"
" that the given value's representation can be chaperoned or impersonated"),
"given value", 1, argv[0],
NULL);
return NULL;
}
if (!redirects) {
/* a non-structure chaperone */