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 version "6.1.0.7")
(define version "6.1.1.2")
(define deps `("racket-lib"
["racket" #:version ,version]))
@ -22,4 +22,3 @@
(define pkg-desc "Racket libraries that are currently always available")
(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.
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[
@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[v]; it must return a replacement for
@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.}
@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
@racket[_field-v] to be propagated to @racket[orig-proc] and
@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
for the resulting impersonated structure to use @racket[orig-proc] on
@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?))]
@ -587,18 +593,20 @@ order of the supplied arguments' keywords.}
[prop-val any] ... ...)
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[
@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
@racket[v]; it must return a chaperone of @racket[_field-v]. The
corresponding field may be immutable.}
@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
return a chaperone of @racket[_field-v] to be propagated to
@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
@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?]

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

@ -471,12 +471,20 @@
(let* ([a1 (make-a 1 2)]
[get #f]
[set #f]
[a2 (chaperone-struct a1 a-y (lambda (an-a v) (set! get v) v)
set-a-x! (lambda (an-a v) (set! set v) v))]
[a2-chap #f]
[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)]
[p-get #f]
[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)])
(set! a2-chap a2)
(test 2 a-y a1)
(test #f values get)
(test #f values set)

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.1.1.1"
#define MZSCHEME_VERSION "6.1.1.2"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 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_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;
}
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)
{
@ -1073,26 +1074,31 @@ static Scheme_Object *chaperone_prop_acc_k(void)
Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
Scheme_Object *arg = (Scheme_Object *)p->ku.k.p2;
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.p2 = 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;
p->ku.k.p1 = (void *)o;
p->ku.k.p2 = (void *)arg;
p->ku.k.p3 = (void *)who;
p->ku.k.p4 = (void *)orig_arg;
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) {
if (SCHEME_CHAPERONEP(arg)) {
@ -1123,7 +1129,7 @@ static Scheme_Object *do_chaperone_prop_accessor(const char *who, Scheme_Object
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
return chaperone_prop_acc_overflow(who, prop, arg);
return chaperone_prop_acc_overflow(who, prop, orig_arg, arg);
}
#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);
red = SCHEME_CDR(red);
} else {
orig = do_chaperone_prop_accessor(who, prop, arg);
orig = do_chaperone_prop_accessor(who, prop, orig_arg, arg);
}
if (!orig) return NULL;
a[0] = arg;
a[0] = orig_arg;
a[1] = orig;
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];
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
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)
{
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
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,
Scheme_Object *o, int i);
Scheme_Object *orig_o, Scheme_Object *o, int i);
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 *prim = (Scheme_Object *)p->ku.k.p3;
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.p2 = 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,
Scheme_Object *o, int i)
Scheme_Object *orig_o, Scheme_Object *o, int i)
{
Scheme_Thread *p = scheme_current_thread;
p->ku.k.p1 = (void *)o;
p->ku.k.p2 = (void *)who;
p->ku.k.p3 = (void *)prim;
p->ku.k.p4 = (void *)orig_o;
p->ku.k.i1 = i;
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,
Scheme_Object *o, int i)
Scheme_Object *orig_o, Scheme_Object *o, int i)
{
while (1) {
if (!SCHEME_CHAPERONEP(o)) {
@ -2079,7 +2089,7 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *prim,
if (!SCHEME_CHAPERONEP(o))
orig = ((Scheme_Structure *)o)->slots[i];
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)) {
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
{
# include "mzstkchk.h"
return chaperone_struct_ref_overflow(who, prim, o, i);
return chaperone_struct_ref_overflow(who, prim, orig_o, o, i);
}
#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);
red = SCHEME_CDR(red);
} 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;
if (SAME_TYPE(SCHEME_TYPE(red), scheme_native_closure_type)) {
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)
{
if (SCHEME_CHAPERONEP(sv)) {
return chaperone_struct_ref("struct-ref", NULL, sv, pos);
return chaperone_struct_ref("struct-ref", NULL, sv, sv, pos);
} else {
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,
Scheme_Object *o, int i, Scheme_Object *v)
{
Scheme_Object *orig_o = o;
while (1) {
if (!SCHEME_CHAPERONEP(o)) {
((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)) {
Scheme_Object *finish_setter = NULL;
a[0] = o;
a[0] = orig_o;
a[1] = v;
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]))
return inst->slots[pos];
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)
@ -5431,7 +5443,7 @@ Scheme_Object *scheme_extract_struct_procedure(Scheme_Object *obj, int num_rands
if (SCHEME_INTP(a)) {
*is_method = 0;
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 {
proc = ((Scheme_Structure *)obj)->slots[SCHEME_INT_VAL(a)];
}