diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index acc53175f1..74bb2c3e4b 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -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)) - diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl index cdd2665af8..b07c3692ed 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl @@ -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?] diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl index db9be0b93e..b6349cb857 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl @@ -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) diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 8e61bd37d5..d899f80186 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -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) diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 068dac7143..b3d191b8c7 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -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)]; }