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

racket/unsafe/undefined: add chaperone-struct-unsafe-undefined

Browse Source
This commit is contained in:
Matthew Flatt 2014-04-19 10:44:52 -06:00
parent 04f9918aa9
commit 3fa9f99e2c
8 changed files with 78 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
pkgs/racket-pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl
View File

@ -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.}

3
racket/collects/racket/unsafe/ops.rkt
View File

@ -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

3
racket/collects/racket/unsafe/undefined.rkt
View File

@ -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)

10
racket/src/racket/src/cstartup.inc
View File

@ -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,

13
racket/src/racket/src/fun.c
View File

@ -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[])
{

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

@ -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

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

@ -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)

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

@ -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)];
}