From 2ada651dd34c9f2402596e5e1b6433d483820a73 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 8 Feb 2015 06:46:34 -0700 Subject: [PATCH] {chaperone,impersonate}-struct: allow structure type as a witness Also, do not allow `struct-type` as a wrapped operation in `chaperone-stuct` without a witness. Related to PR 14970 --- .../scribblings/reference/chaperones.scrbl | 25 +++++++-- .../tests/racket/chaperone.rktl | 11 +++- .../racket/contract/private/provide.rkt | 1 + racket/src/racket/src/struct.c | 55 ++++++++++++++++--- 4 files changed, 77 insertions(+), 15 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/chaperones.scrbl b/pkgs/racket-doc/scribblings/reference/chaperones.scrbl index ee7e211154..e6949d25fc 100644 --- a/pkgs/racket-doc/scribblings/reference/chaperones.scrbl +++ b/pkgs/racket-doc/scribblings/reference/chaperones.scrbl @@ -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?] diff --git a/pkgs/racket-test-core/tests/racket/chaperone.rktl b/pkgs/racket-test-core/tests/racket/chaperone.rktl index bceaf6bef7..2bc3f7f143 100644 --- a/pkgs/racket-test-core/tests/racket/chaperone.rktl +++ b/pkgs/racket-test-core/tests/racket/chaperone.rktl @@ -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 () diff --git a/racket/collects/racket/contract/private/provide.rkt b/racket/collects/racket/contract/private/provide.rkt index 5356a64a9c..2d34f02996 100644 --- a/racket/collects/racket/contract/private/provide.rkt +++ b/racket/collects/racket/contract/private/provide.rkt @@ -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?))))]) diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index c0a249c59b..c418975c4c 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -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 */