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

add `proxy-prop:application-mark'

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-29 12:25:51 -04:00
parent 24e0060e6d
commit 4b120e5d86
5 changed files with 134 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -150,7 +150,20 @@ order of the supplied arguments' keywords.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[procedure-proxy] must be even) add proxy properties
or override proxy-property values of @scheme[proc].}
or override proxy-property values of @scheme[proc].
If any @scheme[prop] is @racket[proxy-prop:application-mark] and if the
associated @racket[prop-val] is a pair, then the call to @racket[proc]
is wrapped with @racket[with-continuation-mark] using @racket[(car
prop-val)] as the mark key and @racket[(cdr prop-val)] as the mark
value. In addition, if @racket[continuation-mark-set-first] with
@racket[(car prop-val)] produces a value for the immediate
continuation frame of the call to the proxied procedure, the value is
also installed as an immediate value for @racket[(car prop-val)] as a
mark during the call to @racket[wrapper-proc] (which allows tail-calls
of proxies with respect to wrapping proxies to be detected within
@racket[wrapper-proc]).}
@defproc[(proxy-struct [v any/c]
[orig-proc (or/c struct-accessor-procedure?
@ -537,3 +550,10 @@ descriptor} value, @scheme[#f] otherwise.}
Returns @scheme[#t] if @scheme[v] is an accessor procedure produced
by @scheme[make-proxy-property], @scheme[#f] otherwise.}
@defthing[proxy-prop:application-mark proxy-property?]{
A @tech{proxy property} that is recognized by @racket[proxy-procedure]
and @racket[chaperone-procedure].}

48
collects/tests/racket/chaperone.rktl
View File

@ -1151,4 +1151,52 @@
;; ----------------------------------------
(let ()
(define (f x)
(call-with-immediate-continuation-mark
'z
(lambda (val)
(list val
(continuation-mark-set->list (current-continuation-marks) 'z)))))
(define saved null)
(define g (chaperone-procedure
f
(lambda (a)
(set! saved (cons (continuation-mark-set-first #f 'z)
saved))
(values (lambda (r) r)
a))
proxy-prop:application-mark
(cons 'z 12)))
(define h (chaperone-procedure
g
(lambda (a)
(values (lambda (r) r)
a))
proxy-prop:application-mark
(cons 'z 9)))
(define i (chaperone-procedure
f
(lambda (a)
(set! saved (cons (continuation-mark-set-first #f 'z)
saved))
a)
proxy-prop:application-mark
(cons 'z 11)))
(define j (chaperone-procedure
i
(lambda (a) a)
proxy-prop:application-mark
(cons 'z 12)))
(test (list 12 '(12)) g 10)
(test '(#f) values saved)
(test (list 12 '(12 9)) h 10)
(test '(9 #f) values saved)
(test (list 11 '(11)) i 10)
(test '(#f 9 #f) values saved)
(test (list 11 '(11)) j 10)
(test '(12 #f 9 #f) values saved))
;; ----------------------------------------
(report-errs)

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

@ -4174,8 +4174,10 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
{
const char *what;
Scheme_Chaperone *px;
Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v, *orig_obj;
Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v, *orig_obj, *app_mark;
int c, i, need_restore = 0;
int need_pop_mark = 0;
Scheme_Cont_Frame_Data cframe;
if (argv == MZ_RUNSTACK) {
/* Pushing onto the runstack ensures that px->redirects won't
@ -4221,6 +4223,26 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
return NULL;
}
if (px->props) {
app_mark = scheme_hash_tree_get(px->props, scheme_app_mark_proxy_property);
/* app_mark should be (cons mark val) */
if (app_mark && !SCHEME_PAIRP(app_mark))
app_mark = NULL;
} else
app_mark = NULL;
if (app_mark) {
v = scheme_extract_one_cc_mark(NULL, SCHEME_CAR(app_mark));
if (v) {
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(SCHEME_CAR(app_mark), v);
MZ_CONT_MARK_POS -= 2;
need_pop_mark = 1;
} else
need_pop_mark = 0;
} else
need_pop_mark = 0;
v = _scheme_apply_multi(px->redirects, argc, argv);
if (v == SCHEME_MULTIPLE_VALUES) {
GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
@ -4233,6 +4255,11 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
a2[0] = v;
argv2 = a2;
}
if (need_pop_mark) {
MZ_CONT_MARK_POS += 2;
scheme_pop_continuation_frame(&cframe);
}
if ((c == argc) || (c == (argc + 1))) {
if (c > argc) {
@ -4278,6 +4305,8 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
if (c == argc) {
/* No filter for the result, so tail call: */
if (app_mark)
scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark));
if (auto_val) {
if (SCHEME_CHAPERONEP(px->prev))
return do_apply_chaperone(px->prev, c, argv2, auto_val);
@ -4299,6 +4328,15 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
what,
px->redirects,
post);
if (app_mark) {
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark));
MZ_CONT_MARK_POS -= 2;
need_pop_mark = 1;
} else
need_pop_mark = 0;
if (auto_val) {
if (SCHEME_CHAPERONEP(px->prev))
result_v = do_apply_chaperone(px->prev, argc, argv2, auto_val);
@ -4314,6 +4352,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
v = _scheme_apply_multi(orig_obj, 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))
@ -4325,6 +4364,11 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
a[0] = v;
argv = a;
}
if (need_pop_mark) {
MZ_CONT_MARK_POS += 2;
scheme_pop_continuation_frame(&cframe);
}
if (!scheme_check_proc_arity(NULL, c, 0, -1, &post))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,

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

@ -386,6 +386,8 @@ extern Scheme_Object *scheme_input_port_property, *scheme_output_port_property;
extern Scheme_Object *scheme_equal_property;
extern Scheme_Object *scheme_proxy_of_property;
extern Scheme_Object *scheme_app_mark_proxy_property;
extern Scheme_Object *scheme_reduced_procedure_struct;
/*========================================================================*/

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

@ -38,6 +38,7 @@ READ_ONLY Scheme_Object *scheme_current_inspector_proc;
READ_ONLY Scheme_Object *scheme_recur_symbol;
READ_ONLY Scheme_Object *scheme_display_symbol;
READ_ONLY Scheme_Object *scheme_write_special_symbol;
READ_ONLY Scheme_Object *scheme_app_mark_proxy_property;
READ_ONLY static Scheme_Object *location_struct;
READ_ONLY static Scheme_Object *write_property;
@ -170,6 +171,8 @@ static Scheme_Object *proxy_struct(int argc, Scheme_Object **argv);
static Scheme_Object *chaperone_struct_type(int argc, Scheme_Object **argv);
static Scheme_Object *make_chaperone_property(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_chaperone_property_from_c(Scheme_Object *name);
#define PRE_REDIRECTS 2
#ifdef MZ_PRECISE_GC
@ -722,9 +725,13 @@ scheme_init_struct (Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant("proxy-prop:application-mark",
scheme_false,
env);
{
REGISTER_SO(scheme_app_mark_proxy_property);
scheme_app_mark_proxy_property = make_chaperone_property_from_c(scheme_intern_symbol("application-mark"));
scheme_add_global_constant("proxy-prop:application-mark",
scheme_app_mark_proxy_property,
env);
}
}
/*========================================================================*/
@ -1104,6 +1111,14 @@ static Scheme_Object *make_chaperone_property(int argc, Scheme_Object *argv[])
return scheme_values(3, a);
}
static Scheme_Object *make_chaperone_property_from_c(Scheme_Object *name)
{
Scheme_Object *a[3];
a[0] = name;
return make_struct_type_property_from_c(1, a, &a[1], &a[2], scheme_chaperone_property_type);
}
Scheme_Object *scheme_make_struct_type_property_w_guard(Scheme_Object *name, Scheme_Object *guard)
{
Scheme_Object *a[2];