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

{impersonator,chaperone}-struct: change protocol to receive self

Browse Source 
When calling a wrapper procedure for a field accessor or mutator,
provide the structure that was originally passed to the accessor or
mutator, instead of the value that was wrapped to create an
impersonator.

This is a backward-incompatible change, but I can't find any uses of
that initial argument to the wrapper procedure. Also, a wrapper can
capture the original value in its closure, while passing "self" allows
wrappers that are sensitive to overridden impersonator properties.
This commit is contained in:
Matthew Flatt 2014-10-02 17:59:29 -06:00
parent 923a785867
commit 0b71b8481d
5 changed files with 67 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi) (define collection 'multi)
(define version "6.1.0.7") (define version "6.1.1.2")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))
@ -22,4 +22,3 @@
(define pkg-desc "Racket libraries that are currently always available") (define pkg-desc "Racket libraries that are currently always available")
(define pkg-authors '(mflatt)) (define pkg-authors '(mflatt))

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

@ -232,12 +232,13 @@ indicate the operations to redirect, and the corresponding
@racket[redirect-proc]s supply the redirections. @racket[redirect-proc]s supply the redirections.
The protocol for a @racket[redirect-proc] depends on the corresponding The protocol for a @racket[redirect-proc] depends on the corresponding
@racket[orig-proc]: @racket[orig-proc], where @racket[_self] refers to the value to which
@racket[redirect-proc] is originally applied:
@itemlist[ @itemlist[
@item{A structure-field accessor: @racket[redirect-proc] @item{A structure-field accessor: @racket[redirect-proc]
must accept two arguments, @racket[v] and the value must accept two arguments, @racket[_self] and the value
@racket[_field-v] that @racket[orig-proc] produces for @racket[_field-v] that @racket[orig-proc] produces for
@racket[v]; it must return a replacement for @racket[v]; it must return a replacement for
@racket[_field-v]. The corresponding field must not be @racket[_field-v]. The corresponding field must not be
@ -247,7 +248,7 @@ The protocol for a @racket[redirect-proc] depends on the corresponding
same field.} same field.}
@item{A structure-field mutator: @racket[redirect-proc] must accept @item{A structure-field mutator: @racket[redirect-proc] must accept
two arguments, @racket[v] and the value @racket[_field-v] two arguments, @racket[_self] and the value @racket[_field-v]
supplied to the mutator; it must return a replacement for supplied to the mutator; it must return a replacement for
@racket[_field-v] to be propagated to @racket[orig-proc] and @racket[_field-v] to be propagated to @racket[orig-proc] and
@racket[v].} @racket[v].}
@ -279,7 +280,12 @@ If any @racket[orig-proc] is itself an impersonator, then a use of the
accessor or mutator that @racket[orig-proc] impersonates is redirected accessor or mutator that @racket[orig-proc] impersonates is redirected
for the resulting impersonated structure to use @racket[orig-proc] on for the resulting impersonated structure to use @racket[orig-proc] on
@racket[v] before @racket[redirect-proc] (in the case of accessor) or @racket[v] before @racket[redirect-proc] (in the case of accessor) or
after @racket[redirect-proc] (in the case of a mutator).} 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].}]}
@defproc[(impersonate-vector [vec (and/c vector? (not/c immutable?))] @defproc[(impersonate-vector [vec (and/c vector? (not/c immutable?))]
@ -587,18 +593,20 @@ order of the supplied arguments' keywords.}
[prop-val any] ... ...) [prop-val any] ... ...)
any/c]{ any/c]{
Like @racket[impersonate-struct], but with the following refinements: Like @racket[impersonate-struct], but with the following refinements,
where @racket[_self] refers to the value to which
a @racket[redirect-proc] is originally applied:
@itemlist[ @itemlist[
@item{With a structure-field accessor as @racket[orig-proc], @item{With a structure-field accessor as @racket[orig-proc],
@racket[redirect-proc] must accept two arguments, @racket[v] and @racket[redirect-proc] must accept two arguments, @racket[_self] and
the value @racket[_field-v] that @racket[orig-proc] produces for the value @racket[_field-v] that @racket[orig-proc] produces for
@racket[v]; it must return a chaperone of @racket[_field-v]. The @racket[v]; it must return a chaperone of @racket[_field-v]. The
corresponding field may be immutable.} corresponding field may be immutable.}
@item{With structure-field mutator as @racket[orig-proc], @item{With structure-field mutator as @racket[orig-proc],
@racket[redirect-proc] must accept two arguments, @racket[v] and @racket[redirect-proc] must accept two arguments, @racket[_self] and
the value @racket[_field-v] supplied to the mutator; it must the value @racket[_field-v] supplied to the mutator; it must
return a chaperone of @racket[_field-v] to be propagated to return a chaperone of @racket[_field-v] to be propagated to
@racket[orig-proc] and @racket[v].} @racket[orig-proc] and @racket[v].}
@ -621,7 +629,12 @@ Like @racket[impersonate-struct], but with the following refinements:
@item{Any accessor or mutator @racket[orig-proc] that is an @item{Any accessor or mutator @racket[orig-proc] that is an
@tech{impersonator} must be specifically a @tech{chaperone}.} @tech{impersonator} must be specifically a @tech{chaperone}.}
]} ]
@history[#:changed "6.1.1.2" @elem{Changed first argument to an
accessor or mutator
@racket[redirect-proc] from
@racket[v] to @racket[_self].}]}
@defproc[(chaperone-vector [vec vector?] @defproc[(chaperone-vector [vec vector?]

12
pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl
View File

@ -471,12 +471,20 @@
(let* ([a1 (make-a 1 2)] (let* ([a1 (make-a 1 2)]
[get #f] [get #f]
[set #f] [set #f]
[a2 (chaperone-struct a1 a-y (lambda (an-a v) (set! get v) v) [a2-chap #f]
set-a-x! (lambda (an-a v) (set! set v) v))] [a2 (chaperone-struct a1 a-y (lambda (an-a v)
(test #t eq? an-a a2-chap)
(set! get v)
v)
set-a-x! (lambda (an-a v)
(test #t eq? an-a a2-chap)
(set! set v)
v))]
[p1 (make-p 100)] [p1 (make-p 100)]
[p-get #f] [p-get #f]
[p2 (chaperone-struct p1 green-ref (lambda (p v) (set! p-get v) v))] [p2 (chaperone-struct p1 green-ref (lambda (p v) (set! p-get v) v))]
[a3 (chaperone-struct a1 a-x (lambda (a y) y) prop:blue 8)]) [a3 (chaperone-struct a1 a-x (lambda (a y) y) prop:blue 8)])
(set! a2-chap a2)
(test 2 a-y a1) (test 2 a-y a1)
(test #f values get) (test #f values get)
(test #f values set) (test #f values set)

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "6.1.1.1" #define MZSCHEME_VERSION "6.1.1.2"
#define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 1 #define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 1 #define MZSCHEME_VERSION_W 2
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

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

@ -1065,7 +1065,8 @@ XFORM_NONGCING static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Schem
return NULL; return NULL;
} }
static Scheme_Object *do_chaperone_prop_accessor(const char *who, Scheme_Object *prop, Scheme_Object *arg); static Scheme_Object *do_chaperone_prop_accessor(const char *who, Scheme_Object *prop,
Scheme_Object *orig_arg, Scheme_Object *arg);
static Scheme_Object *chaperone_prop_acc_k(void) static Scheme_Object *chaperone_prop_acc_k(void)
{ {
@ -1073,26 +1074,31 @@ static Scheme_Object *chaperone_prop_acc_k(void)
Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
Scheme_Object *arg = (Scheme_Object *)p->ku.k.p2; Scheme_Object *arg = (Scheme_Object *)p->ku.k.p2;
const char *who = (const char *)p->ku.k.p3; const char *who = (const char *)p->ku.k.p3;
Scheme_Object *orig_arg = (Scheme_Object *)p->ku.k.p4;
p->ku.k.p1 = NULL; p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL; p->ku.k.p2 = NULL;
p->ku.k.p3 = NULL; p->ku.k.p3 = NULL;
p->ku.k.p4 = NULL;
return do_chaperone_prop_accessor(who, o, arg); return do_chaperone_prop_accessor(who, o, orig_arg, arg);
} }
static Scheme_Object *chaperone_prop_acc_overflow(const char *who, Scheme_Object *o, Scheme_Object *arg) static Scheme_Object *chaperone_prop_acc_overflow(const char *who, Scheme_Object *o,
Scheme_Object *orig_arg, Scheme_Object *arg)
{ {
Scheme_Thread *p = scheme_current_thread; Scheme_Thread *p = scheme_current_thread;
p->ku.k.p1 = (void *)o; p->ku.k.p1 = (void *)o;
p->ku.k.p2 = (void *)arg; p->ku.k.p2 = (void *)arg;
p->ku.k.p3 = (void *)who; p->ku.k.p3 = (void *)who;
p->ku.k.p4 = (void *)orig_arg;
return scheme_handle_stack_overflow(chaperone_prop_acc_k); return scheme_handle_stack_overflow(chaperone_prop_acc_k);
} }
static Scheme_Object *do_chaperone_prop_accessor(const char *who, Scheme_Object *prop, Scheme_Object *arg) static Scheme_Object *do_chaperone_prop_accessor(const char *who, Scheme_Object *prop,
Scheme_Object *orig_arg, Scheme_Object *arg)
{ {
while (1) { while (1) {
if (SCHEME_CHAPERONEP(arg)) { if (SCHEME_CHAPERONEP(arg)) {
@ -1123,7 +1129,7 @@ static Scheme_Object *do_chaperone_prop_accessor(const char *who, Scheme_Object
#ifdef DO_STACK_CHECK #ifdef DO_STACK_CHECK
{ {
# include "mzstkchk.h" # include "mzstkchk.h"
return chaperone_prop_acc_overflow(who, prop, arg); return chaperone_prop_acc_overflow(who, prop, orig_arg, arg);
} }
#endif #endif
@ -1136,12 +1142,12 @@ static Scheme_Object *do_chaperone_prop_accessor(const char *who, Scheme_Object
orig = _scheme_apply(SCHEME_CAR(red), 1, a); orig = _scheme_apply(SCHEME_CAR(red), 1, a);
red = SCHEME_CDR(red); red = SCHEME_CDR(red);
} else { } else {
orig = do_chaperone_prop_accessor(who, prop, arg); orig = do_chaperone_prop_accessor(who, prop, orig_arg, arg);
} }
if (!orig) return NULL; if (!orig) return NULL;
a[0] = arg; a[0] = orig_arg;
a[1] = orig; a[1] = orig;
v = _scheme_apply(red, 2, a); v = _scheme_apply(red, 2, a);
@ -1164,7 +1170,8 @@ static Scheme_Object *prop_accessor(int argc, Scheme_Object **args, Scheme_Objec
v = args[0]; v = args[0];
if (SCHEME_CHAPERONEP(v)) if (SCHEME_CHAPERONEP(v))
v = do_chaperone_prop_accessor(((Scheme_Primitive_Proc *)prim)->name, SCHEME_PRIM_CLOSURE_ELS(prim)[0], v); v = do_chaperone_prop_accessor(((Scheme_Primitive_Proc *)prim)->name, SCHEME_PRIM_CLOSURE_ELS(prim)[0],
v, v);
else else
v = do_prop_accessor(SCHEME_PRIM_CLOSURE_ELS(prim)[0], v); v = do_prop_accessor(SCHEME_PRIM_CLOSURE_ELS(prim)[0], v);
@ -1316,7 +1323,7 @@ Scheme_Object *scheme_make_struct_type_property(Scheme_Object *name)
Scheme_Object *scheme_chaperone_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s) Scheme_Object *scheme_chaperone_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s)
{ {
if (SCHEME_CHAPERONEP(s)) if (SCHEME_CHAPERONEP(s))
return do_chaperone_prop_accessor("impersonator-property-ref", prop, s); return do_chaperone_prop_accessor("impersonator-property-ref", prop, s, s);
else else
return do_prop_accessor(prop, s); return do_prop_accessor(prop, s);
} }
@ -2002,7 +2009,7 @@ int scheme_is_struct_instance(Scheme_Object *type, Scheme_Object *v)
} }
static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *prim, static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *prim,
Scheme_Object *o, int i); Scheme_Object *orig_o, Scheme_Object *o, int i);
static Scheme_Object *chaperone_struct_ref_k(void) static Scheme_Object *chaperone_struct_ref_k(void)
{ {
@ -2010,22 +2017,25 @@ static Scheme_Object *chaperone_struct_ref_k(void)
Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
Scheme_Object *prim = (Scheme_Object *)p->ku.k.p3; Scheme_Object *prim = (Scheme_Object *)p->ku.k.p3;
const char *who = (const char *)p->ku.k.p2; const char *who = (const char *)p->ku.k.p2;
Scheme_Object *orig_o = (Scheme_Object *)p->ku.k.p4;
p->ku.k.p1 = NULL; p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL; p->ku.k.p2 = NULL;
p->ku.k.p3 = NULL; p->ku.k.p3 = NULL;
p->ku.k.p4 = NULL;
return chaperone_struct_ref(who, prim, o, p->ku.k.i1); return chaperone_struct_ref(who, prim, orig_o, o, p->ku.k.i1);
} }
static Scheme_Object *chaperone_struct_ref_overflow(const char *who, Scheme_Object *prim, static Scheme_Object *chaperone_struct_ref_overflow(const char *who, Scheme_Object *prim,
Scheme_Object *o, int i) Scheme_Object *orig_o, Scheme_Object *o, int i)
{ {
Scheme_Thread *p = scheme_current_thread; Scheme_Thread *p = scheme_current_thread;
p->ku.k.p1 = (void *)o; p->ku.k.p1 = (void *)o;
p->ku.k.p2 = (void *)who; p->ku.k.p2 = (void *)who;
p->ku.k.p3 = (void *)prim; p->ku.k.p3 = (void *)prim;
p->ku.k.p4 = (void *)orig_o;
p->ku.k.i1 = i; p->ku.k.i1 = i;
return scheme_handle_stack_overflow(chaperone_struct_ref_k); return scheme_handle_stack_overflow(chaperone_struct_ref_k);
@ -2061,7 +2071,7 @@ static void raise_undefined_error(const char *who, Scheme_Object *prim, Scheme_O
} }
static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *prim, static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *prim,
Scheme_Object *o, int i) Scheme_Object *orig_o, Scheme_Object *o, int i)
{ {
while (1) { while (1) {
if (!SCHEME_CHAPERONEP(o)) { if (!SCHEME_CHAPERONEP(o)) {
@ -2079,7 +2089,7 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *prim,
if (!SCHEME_CHAPERONEP(o)) if (!SCHEME_CHAPERONEP(o))
orig = ((Scheme_Structure *)o)->slots[i]; orig = ((Scheme_Structure *)o)->slots[i];
else else
orig = chaperone_struct_ref(who, prim, o, i); orig = chaperone_struct_ref(who, prim, orig_o, o, i);
if (SAME_OBJ(orig, scheme_undefined)) { if (SAME_OBJ(orig, scheme_undefined)) {
raise_undefined_error(who, prim, px->val, "undefined", "use", i); raise_undefined_error(who, prim, px->val, "undefined", "use", i);
@ -2094,7 +2104,7 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *prim,
#ifdef DO_STACK_CHECK #ifdef DO_STACK_CHECK
{ {
# include "mzstkchk.h" # include "mzstkchk.h"
return chaperone_struct_ref_overflow(who, prim, o, i); return chaperone_struct_ref_overflow(who, prim, orig_o, o, i);
} }
#endif #endif
@ -2107,9 +2117,9 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *prim,
orig = _scheme_apply(SCHEME_CAR(red), 1, a); orig = _scheme_apply(SCHEME_CAR(red), 1, a);
red = SCHEME_CDR(red); red = SCHEME_CDR(red);
} else } else
orig = chaperone_struct_ref(who, prim, px->prev, i); orig = chaperone_struct_ref(who, prim, orig_o, px->prev, i);
a[0] = px->prev; a[0] = orig_o;
a[1] = orig; a[1] = orig;
if (SAME_TYPE(SCHEME_TYPE(red), scheme_native_closure_type)) { if (SAME_TYPE(SCHEME_TYPE(red), scheme_native_closure_type)) {
o = _scheme_apply_native(red, 2, a); o = _scheme_apply_native(red, 2, a);
@ -2136,7 +2146,7 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *prim,
Scheme_Object *scheme_struct_ref(Scheme_Object *sv, int pos) Scheme_Object *scheme_struct_ref(Scheme_Object *sv, int pos)
{ {
if (SCHEME_CHAPERONEP(sv)) { if (SCHEME_CHAPERONEP(sv)) {
return chaperone_struct_ref("struct-ref", NULL, sv, pos); return chaperone_struct_ref("struct-ref", NULL, sv, sv, pos);
} else { } else {
Scheme_Structure *s = (Scheme_Structure *)sv; Scheme_Structure *s = (Scheme_Structure *)sv;
@ -2147,6 +2157,8 @@ Scheme_Object *scheme_struct_ref(Scheme_Object *sv, int pos)
static void chaperone_struct_set(const char *who, Scheme_Object *prim, static void chaperone_struct_set(const char *who, Scheme_Object *prim,
Scheme_Object *o, int i, Scheme_Object *v) Scheme_Object *o, int i, Scheme_Object *v)
{ {
Scheme_Object *orig_o = o;
while (1) { while (1) {
if (!SCHEME_CHAPERONEP(o)) { if (!SCHEME_CHAPERONEP(o)) {
((Scheme_Structure *)o)->slots[i] = v; ((Scheme_Structure *)o)->slots[i] = v;
@ -2165,7 +2177,7 @@ static void chaperone_struct_set(const char *who, Scheme_Object *prim,
if (SCHEME_TRUEP(red)) { if (SCHEME_TRUEP(red)) {
Scheme_Object *finish_setter = NULL; Scheme_Object *finish_setter = NULL;
a[0] = o; a[0] = orig_o;
a[1] = v; a[1] = v;
if (SCHEME_PAIRP(red)) { if (SCHEME_PAIRP(red)) {
@ -2597,7 +2609,7 @@ Scheme_Object *scheme_struct_getter(int argc, Scheme_Object **args, Scheme_Objec
if (SAME_OBJ((Scheme_Object *)inst, args[0])) if (SAME_OBJ((Scheme_Object *)inst, args[0]))
return inst->slots[pos]; return inst->slots[pos];
else else
return chaperone_struct_ref("struct-ref", prim, args[0], pos); return chaperone_struct_ref("struct-ref", prim, args[0], args[0], pos);
} }
Scheme_Object *scheme_struct_setter(int argc, Scheme_Object **args, Scheme_Object *prim) Scheme_Object *scheme_struct_setter(int argc, Scheme_Object **args, Scheme_Object *prim)
@ -5431,7 +5443,7 @@ Scheme_Object *scheme_extract_struct_procedure(Scheme_Object *obj, int num_rands
if (SCHEME_INTP(a)) { if (SCHEME_INTP(a)) {
*is_method = 0; *is_method = 0;
if (!SAME_OBJ(plain_obj, obj)) { if (!SAME_OBJ(plain_obj, obj)) {
proc = chaperone_struct_ref("struct-ref", NULL, obj, SCHEME_INT_VAL(a)); proc = chaperone_struct_ref("struct-ref", NULL, obj, obj, SCHEME_INT_VAL(a));
} else { } else {
proc = ((Scheme_Structure *)obj)->slots[SCHEME_INT_VAL(a)]; proc = ((Scheme_Structure *)obj)->slots[SCHEME_INT_VAL(a)];
} }