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

chaperones: allow procedure chaperones that supplies no redirection

Browse Source 
The same as the change for structure chaperones, but for procedures.
This commit is contained in:
Matthew Flatt 2014-09-21 12:13:55 -05:00
parent 1f1a10db87
commit a8d0534e65
4 changed files with 60 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl
View File

@ -116,7 +116,7 @@ Otherwise, impersonators within @racket[v2] must be intact within
]}
@item{If a part of @racket[v2] is a structure impersonator that was
@item{If a part of @racket[v2] is a structure or procedure impersonator that was
created with no redirection procedures (i.e, @racket[#f] in
place of all redirection procedures for specified operations),
then the impersonated value is considered in place of that part
@ -141,7 +141,7 @@ except that the mutability of vectors and boxes with @racket[v1] and
Otherwise, chaperones within @racket[v2] must be intact within
@racket[v1] analogous to way that @racket[impersonator-of?] requires
that impersonators are preserved, except that @racket[prop:impersonator-of]
has no analog for @racket[chaperone-of].}
has no analog for @racket[chaperone-of?].}
@defproc[(impersonator-ephemeron [v any/c]) ephemeron?]{
@ -158,14 +158,15 @@ reachable in addition to any value that @racket[v] impersonates
@section{Impersonator Constructors}
@defproc[(impersonate-procedure [proc procedure?]
[wrapper-proc procedure?]
[wrapper-proc (or/c procedure? #f)]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c procedure? impersonator?)]{
Returns an impersonator procedure that has the same arity, name, and
other attributes as @racket[proc]. When the impersonator procedure is
applied, the arguments are first passed to @racket[wrapper-proc], and
applied, the arguments are first passed to @racket[wrapper-proc]
(when it is not @racket[#f]), and
then the results from @racket[wrapper-proc] are passed to
@racket[proc]. The @racket[wrapper-proc] can also supply a procedure
that processes the results of @racket[proc].
@ -194,6 +195,11 @@ impersonator (i.e., not counting optional arguments that were
not supplied). The arguments must be ordered according to the sorted
order of the supplied arguments' keywords.
If @racket[wrapper] is @racket[#f], then applying the resulting
impersonator is the same as applying @racket[proc]. If
@racket[wrapper] is @racket[#f] and no @racket[prop] is provided, then
the result is @racket[proc] unimpersonated.
Pairs of @racket[prop] and @racket[prop-val] (the number of arguments
to @racket[procedure-impersonator] must be even) add impersonator properties
or override impersonator-property values of @racket[proc].
@ -550,7 +556,7 @@ between @racket[impersonator-of?] and @racket[equal?]).}
@section{Chaperone Constructors}
@defproc[(chaperone-procedure [proc procedure?]
[wrapper-proc procedure?]
[wrapper-proc (or/c procedure? #f)]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c procedure? chaperone?)]{

16
pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl
View File

@ -1529,6 +1529,7 @@
(λ (kwds kwd-args . args)
(apply values kwd-args args))
(λ args (apply values args))))
(define-values (prop:blue blue? blue-ref) (make-impersonator-property 'blue))
(define g1 (chaperone-procedure f1 wrapper))
(define g2 (chaperone-procedure f2 wrapper))
@ -1542,6 +1543,21 @@
(test #t chaperone-of? g3 f2)
(test #f chaperone-of? g3 g2)
(test #t chaperone-of? g1 (chaperone-procedure g1 #f prop:blue 'color))
(test #t chaperone-of? g2 (chaperone-procedure g2 #f prop:blue 'color))
(test #t chaperone-of? g3 (chaperone-procedure g3 #f prop:blue 'color))
(test #t chaperone-of? f3 (chaperone-procedure f3 #f prop:blue 'color))
(test #f chaperone-of? f3 (chaperone-procedure g3 #f prop:blue 'color))
(test #t eq? f1 (chaperone-procedure f1 #f))
(test #t eq? f3 (chaperone-procedure f3 #f))
(test #f eq? f3 (chaperone-procedure f3 #f prop:blue 'color))
(test #f eq? f1 (chaperone-procedure f1 #f impersonator-prop:application-mark 'x))
(test #f eq? f1 (chaperone-procedure f1 #f impersonator-prop:application-mark (cons 1 2)))
(test 8 (chaperone-procedure f2 #f prop:blue 'color) #:key 8)
(test 88 (chaperone-procedure f3 #f prop:blue 'color) #:key 88)
(test 'color blue-ref (chaperone-procedure f3 #f prop:blue 'color))
(test #t equal? g1 f1)
(test #t equal? g2 f2)
(test #t equal? g3 f2)

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

@ -3382,20 +3382,24 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
if (!SCHEME_PROCP(val))
scheme_wrong_contract(name, "procedure?", 0, argc, argv);
if (!SCHEME_PROCP(argv[1]))
scheme_wrong_contract(name, "procedure?", 1, argc, argv);
if (!SCHEME_FALSEP(argv[1]) && !SCHEME_PROCP(argv[1]))
scheme_wrong_contract(name, "(or/c procedure? #f)", 1, argc, argv);
orig = get_or_check_arity(val, -1, NULL, 1);
naya = get_or_check_arity(argv[1], -1, NULL, 1);
if (SCHEME_FALSEP(argv[1]))
naya = scheme_false;
else {
naya = get_or_check_arity(argv[1], -1, NULL, 1);
if (!is_subarity(orig, naya))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: arity of wrapper procedure does not cover arity of original procedure\n"
" wrapper: %V\n"
" original: %V",
name,
argv[1],
argv[0]);
if (!is_subarity(orig, naya))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: arity of wrapper procedure does not cover arity of original procedure\n"
" wrapper: %V\n"
" original: %V",
name,
argv[1],
argv[0]);
}
props = scheme_parse_chaperone_props(name, 2, argc, argv);
if (props) {
@ -3406,14 +3410,18 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
props = NULL;
else
props = scheme_hash_tree_set(props, scheme_app_mark_impersonator_property, NULL);
/* app_mark should be (cons mark val) */
if (!SCHEME_PAIRP(app_mark))
app_mark = scheme_false;
} else
app_mark = scheme_false;
} else
app_mark = scheme_false;
if (SCHEME_FALSEP(argv[1]) && SCHEME_FALSEP(app_mark) && !props)
return argv[0];
/* app_mark should be (cons mark val) */
if (SCHEME_FALSEP(app_mark) && !SCHEME_PAIRP(app_mark))
app_mark = scheme_false;
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->iso.so.type = scheme_proc_chaperone_type;
px->val = val;
@ -3561,6 +3569,11 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
else
what = "impersonator";
if (SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[0])) {
/* no redirection procedure */
return _scheme_tail_apply(px->prev, argc, argv);
}
/* Ensure that the original procedure accepts `argc' arguments: */
if (argc != SCHEME_INT_VAL(SCHEME_VEC_ELS(px->redirects)[1])) {
a[0] = px->prev;

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

@ -2237,8 +2237,12 @@ int scheme_is_noninterposing_chaperone(Scheme_Object *o)
if (!SCHEME_VECTORP(px->redirects))
return 0;
if (SCHEME_VEC_SIZE(px->redirects) & 1)
return 0;
if (SCHEME_VEC_SIZE(px->redirects) & 1) {
/* procedure chaperone */
if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0]))
return 0;
return 1;
}
if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0]))
return 0;