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

make impersonator properties sensitive to prop:impersonator-of

Browse Source 
When a structure type has `prop:inpersonator-of`, follow it
when attemptng to access imperonator properties.

This change fixes a problem with `impersonate-procedure` as
reported by Scott Moore.
This commit is contained in:
Matthew Flatt 2015-03-08 19:22:55 -06:00
parent 092f6bb7e1
commit b923269569
6 changed files with 174 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -595,9 +595,19 @@ otherwise the result is a value for which the original structure is an
impersonator (so the original structure is an @racket[impersonator-of?] and
@racket[equal?] to the result value). The result value must have the
same @racket[prop:impersonator-of] and @racket[prop:equal+hash] property
values as the original structure, and the property values must be
values as the original structure, if any, and the property values must be
inherited from the same structure type (which ensures some consistency
between @racket[impersonator-of?] and @racket[equal?]).}
between @racket[impersonator-of?] and @racket[equal?]).
@tech{Impersonator property} predicates and accessors applied to a
structure with the @racket[prop:impersonator-of] property first check
for the property on the immediate structure, and if it is not found,
the value produced by the @racket[prop:impersonator-of] procedure is
checked (recursively).
@history[#:changed "6.1.1.8" @elem{Made @tech{impersonator property}
predicates and accessors sensitive
to @racket[prop:impersonator-of].}]}
@; ------------------------------------------------------------
@section{Chaperone Constructors}

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

