From e14c5d61e95b867a95c820adec6c5b9e5f1ff9dc Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Thu, 19 Jul 2012 16:15:55 -0400 Subject: [PATCH] Allow guards for impersonatable struct type properties --- collects/racket/private/promise.rkt | 2 +- collects/scribblings/reference/struct.scrbl | 15 +++++++++++---- collects/tests/racket/chaperone.rktl | 12 ++++++++++++ collects/tests/racket/struct.rktl | 4 ++-- collects/typed-racket/base-env/base-env.rkt | 3 ++- src/racket/src/schpriv.h | 1 + src/racket/src/struct.c | 13 +++++++++---- 7 files changed, 38 insertions(+), 12 deletions(-) diff --git a/collects/racket/private/promise.rkt b/collects/racket/private/promise.rkt index 4ba6c01283..05391b2f00 100644 --- a/collects/racket/private/promise.rkt +++ b/collects/racket/private/promise.rkt @@ -147,7 +147,7 @@ ;; property value for the right forcer to use (define-values [prop:force promise-forcer] (let-values ([(prop pred? get) ; no need for the predicate - (make-struct-type-property 'forcer 'can-impersonate)]) + (make-struct-type-property 'forcer #f null #t)]) (values prop get))) ;; A promise value can hold diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl index 8289c08ba0..82954a27c7 100644 --- a/collects/scribblings/reference/struct.scrbl +++ b/collects/scribblings/reference/struct.scrbl @@ -304,7 +304,8 @@ A @deftech{structure type property} allows per-type information to be [guard (or/c procedure? #f 'can-impersonate) #f] [supers (listof (cons/c struct-type-property? (any/c . -> . any/c))) - null]) + null] + [can-impersonate? any/c #f]) (values struct-type-property? procedure? procedure?)]{ @@ -355,9 +356,9 @@ 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. +@racket[impersonate-struct]. This option is identical to supplying +@racket[#t] as the @racket[can-impersonate?] argument and is provided +for backwards compatibility. The optional @racket[supers] argument is a list of properties that are automatically associated with some structure type when the newly @@ -367,6 +368,12 @@ supplied for the new property (after it is processed by @racket[guard]) and returns a value for the associated property (which is then sent to that property's guard, of any). +The optional @racket[can-impersonate?] argument determines if the +structure type property can be redirected through @racket[impersonate-struct]. +If the argument is @racket[#f], then redirection is not allowed. +Otherwise, the property accessor may be redirected by a struct +impersonator. + @examples[ #:eval struct-eval (define-values (prop:p p? p-ref) (make-struct-type-property 'p)) diff --git a/collects/tests/racket/chaperone.rktl b/collects/tests/racket/chaperone.rktl index 6ba6fcae97..0ea7fbfd45 100644 --- a/collects/tests/racket/chaperone.rktl +++ b/collects/tests/racket/chaperone.rktl @@ -412,16 +412,20 @@ (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-values (prop:red red? red-ref) + (make-struct-type-property 'red (lambda (v i) (symbol->string v)) null #t)) (define-struct a ([x #:mutable] y)) (define-struct (b a) ([z #:mutable])) (define-struct (c b) ([n #:mutable]) #:transparent) (define-struct p (u) #:property prop:green 'green) + (define-struct r (t) #:property prop:red 'red) (define-struct (q p) (v w)) (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) set-a-x! (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-r 1) red-ref (lambda (a v) v))) (test #t chaperone?/impersonator (chaperone-struct (make-a 1 2) a-x (lambda (a v) v) set-a-x! (lambda (a v) v) prop:blue 'blue)) @@ -553,6 +557,14 @@ (test 'bad a-x a2) (test 'bad a-x a3))))))) +;; test to see if the guard is actually called even when impersonated +(let () + (define-values (prop:red red? red-ref) + (make-struct-type-property 'red (lambda (v i) (symbol->string v)) null #t)) + (define-struct a (b) #:property prop:red 'red) + (test "red" red-ref (impersonate-struct (make-a 1) red-ref (lambda (v f-v) f-v))) + (test 5 red-ref (impersonate-struct (make-a 1) red-ref (lambda (v f-v) 5)))) + ;; ---------------------------------------- (as-chaperone-or-impersonator diff --git a/collects/tests/racket/struct.rktl b/collects/tests/racket/struct.rktl index 252cb0da53..43114766da 100644 --- a/collects/tests/racket/struct.rktl +++ b/collects/tests/racket/struct.rktl @@ -7,7 +7,7 @@ [(prop:p2 p2? p2-ref) (make-struct-type-property 'prop2)] [(insp1) (make-inspector)] [(insp2) (make-inspector)]) - (arity-test make-struct-type-property 1 3) + (arity-test make-struct-type-property 1 4) (test 3 primitive-result-arity make-struct-type-property) (arity-test p? 1 1) (arity-test p-ref 1 2) @@ -638,7 +638,7 @@ ;; ------------------------------------------------------------ ;; Property accessor errors -(let-values ([(prop:p p? p-ref) (make-struct-type-property 'prop1 'can-impersonate '())]) +(let-values ([(prop:p p? p-ref) (make-struct-type-property 'prop1 #f '() #t)]) (test 42 p-ref 5 42) (test 17 p-ref 5 (lambda () (* 1 17))) (err/rt-test (p-ref 5) exn:fail:contract?)) diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt index 3da407c37e..718398414f 100644 --- a/collects/typed-racket/base-env/base-env.rkt +++ b/collects/typed-racket/base-env/base-env.rkt @@ -2093,7 +2093,8 @@ [make-struct-type-property (->opt Sym [(Un (one-of/c #f 'can-impersonate) (-> Univ (-lst Univ))) - (-lst (-pair -Struct-Type-Property (-> Univ Univ)))] + (-lst (-pair -Struct-Type-Property (-> Univ Univ))) + Univ] (-values (list -Struct-Type-Property (-> Univ B) (-> Univ Univ))))] [struct-type-property? (make-pred-ty -Struct-Type-Property)] diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index f02f02f695..c99d2aaa18 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -729,6 +729,7 @@ typedef struct Scheme_Inspector { typedef struct Scheme_Struct_Property { Scheme_Object so; + char can_impersonate; /* 1 if impersonatable property, 0 otherwise */ Scheme_Object *name; /* a symbol */ Scheme_Object *guard; /* NULL, a procedure, or 'can-impersonate */ Scheme_Object *supers; /* implied properties: listof (cons ) */ diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 2b73329cab..f13a673698 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -542,7 +542,7 @@ scheme_init_struct (Scheme_Env *env) scheme_add_global_constant("make-struct-type-property", scheme_make_prim_w_arity2(make_struct_type_property, "make-struct-type-property", - 1, 3, + 1, 4, 3, 3), env); @@ -1112,6 +1112,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object * char *name; int len; const char *who; + char can_impersonate = 0; if (type == scheme_struct_property_type) who = "make-struct-type-property"; @@ -1124,6 +1125,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object * 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_contract(who, "(or/c (any/c any/c . -> . any) #f 'can-impersonate)", 1, argc, argv); @@ -1153,6 +1155,9 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object * "(listof (cons struct-type-property? (any/c . -> . any)))", 2, argc, argv); } + + if (argc > 3) + can_impersonate = SCHEME_TRUEP(argv[3]); } } @@ -1162,6 +1167,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object * if ((argc > 1) && SCHEME_TRUEP(argv[1])) p->guard = argv[1]; p->supers = supers; + p->can_impersonate = can_impersonate; a[0] = (Scheme_Object *)p; @@ -5243,9 +5249,8 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, prop = SCHEME_PRIM_CLOSURE_ELS(proc)[0]; pi = NULL; - if (is_impersonator - && (!((Scheme_Struct_Property *)prop)->guard - || !SCHEME_SYMBOLP(((Scheme_Struct_Property *)prop)->guard))) + if (is_impersonator + && !((Scheme_Struct_Property *)prop)->can_impersonate) scheme_contract_error(name, "operation cannot be impersonated", "operation kind", 0, kind,