From 3fa9f99e2c6866171d8a99888ad8b6e4e68bb212 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 19 Apr 2014 10:44:52 -0600 Subject: [PATCH] racket/unsafe/undefined: add `chaperone-struct-unsafe-undefined` --- .../reference/unsafe-undefined.scrbl | 38 +++++++++------ racket/collects/racket/unsafe/ops.rkt | 3 +- racket/collects/racket/unsafe/undefined.rkt | 3 +- racket/src/racket/src/cstartup.inc | 10 ++-- racket/src/racket/src/fun.c | 13 ++++++ racket/src/racket/src/schminc.h | 2 +- racket/src/racket/src/schvers.h | 4 +- racket/src/racket/src/struct.c | 46 ++++++++++++------- 8 files changed, 78 insertions(+), 41 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl index a2ff551b4f..fec2a52934 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl @@ -42,22 +42,17 @@ message (if any) is along the lines of ``@racket[sym]: undefined; assignment before initialization.''} -@defthing[prop:chaperone-unsafe-undefined struct-type-property?]{ +@defproc[(chaperone-struct-unsafe-undefined [v any/c]) any/c]{ -A @tech{structure type property} that causes a structure type's -constructor to produce a @tech{chaperone} of an instance. Every access +Chaperones @racket[v] if it is a structure (as viewed through some +@tech{inspector}). Every access of a field in the structure is checked +to prevent returning @racket[unsafe-undefined]. Similarly, every +assignment to a field in the structure is checked (unless the check +disabled as described below) to prevent assignment of a field whose +current value is @racket[unsafe-undefined]. -of a field in the structure is checked to prevent returning -@racket[unsafe-undefined]. Similarly, every assignment to a field in -the structure is checked (unless the check disabled as described -below) to prevent assignment of a field whose current value is -@racket[unsafe-undefined]. - -The property value should be a list of symbols used as field names, -but the list should be in reverse order of the structure's fields. -When a field access would otherwise produce @racket[unsafe-undefined], -the @racket[exn:fail:contract:variable] exception is raised if a field -name is provided by the structure property's value, otherwise the +When a field access would otherwise produce @racket[unsafe-undefined] +or when a field assignment would replace @racket[unsafe-undefined], the @racket[exn:fail:contract] exception is raised. The chaperone's field-assignment check is disabled whenever @@ -67,3 +62,18 @@ Thus, a field-initializing assignment---one that is intended to replace the @racket[unsafe-undefined] value of a field---should be wrapped with @racket[(with-continuation-mark prop:chaperone-unsafe-undefined unsafe-undefined ....)].} + + +@defthing[prop:chaperone-unsafe-undefined struct-type-property?]{ + +A @tech{structure type property} that causes a structure type's +constructor to produce a @tech{chaperone} of an instance +in the same way as @racket[chaperone-struct-unsafe-undefined]. + +The property value should be a list of symbols used as field names, +but the list should be in reverse order of the structure's fields. +When a field access or assignment would produce or replace +@racket[unsafe-undefined], the @racket[exn:fail:contract:variable] +exception is raised if a field name is provided by the structure +property's value, otherwise the @racket[exn:fail:contract] exception +is raised.} diff --git a/racket/collects/racket/unsafe/ops.rkt b/racket/collects/racket/unsafe/ops.rkt index 68a6109c86..04a38c590e 100644 --- a/racket/collects/racket/unsafe/ops.rkt +++ b/racket/collects/racket/unsafe/ops.rkt @@ -7,7 +7,8 @@ unsafe-undefined check-not-unsafe-undefined check-not-unsafe-undefined/assign - prop:chaperone-unsafe-undefined) + prop:chaperone-unsafe-undefined + chaperone-struct-unsafe-undefined) (prefix-out unsafe- (combine-out flsin flcos fltan flasin flacos flatan diff --git a/racket/collects/racket/unsafe/undefined.rkt b/racket/collects/racket/unsafe/undefined.rkt index 3566c36adf..e09b95be87 100644 --- a/racket/collects/racket/unsafe/undefined.rkt +++ b/racket/collects/racket/unsafe/undefined.rkt @@ -4,4 +4,5 @@ (provide check-not-unsafe-undefined check-not-unsafe-undefined/assign unsafe-undefined - prop:chaperone-unsafe-undefined) + prop:chaperone-unsafe-undefined + chaperone-struct-unsafe-undefined) diff --git a/racket/src/racket/src/cstartup.inc b/racket/src/racket/src/cstartup.inc index d4d8ea7f39..dfee110067 100644 --- a/racket/src/racket/src/cstartup.inc +++ b/racket/src/racket/src/cstartup.inc @@ -1,5 +1,5 @@ { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,14,0, 27,0,31,0,38,0,42,0,49,0,54,0,61,0,66,0,69,0,74,0,83, 0,87,0,93,0,107,0,121,0,124,0,130,0,134,0,136,0,147,0,149,0, @@ -100,7 +100,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 2051); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,187,0,0,0,1,0,0,8,0,21,0, 26,0,43,0,55,0,77,0,106,0,150,0,156,0,165,0,172,0,187,0,205, 0,217,0,233,0,247,0,13,1,32,1,39,1,73,1,90,1,107,1,130,1, @@ -1017,7 +1017,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 19187); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,14,0,0,0,1,0,0,15,0,40,0, 57,0,75,0,97,0,120,0,140,0,162,0,171,0,180,0,187,0,196,0,203, 0,0,0,231,1,0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99, @@ -1047,7 +1047,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 557); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,106,0,0,0,1,0,0,7,0,18,0, 45,0,51,0,60,0,67,0,89,0,102,0,128,0,145,0,167,0,175,0,187, 0,202,0,218,0,236,0,0,1,12,1,28,1,51,1,75,1,87,1,118,1, @@ -1529,7 +1529,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 10046); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0, 29,0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,101,1,0, 0,69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2, diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 5d29f16765..f1be0c658f 100644 --- a/racket/src/racket/src/fun.c +++ b/racket/src/racket/src/fun.c @@ -194,6 +194,8 @@ static Scheme_Object *current_get_read_input_port(int, Scheme_Object **); static Scheme_Object *chaperone_wrap_cc_guard(Scheme_Object *obj, Scheme_Object *proc); static Scheme_Object *do_cc_guard(Scheme_Object *v, Scheme_Object *cc_guard, Scheme_Object *chaperone); +static Scheme_Object *chaperone_unsafe_undefined(int argc, Scheme_Object **argv); + static Scheme_Object * scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key, Scheme_Object *prompt_tag, Scheme_Meta_Continuation **_meta, @@ -688,6 +690,9 @@ scheme_init_unsafe_fun (Scheme_Env *env) o = scheme_make_struct_type_property(scheme_intern_symbol("chaperone-unsafe-undefined")); scheme_chaperone_undefined_property = o; scheme_add_global_constant("prop:chaperone-unsafe-undefined", o, env); + + o = scheme_make_prim_w_arity(chaperone_unsafe_undefined, "chaperone-struct-unsafe-undefined", 1, 1); + scheme_add_global_constant("chaperone-struct-unsafe-undefined", o, env); } void @@ -2579,6 +2584,14 @@ scheme_check_assign_not_undefined (int argc, Scheme_Object *argv[]) return argv[0]; } +static Scheme_Object *chaperone_unsafe_undefined(int argc, Scheme_Object **argv) +{ + if (SCHEME_CHAPERONE_STRUCTP(argv[0])) + return scheme_chaperone_not_undefined(argv[0]); + else + return argv[0]; +} + static Scheme_Object * procedure_p (int argc, Scheme_Object *argv[]) { diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index 5a67f42a18..ea9319d714 100644 --- a/racket/src/racket/src/schminc.h +++ b/racket/src/racket/src/schminc.h @@ -15,7 +15,7 @@ #define USE_COMPILED_STARTUP 1 #define EXPECTED_PRIM_COUNT 1116 -#define EXPECTED_UNSAFE_COUNT 105 +#define EXPECTED_UNSAFE_COUNT 106 #define EXPECTED_FLFXNUM_COUNT 69 #define EXPECTED_EXTFL_COUNT 45 #define EXPECTED_FUTURES_COUNT 15 diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 6942e6aa37..ee5750ec10 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.0.1.4" +#define MZSCHEME_VERSION "6.0.1.5" #define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Z 1 -#define MZSCHEME_VERSION_W 4 +#define MZSCHEME_VERSION_W 5 #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 40e3d7dbd2..ac64ecd6b6 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -1968,32 +1968,38 @@ int scheme_is_struct_instance(Scheme_Object *type, Scheme_Object *v) return STRUCT_TYPEP(stype, s); } -static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, int i); +static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *prim, + Scheme_Object *o, int i); static Scheme_Object *chaperone_struct_ref_k(void) { Scheme_Thread *p = scheme_current_thread; 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; p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; - return chaperone_struct_ref(who, o, p->ku.k.i1); + return chaperone_struct_ref(who, prim, o, p->ku.k.i1); } -static Scheme_Object *chaperone_struct_ref_overflow(const char *who, Scheme_Object *o, int i) +static Scheme_Object *chaperone_struct_ref_overflow(const char *who, Scheme_Object *prim, + 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.i1 = i; return scheme_handle_stack_overflow(chaperone_struct_ref_k); } -static void raise_undefined_error(Scheme_Object *val, const char *short_error, const char *mode, int i) +static void raise_undefined_error(const char *who, Scheme_Object *prim, Scheme_Object *val, + const char *short_error, const char *mode, int i) { int len; Scheme_Object *o; @@ -2010,14 +2016,19 @@ static void raise_undefined_error(Scheme_Object *val, const char *short_error, c "%S: %s;\n cannot %s field before initialization", o, short_error, mode); } else { + if (prim) + who = extract_field_proc_name(prim); + scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "%s;\n cannot %s field before initialization", + "%s: %s;\n cannot %s field before initialization", + who, short_error, mode); } } -static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, int i) +static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *prim, + Scheme_Object *o, int i) { while (1) { if (!SCHEME_CHAPERONEP(o)) { @@ -2035,10 +2046,10 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, in if (!SCHEME_CHAPERONEP(o)) orig = ((Scheme_Structure *)o)->slots[i]; else - orig = chaperone_struct_ref(who, o, i); + orig = chaperone_struct_ref(who, prim, o, i); if (SAME_OBJ(orig, scheme_undefined)) { - raise_undefined_error(px->val, "undefined", "use", i); + raise_undefined_error(who, prim, px->val, "undefined", "use", i); } return orig; @@ -2050,11 +2061,11 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, in #ifdef DO_STACK_CHECK { # include "mzstkchk.h" - return chaperone_struct_ref_overflow(who, o, i); + return chaperone_struct_ref_overflow(who, prim, o, i); } #endif - orig = chaperone_struct_ref(who, px->prev, i); + orig = chaperone_struct_ref(who, prim, px->prev, i); a[0] = px->prev; a[1] = orig; @@ -2084,7 +2095,7 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, in Scheme_Object *scheme_struct_ref(Scheme_Object *sv, int pos) { if (SCHEME_CHAPERONEP(sv)) { - return chaperone_struct_ref("struct-ref", sv, pos); + return chaperone_struct_ref("struct-ref", NULL, sv, pos); } else { Scheme_Structure *s = (Scheme_Structure *)sv; @@ -2092,7 +2103,8 @@ Scheme_Object *scheme_struct_ref(Scheme_Object *sv, int pos) } } -static void chaperone_struct_set(const char *who, Scheme_Object *o, int i, Scheme_Object *v) +static void chaperone_struct_set(const char *who, Scheme_Object *prim, + Scheme_Object *o, int i, Scheme_Object *v) { while (1) { if (!SCHEME_CHAPERONEP(o)) { @@ -2138,7 +2150,7 @@ static void chaperone_struct_set(const char *who, Scheme_Object *o, int i, Schem m = scheme_extract_one_cc_mark(NULL, scheme_chaperone_undefined_property); if (!m || !SAME_OBJ(m, scheme_undefined)) - raise_undefined_error(px->val, "assignment disallowed", "assign", i); + raise_undefined_error(who, prim, px->val, "assignment disallowed", "assign", i); } } } @@ -2148,7 +2160,7 @@ static void chaperone_struct_set(const char *who, Scheme_Object *o, int i, Schem void scheme_struct_set(Scheme_Object *sv, int pos, Scheme_Object *v) { if (SCHEME_CHAPERONEP(sv)) { - chaperone_struct_set("struct-set", sv, pos, v); + chaperone_struct_set("struct-set!", NULL, sv, pos, v); } else { Scheme_Structure *s = (Scheme_Structure *)sv; @@ -2498,7 +2510,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 scheme_struct_ref(args[0], pos); + return chaperone_struct_ref("struct-ref", prim, args[0], pos); } Scheme_Object *scheme_struct_setter(int argc, Scheme_Object **args, Scheme_Object *prim) @@ -2554,7 +2566,7 @@ Scheme_Object *scheme_struct_setter(int argc, Scheme_Object **args, Scheme_Objec if (SAME_OBJ((Scheme_Object *)inst, args[0])) inst->slots[pos] = v; else - scheme_struct_set(args[0], pos, v); + chaperone_struct_set("struct-set!", prim, args[0], pos, v); return scheme_void; } @@ -5180,7 +5192,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", obj, SCHEME_INT_VAL(a)); + proc = chaperone_struct_ref("struct-ref", NULL, obj, SCHEME_INT_VAL(a)); } else { proc = ((Scheme_Structure *)obj)->slots[SCHEME_INT_VAL(a)]; }