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

fix chaperones on parameters

Browse Source 
svn: r18654
This commit is contained in:
Matthew Flatt 2010-03-28 15:56:04 +00:00
parent 026356ecc5
commit b8c3112b98
9 changed files with 182 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/scribblings/reference/chaperones.scrbl
View File

@ -102,6 +102,11 @@ that accepts as many results as produced by @scheme[proc]; it must
return the same number of results, each of which is the same or a
chaperone of the corresponding original result.
If @scheme[wrapper-proc] returns the same number of values as it is
given (i.e., it does not return a procedure to chaperone
@scheme[proc]'s result), then @scheme[proc] is called in @tech{tail
position} with respect to the call to the chaperone.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[procedure-chaperone] must be even) add chaperone properties
or override chaperone-property values of @scheme[proc].}

12
collects/scribblings/reference/parameters.scrbl
View File

@ -141,18 +141,24 @@ Returns a parameter procedure that sets or retrieves the same value as
@item{@scheme[wrap] applied when obtaining the parameter's value.}
]}
]
See also @scheme[chaperone-procedure], which can also be used to guard
parameter procedures.}
@defproc[(parameter? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a parameter procedure,
@scheme[#f] otherwise.}
@defproc[(parameter-procedure=? [a parameter?][b parameter?]) boolean?]{
Returns @scheme[#t] if the parameter procedures @scheme[a] and
@scheme[b] always modify the same parameter with the same guards,
@scheme[#f] otherwise.}
@scheme[b] always modify the same parameter with the same guards
(although possibly with different @tech{chaperones}), @scheme[#f]
otherwise.}
@defproc[(current-parameterization) parameterization?]{Returns the

46
collects/tests/mzscheme/chaperone.ss
View File

@ -553,4 +553,50 @@
;; ----------------------------------------
(let ()
(define (check-param current-directory)
(parameterize ([current-directory (current-directory)])
(let* ([pre-cd? #f]
[post-cd? #f]
[got-cd? #f]
[post-got-cd? #f]
[cd1 (chaperone-procedure current-directory (case-lambda
[() (set! got-cd? #t) (values)]
[(v) (set! pre-cd? #t) v]))]
[cd2 (chaperone-procedure current-directory (case-lambda
[() (set! got-cd? #t)
(lambda (r)
(set! post-got-cd? #t)
r)]
[(v)
(set! pre-cd? #t)
(values v
(lambda (x)
(set! post-cd? #t)
(void)))]))])
(test #t parameter? cd1)
(test #t parameter? cd2)
(test '(#f #f #f #f) list pre-cd? post-cd? got-cd? post-got-cd?)
(test (current-directory) cd1)
(test '(#f #f #t #f) list pre-cd? post-cd? got-cd? post-got-cd?)
(test (current-directory) cd2)
(test '(#f #f #t #t) list pre-cd? post-cd? got-cd? post-got-cd?)
(cd1 (current-directory))
(test '(#t #f #t #t) list pre-cd? post-cd? got-cd? post-got-cd?)
(set! pre-cd? #f)
(parameterize ([cd1 (current-directory)])
(test '(#t #f #t #t) list pre-cd? post-cd? got-cd? post-got-cd?))
(set! pre-cd? #f)
(cd2 (current-directory))
(test '(#t #t #t #t) list pre-cd? post-cd? got-cd? post-got-cd?)
(set! pre-cd? #f)
(set! post-cd? #f)
(parameterize ([cd2 (current-directory)])
(test '(#t #t #t #t) list pre-cd? post-cd? got-cd? post-got-cd?)))))
(check-param current-directory)
(let ([p (make-parameter 88)])
(check-param p)))
;; ----------------------------------------
(report-errs)

2
src/mzscheme/src/eval.c
View File

@ -9196,7 +9196,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
/* Chaperone is for function arguments */
VACATE_TAIL_BUFFER_USE_RUNSTACK();
UPDATE_THREAD_RSPTR();
v = scheme_apply_chaperone(obj, num_rands, rands);
v = scheme_apply_chaperone(obj, num_rands, rands, NULL);
}
} else if (type == scheme_closed_prim_type) {
GC_CAN_IGNORE Scheme_Closed_Primitive_Proc *prim;

63
src/mzscheme/src/fun.c
View File

@ -31,6 +31,7 @@
#include "schpriv.h"
#include "schexpobs.h"
#include "schmach.h"
/* The implementations of the time primitives, such as
`current-seconds', vary a lot from platform to platform. */
@ -4007,7 +4008,7 @@ static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[])
if (!is_subarity(orig, naya))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-procedure: arity of chaperoneing procedure: %V"
"chaperone-procedure: arity of chaperoning procedure: %V"
" does not cover arity of original procedure: %V",
argv[1],
argv[0]);
@ -4024,10 +4025,46 @@ static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[])
return (Scheme_Object *)px;
}
Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv)
static Scheme_Object *apply_chaperone_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
Scheme_Object **argv = (Scheme_Object **)p->ku.k.p2;
Scheme_Object *auto_val = (Scheme_Object *)p->ku.k.p3;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
p->ku.k.p3 = NULL;
return scheme_apply_chaperone(o, p->ku.k.i1, argv, auto_val);
}
static Scheme_Object *do_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val)
{
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object **argv2;
argv2 = MALLOC_N(Scheme_Object*, argc);
memcpy(argv2, argv, sizeof(Scheme_Object *) * argc);
p->ku.k.p1 = (void *)o;
p->ku.k.p2 = (void *)argv2;
p->ku.k.p3 = (void *)auto_val;
p->ku.k.i1 = argc;
return scheme_handle_stack_overflow(apply_chaperone_k);
}
}
#endif
return scheme_apply_chaperone(o, argc, argv, auto_val);
}
Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val)
{
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *v, *a[1], *a2[1], **argv2, *post;
Scheme_Object *v, *a[1], *a2[1], **argv2, *post, *result_v;
int c, i;
v = _scheme_apply_multi(px->redirects, argc, argv);
@ -4069,7 +4106,14 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
if (c == argc) {
/* No filter for the result, so tail call: */
if (auto_val) {
if (SCHEME_CHAPERONEP(px->prev))
return do_apply_chaperone(px->prev, c, argv2, auto_val);
else
return argv2[0];
} else {
return scheme_tail_apply(px->prev, c, argv2);
}
} else {
/* Last element is a filter for the result(s) */
post = argv2[argc];
@ -4078,7 +4122,16 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
"procedure chaperone: %V: expected <procedure> as last result, produced: %V",
px->redirects,
post);
if (auto_val) {
if (SCHEME_CHAPERONEP(px->prev))
result_v = do_apply_chaperone(px->prev, argc, argv2, auto_val);
else
result_v = argv2[0];
v = auto_val;
} else {
v = _scheme_apply_multi(px->prev, argc, argv2);
result_v = NULL;
}
if (v == SCHEME_MULTIPLE_VALUES) {
GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
@ -4134,7 +4187,9 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
return NULL;
}
if (c == 1)
if (result_v)
return result_v;
else if (c == 1)
return argv2[0];
else
return scheme_values(c, argv2);

2
src/mzscheme/src/schpriv.h
View File

@ -768,7 +768,7 @@ typedef struct Scheme_Chaperone {
Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i);
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v);
Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv);
Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val);
Scheme_Hash_Tree *scheme_parse_chaperone_props(const char *who, int start_at, int argc, Scheme_Object **argv);

47
src/mzscheme/src/struct.c
View File

@ -2714,10 +2714,12 @@ int scheme_inspector_sees_part(Scheme_Object *s, Scheme_Object *insp, int pos)
static Scheme_Object *
struct_setter_p(int argc, Scheme_Object *argv[])
{
return ((STRUCT_mPROCP(argv[0],
Scheme_Object *v = argv[0];
if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
return ((STRUCT_mPROCP(v,
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK,
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER)
|| STRUCT_mPROCP(argv[0],
|| STRUCT_mPROCP(v,
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK,
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER))
? scheme_true : scheme_false);
@ -2726,8 +2728,10 @@ struct_setter_p(int argc, Scheme_Object *argv[])
static Scheme_Object *
struct_getter_p(int argc, Scheme_Object *argv[])
{
return ((STRUCT_PROCP(argv[0], SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)
|| STRUCT_mPROCP(argv[0],
Scheme_Object *v = argv[0];
if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
return ((STRUCT_PROCP(v, SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)
|| STRUCT_mPROCP(v,
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK,
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER))
? scheme_true : scheme_false);
@ -2736,14 +2740,18 @@ struct_getter_p(int argc, Scheme_Object *argv[])
static Scheme_Object *
struct_pred_p(int argc, Scheme_Object *argv[])
{
return (STRUCT_PROCP(argv[0], SCHEME_PRIM_IS_STRUCT_PRED)
Scheme_Object *v = argv[0];
if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
return (STRUCT_PROCP(v, SCHEME_PRIM_IS_STRUCT_PRED)
? scheme_true : scheme_false);
}
static Scheme_Object *
struct_constr_p(int argc, Scheme_Object *argv[])
{
return (STRUCT_mPROCP(argv[0],
Scheme_Object *v = argv[0];
if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
return (STRUCT_mPROCP(v,
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK,
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_CONSTR)
? scheme_true : scheme_false);
@ -2752,20 +2760,24 @@ struct_constr_p(int argc, Scheme_Object *argv[])
static Scheme_Object *
struct_prop_getter_p(int argc, Scheme_Object *argv[])
{
return ((STRUCT_mPROCP(argv[0],
Scheme_Object *v = argv[0];
if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
return ((STRUCT_mPROCP(v,
SCHEME_PRIM_OTHER_TYPE_MASK,
SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER)
&& SAME_TYPE(SCHEME_TYPE(SCHEME_PRIM_CLOSURE_ELS(argv[0])[0]), scheme_struct_property_type))
&& SAME_TYPE(SCHEME_TYPE(SCHEME_PRIM_CLOSURE_ELS(v)[0]), scheme_struct_property_type))
? scheme_true : scheme_false);
}
static Scheme_Object *
chaperone_prop_getter_p(int argc, Scheme_Object *argv[])
{
return ((STRUCT_mPROCP(argv[0],
Scheme_Object *v = argv[0];
if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
return ((STRUCT_mPROCP(v,
SCHEME_PRIM_OTHER_TYPE_MASK,
SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER)
&& SAME_TYPE(SCHEME_TYPE(SCHEME_PRIM_CLOSURE_ELS(argv[0])[0]), scheme_chaperone_property_type))
&& SAME_TYPE(SCHEME_TYPE(SCHEME_PRIM_CLOSURE_ELS(v)[0]), scheme_chaperone_property_type))
? scheme_true : scheme_false);
}
@ -2779,6 +2791,9 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
char digitbuf[20];
int fieldstrlen;
/* We don't allow chaperones on the getter or setter procedure, because we
can't preserve them in the generated procedure. */
if (!STRUCT_mPROCP(argv[0],
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_OTHER_TYPE_MASK,
SCHEME_PRIM_IS_STRUCT_OTHER | (getter
@ -4565,7 +4580,9 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
break;
}
a[0] = proc;
if (SCHEME_CHAPERONEP(proc)) proc = SCHEME_CHAPERONE_VAL(proc);
if (SCHEME_TRUEP(struct_setter_p(1, a))) {
kind = "mutator";
offset = stype->num_slots;
@ -4589,7 +4606,7 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
if (si_chaperone)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-struct: struct-info procedure supplied a second time: %V",
proc);
a[0]);
pi = NULL;
prop = NULL;
arity = 2;
@ -4601,7 +4618,7 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-struct: %s %V does not apply to given object: %V",
kind,
proc,
a[0],
argv[0]);
if (!red_props)
red_props = scheme_make_hash_tree(0);
@ -4610,7 +4627,7 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-struct: given %s is for the same property as a previous %s argument: %V",
kind, kind,
proc);
a[0]);
arity = 2;
} else {
pi = (Struct_Proc_Info *)((Scheme_Primitive_Closure *)proc)->val[0];
@ -4620,13 +4637,13 @@ static Scheme_Object *chaperone_struct(int argc, Scheme_Object **argv)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-struct: %s %V does not apply to given object: %V",
kind,
proc,
a[0],
argv[0]);
if (SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + pi->field])
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"chaperone-struct: given %s is for the same field as a previous %s argument: %V",
kind, kind,
proc);
a[0]);
arity = 2;
}

2
src/mzscheme/src/stxobj.c
View File

@ -8034,7 +8034,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
while (i != -1) {
scheme_hash_tree_index(ht1, i, &key, &val);
if (!SAME_OBJ((Scheme_Object *)ht1, o))
val = scheme_chaperone_hash_traversal_get(ht1, key);
val = scheme_chaperone_hash_traversal_get(o, key);
val = datum_to_syntax_inner(val, ut, stx_src, stx_wraps, ht);
if (!val) return NULL;
ht2 = scheme_hash_tree_set(ht2, key, val);

20
src/mzscheme/src/thread.c
View File

@ -6351,13 +6351,20 @@ static Scheme_Object *extend_parameterization(int argc, Scheme_Object *argv[])
scheme_flatten_config(c);
} else if (SCHEME_CONFIGP(c) && (argc & 1)) {
for (i = 1; i < argc; i += 2) {
if (!SCHEME_PARAMETERP(argv[i])) {
param = argv[i];
if (!SCHEME_PARAMETERP(param)
&& !(SCHEME_CHAPERONEP(param) && SCHEME_PARAMETERP(SCHEME_CHAPERONE_VAL(param)))) {
scheme_wrong_type("parameterize", "parameter", i, argc, argv);
return NULL;
}
a[0] = argv[i + 1];
key = argv[i + 1];
if (SCHEME_CHAPERONEP(param)) {
a[0] = key;
key = scheme_apply_chaperone(param, 1, a, scheme_void);
param = SCHEME_CHAPERONE_VAL(param);
}
a[0] = key;
a[1] = scheme_false;
param = argv[i];
while (1) {
if (SCHEME_PRIMP(param)) {
Scheme_Prim *proc;
@ -6421,6 +6428,8 @@ static Scheme_Object *parameter_p(int argc, Scheme_Object **argv)
{
Scheme_Object *v = argv[0];
if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
return (SCHEME_PARAMETERP(v)
? scheme_true
: scheme_false);
@ -6509,7 +6518,7 @@ static Scheme_Object *make_derived_parameter(int argc, Scheme_Object **argv)
ParamData *data;
if (!SCHEME_PARAMETERP(argv[0]))
scheme_wrong_type("make-derived-parameter", "parameter", 0, argc, argv);
scheme_wrong_type("make-derived-parameter", "unchaperoned parameter", 0, argc, argv);
scheme_check_proc_arity("make-derived-parameter", 1, 1, argc, argv);
scheme_check_proc_arity("make-derived-parameter", 1, 2, argc, argv);
@ -6537,6 +6546,9 @@ static Scheme_Object *parameter_procedure_eq(int argc, Scheme_Object **argv)
a = argv[0];
b = argv[1];
if (SCHEME_CHAPERONEP(a)) a = SCHEME_CHAPERONE_VAL(a);
if (SCHEME_CHAPERONEP(b)) b = SCHEME_CHAPERONE_VAL(b);
if (!SCHEME_PARAMETERP(a))
scheme_wrong_type("parameter-procedure=?", "parameter-procedure", 0, argc, argv);
if (!SCHEME_PARAMETERP(b))