@ -299,6 +299,15 @@
(lambda (kws kw-args self . args)
(keyword-apply b kws kw-args args)))))
(define (check-proc-prop f mk)
(let-values ([(prop:blue blue? blue-ref) (make-impersonator-property 'blue)])
(define f1 (chaperone-procedure f #f prop:blue "blue"))
(test #t blue? f1)
(test "blue" blue-ref f1)
(define f2 (mk f1))
(test #t blue? f2)
(test "blue" blue-ref f2)))
;; Single argument, no post filter:
(as-chaperone-or-impersonator
([chaperone-procedure impersonate-procedure
@ -306,15 +315,18 @@
impersonate-procedure**])
(let* ([f (lambda (x) (list x x))]
[in #f]
[f2 (chaperone-procedure
f
(lambda (x)
(set! in x)
x))])
[mk (lambda (f)
(chaperone-procedure
f
(lambda (x)
(set! in x)
x)))]
[f2 (mk f)])
(test '(110 110) f 110)
(test #f values in)
(test '(111 111) f2 111)
(test 111 values in)))
(test 111 values in)
(check-proc-prop f mk)))
;; Multiple arguments, no post filter:
(as-chaperone-or-impersonator
@ -323,15 +335,18 @@
impersonate-procedure**])
(let* ([f (lambda (x y) (list x y))]
[in #f]
[f2 (chaperone-procedure
f
(lambda (x y)
(set! in (vector x y))
(values x y)))])
[mk (lambda (f)
(chaperone-procedure
f
(lambda (x y)
(set! in (vector x y))
(values x y))))]
[f2 (mk f)])
(test '(1100 1101) f 1100 1101)
(test #f values in)
(test '(1110 1111) f2 1110 1111)
(test (vector 1110 1111) values in)))
(test (vector 1110 1111) values in)
(check-proc-prop f mk)))
;; Single argument, post filter on single value:
(as-chaperone-or-impersonator
@ -341,20 +356,23 @@
(let* ([f (lambda (x) (list x x))]
[in #f]
[out #f]
[f2 (chaperone-procedure
f
(lambda (x)
(set! in x)
(values (lambda (y)
(set! out y)
y)
x)))])
[mk (lambda (f)
(chaperone-procedure
f
(lambda (x)
(set! in x)
(values (lambda (y)
(set! out y)
y)
x))))]
[f2 (mk f)])
(test '(10 10) f 10)
(test #f values in)
(test #f values out)
(test '(11 11) f2 11)
(test 11 values in)
(test '(11 11) values out)))
(test '(11 11) values out)
(check-proc-prop f mk)))
;; Multiple arguments, post filter on multiple values:
(as-chaperone-or-impersonator
@ -364,20 +382,23 @@
(let* ([f (lambda (x y z) (values y (list x z)))]
[in #f]
[out #f]
[f2 (chaperone-procedure
f
(lambda (x y z)
(set! in (vector x y z))
(values (lambda (y z)
(set! out (vector y z))
(values y z))
x y z)))])
[mk (lambda (f)
(chaperone-procedure
f
(lambda (x y z)
(set! in (vector x y z))
(values (lambda (y z)
(set! out (vector y z))
(values y z))
x y z))))]
[f2 (mk f)])
(test-values '(b (a c)) (lambda () (f 'a 'b 'c)))
(test #f values in)
(test #f values out)
(test-values '(b (a c)) (lambda () (f2 'a 'b 'c)))
(test (vector 'a 'b 'c) values in)
(test (vector 'b '(a c)) values out)))
(test (vector 'b '(a c)) values out)
(check-proc-prop f mk)))
;; Optional keyword arguments:
(as-chaperone-or-impersonator
@ -386,16 +407,18 @@
impersonate-procedure**/kw])
(let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
[in #f]
[f2 (chaperone-procedure
f
(lambda (x #:a [a 'nope] #:b [b 'nope])
(if (and (eq? a 'nope) (eq? b 'nope))
x
(values
(append
(if (eq? a 'nope) null (list a))
(if (eq? b 'nope) null (list b)))
x))))])
[mk (lambda (f)
(chaperone-procedure
f
(lambda (x #:a [a 'nope] #:b [b 'nope])
(if (and (eq? a 'nope) (eq? b 'nope))
x
(values
(append
(if (eq? a 'nope) null (list a))
(if (eq? b 'nope) null (list b)))
x)))))]
[f2 (mk f)])
(test '(1 a b) f 1)
(test '(1 a b) f2 1)
(test '(1 2 b) f 1 #:a 2)
@ -406,7 +429,8 @@
(test '(1 2 3) f2 1 #:a 2 #:b 3)
(test 1 procedure-arity f2)
(test 'f object-name f2)
(test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))))
(test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))
(check-proc-prop f mk)))
;; Optional keyword arguments with result chaperone:
(as-chaperone-or-impersonator
@ -416,18 +440,20 @@
(let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b))]
[in #f]
[out #f]
[f2 (chaperone-procedure
f
(lambda (x #:a [a 'nope] #:b [b 'nope])
(set! in (list x a b))
(if (and (eq? a 'nope) (eq? b 'nope))
x
(values
(lambda (z) (set! out z) z)
(append
(if (eq? a 'nope) null (list a))
(if (eq? b 'nope) null (list b)))
x))))])
[mk (lambda (f)
(chaperone-procedure
f
(lambda (x #:a [a 'nope] #:b [b 'nope])
(set! in (list x a b))
(if (and (eq? a 'nope) (eq? b 'nope))
x
(values
(lambda (z) (set! out z) z)
(append
(if (eq? a 'nope) null (list a))
(if (eq? b 'nope) null (list b)))
x)))))]
[f2 (mk f)])
(test '(1 a b) f 1)
(test '(#f #f) list in out)
(test '(1 a b) f2 1)
@ -441,7 +467,8 @@
(test '(1 2 3) f2 1 #:a 2 #:b 3)
(test 1 procedure-arity f2)
(test 'f object-name f2)
(test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))))
(test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))
(check-proc-prop f mk)))
;; Required keyword arguments:
(as-chaperone-or-impersonator
@ -450,16 +477,18 @@
impersonate-procedure**/kw])
(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
[in #f]
[f2 (chaperone-procedure
f
(lambda (x #:a [a 'nope] #:b [b 'nope])
(if (and (eq? a 'nope) (eq? b 'nope))
x
(values
(append
(if (eq? a 'nope) null (list a))
(if (eq? b 'nope) null (list b)))
x))))])
[mk (lambda (f)
(chaperone-procedure
f
(lambda (x #:a [a 'nope] #:b [b 'nope])
(if (and (eq? a 'nope) (eq? b 'nope))
x
(values
(append
(if (eq? a 'nope) null (list a))
(if (eq? b 'nope) null (list b)))
x)))))]
[f2 (mk f)])
(err/rt-test (f 1))
(err/rt-test (f2 1))
(err/rt-test (f 1 #:a 2))
@ -470,7 +499,8 @@
(test '(1 2 3) f2 1 #:a 2 #:b 3)
(test 1 procedure-arity f2)
(test 'f object-name f2)
(test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))))
(test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))
(check-proc-prop f mk)))
;; Required keyword arguments:
(as-chaperone-or-impersonator
@ -480,18 +510,20 @@
(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b))]
[in #f]
[out #f]
[f2 (chaperone-procedure
f
(lambda (x #:a [a 'nope] #:b [b 'nope])
(set! in (list x a b))
(if (and (eq? a 'nope) (eq? b 'nope))
x
(values
(lambda (z) (set! out z) z)
(append
(if (eq? a 'nope) null (list a))
(if (eq? b 'nope) null (list b)))
x))))])
[mk (lambda (f)
(chaperone-procedure
f
(lambda (x #:a [a 'nope] #:b [b 'nope])
(set! in (list x a b))
(if (and (eq? a 'nope) (eq? b 'nope))
x
(values
(lambda (z) (set! out z) z)
(append
(if (eq? a 'nope) null (list a))
(if (eq? b 'nope) null (list b)))
x)))))]
[f2 (mk f)])
(err/rt-test (f 1))
(err/rt-test (f2 1))
(err/rt-test (f 1 #:a 2))
@ -503,7 +535,8 @@
(test '(1 2 3) f2 1 #:a 2 #:b 3)
(test 1 procedure-arity f2)
(test 'f object-name f2)
(test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))))
(test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))
(check-proc-prop f mk)))
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y))) 1))
(err/rt-test ((impersonate-procedure (lambda (x) x) (lambda (y) (values y y))) 1))
@ -1693,6 +1726,10 @@
(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))
(test #t blue? (make-a (chaperone-struct a1 struct:a prop:blue 'color) 2))
(test 'color blue-ref (make-a (chaperone-struct a1 struct:a prop:blue 'color) 2))
(void)))
;; ----------------------------------------

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

@ -1708,6 +1708,8 @@
[(okp? n-proc)
(values
(if is-impersonator?
;; Can't use `impersonate-struct` here (due to the immutable field);
;; create a new structure, but preserve properties
((if (okm? n-proc)
make-optional-keyword-method-impersonator
make-optional-keyword-procedure-impersonator)

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

@ -69,7 +69,6 @@ static int vector_equal (Scheme_Object *vec1, Scheme_Object *orig_vec1,
static int struct_equal (Scheme_Object *s1, Scheme_Object *orig_s1,
Scheme_Object *s2, Scheme_Object *orig_s2,
Equal_Info *eql);
static Scheme_Object *apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj);
void scheme_init_true_false(void)
{
@ -699,13 +698,13 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
else
procs1 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st1);
if (procs1)
procs1 = apply_impersonator_of(eql->for_chaperone, procs1, obj1);
procs1 = scheme_apply_impersonator_of(eql->for_chaperone, procs1, obj1);
if (eql->for_chaperone)
procs2 = NULL;
else {
procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
if (procs2)
procs2 = apply_impersonator_of(eql->for_chaperone, procs2, obj2);
procs2 = scheme_apply_impersonator_of(eql->for_chaperone, procs2, obj2);
}
if (procs1 || procs2) {
@ -997,7 +996,7 @@ int scheme_impersonator_of(Scheme_Object *obj1, Scheme_Object *obj2)
return is_equal(obj1, obj2, &eql);
}
static Scheme_Object *apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj)
Scheme_Object *scheme_apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj)
{
Scheme_Object *a[1], *v, *oprocs;

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

@ -1029,6 +1029,8 @@ Scheme_Object *scheme_chaperone_not_undefined(Scheme_Object *orig_val);
int scheme_is_noninterposing_chaperone(Scheme_Object *obj);
Scheme_Object *scheme_apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj);
/*========================================================================*/
/* syntax objects */
/*========================================================================*/

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

@ -1003,16 +1003,31 @@ static Scheme_Object *prop_pred(int argc, Scheme_Object **args, Scheme_Object *p
Scheme_Chaperone *px;
v = args[0];
if (SCHEME_CHAPERONEP(v)) {
/* Check for property at chaperone level: */
px = (Scheme_Chaperone *)v;
if (px->props)
v = scheme_hash_tree_get(px->props, prop);
else
v = NULL;
if (v)
return scheme_true;
v = px->val;
while (1) {
if (SCHEME_CHAPERONEP(v)) {
/* Check for property at chaperone level: */
px = (Scheme_Chaperone *)v;
if (px->props)
v = scheme_hash_tree_get(px->props, prop);
else
v = NULL;
if (v)
return scheme_true;
v = px->val;
}
if (SAME_TYPE(SCHEME_TYPE(prop), scheme_chaperone_property_type)) {
/* An impersonator property must be at the chaperone level, but can
be via `prop:impersonator-of`: */
Scheme_Object *procs;
procs = scheme_struct_type_property_ref(scheme_impersonator_of_property, v);
if (procs)
v = scheme_apply_impersonator_of(0, procs, v);
else
return scheme_false;
} else
break;
}
if (SCHEME_STRUCTP(v))
@ -1159,7 +1174,19 @@ static Scheme_Object *do_chaperone_prop_accessor(const char *who, Scheme_Object
}
}
} else {
return do_prop_accessor(prop, arg);
if (SAME_TYPE(SCHEME_TYPE(prop), scheme_chaperone_property_type)) {
Scheme_Object *procs;
procs = scheme_struct_type_property_ref(scheme_impersonator_of_property, arg);
if (procs) {
arg = scheme_apply_impersonator_of(0, procs, arg);
/* loop to try again */
} else {
/* an impersonator property lives at the impersonator/chaperone level, only: */
return NULL;
}
} else {
return do_prop_accessor(prop, arg);
}
}
}
}
@ -1169,7 +1196,8 @@ static Scheme_Object *prop_accessor(int argc, Scheme_Object **args, Scheme_Objec
Scheme_Object *v;
v = args[0];
if (SCHEME_CHAPERONEP(v))
if (SCHEME_CHAPERONEP(v)
|| SAME_TYPE(SCHEME_TYPE(SCHEME_PRIM_CLOSURE_ELS(prim)[0]), scheme_chaperone_property_type))
v = do_chaperone_prop_accessor(((Scheme_Primitive_Proc *)prim)->name, SCHEME_PRIM_CLOSURE_ELS(prim)[0],
v, v);
else