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

Allow guards for impersonatable struct type properties

Browse Source
This commit is contained in:
Asumu Takikawa 2012-07-19 16:15:55 -04:00
parent d3677524b8
commit e14c5d61e9
7 changed files with 38 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/racket/private/promise.rkt
View File

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

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

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

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

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

4
collects/tests/racket/struct.rktl
View File

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

3
collects/typed-racket/base-env/base-env.rkt
View File

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

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

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

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

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