diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl index 3eecb3f79c..cdd2665af8 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl @@ -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?)]{ diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl index 2cb96f0fb9..db9be0b93e 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl @@ -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) diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 230b39d91e..d2e26e370f 100644 --- a/racket/src/racket/src/fun.c +++ b/racket/src/racket/src/fun.c @@ -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; diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 364f9fcfde..068dac7143 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -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;