diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl index 22c3e8e22f..3eecb3f79c 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/chaperones.scrbl @@ -89,12 +89,43 @@ impersonators to @racket[v2]. For values that include no impersonators, @racket[v1] and @racket[v2] can be considered impersonators of each other if they are @racket[equal?]. -Otherwise, all impersonators of @racket[v2] must be intact in @racket[v1], -in the sense that parts of @racket[v2] must be derived from -@racket[v1] through one of the impersonator constructors (e.g., -@racket[impersonate-procedure] or @racket[chaperone-procedure]). +Otherwise, impersonators within @racket[v2] must be intact within +@racket[v1]: -See also @racket[prop:impersonator-of].} +@itemlist[ + + @item{If a part of @racket[v2] is an impersonator created from one of + the impersonator constructors (e.g., + @racket[impersonate-procedure] or + @racket[chaperone-procedure]), and if the impersonator is + constructed with at least one redirection procedure (i.e., a + value other than @racket[#f] was supplied for a redirection + procedure), then the corresponding part of @racket[v1] must be + one of the following: + + @itemlist[ + + @item{the same value that is a part of @racket[v2];} + + @item{a value further derived from the part of @racket[v2] + value using an impersonator constructor; or} + + @item{a value with the @racket[prop:impersonator-of] property + whose procedure produces an impersonator of the value + that is a part of @racket[v2].} + + ]} + + @item{If a part of @racket[v2] is a structure 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 + of @racket[v2]. In other words, an impersonator construction + that does not redirect any access or mutation (but that + includes some @tech{impersonator properties}) need not be + preserved in @racket[v1].} + +]} @defproc[(chaperone-of? [v1 any/c] [v2 any/c]) boolean?]{ @@ -107,10 +138,11 @@ be considered chaperones of each other if they are @racket[equal?], except that the mutability of vectors and boxes with @racket[v1] and @racket[v2] must be the same. -Otherwise, all chaperones of @racket[v2] must be intact in -@racket[v1], in the sense that parts of @racket[v2] must be derived -from @racket[v1] through one of the chaperone constructors (e.g., -@racket[chaperone-procedure]).} +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].} + @defproc[(impersonator-ephemeron [v any/c]) ephemeron?]{ @@ -183,7 +215,7 @@ of impersonators with respect to wrapping impersonators to be detected within [orig-proc (or/c struct-accessor-procedure? struct-mutator-procedure? struct-type-property-accessor-procedure?)] - [redirect-proc procedure?] ... ... + [redirect-proc (or/c procedure? #f)] ... ... [prop impersonator-property?] [prop-val any] ... ...) any/c]{ @@ -221,13 +253,21 @@ The protocol for a @racket[redirect-proc] depends on the corresponding ] +When a @racket[redirect-proc] is @racket[#f], the corresponding +@racket[orig-proc] is unaffected. Supplying @racket[#f] for a +@racket[redirect-proc] is useful to allow its @racket[orig-proc] to +act as a ``witness'' of @racket[v]'s representation and enable the +addition of @racket[prop]s. + Pairs of @racket[prop] and @racket[prop-val] (the number of arguments to @racket[impersonate-struct] must be odd) add impersonator properties or override impersonator-property values of @racket[v]. Each @racket[orig-proc] must indicate a distinct operation. If no @racket[orig-proc]s are supplied, then no @racket[prop]s must be -supplied, and @racket[v] is returned unimpersonated. +supplied. If @racket[orig-proc]s are supplied only with @racket[#f] +@racket[redirect-proc]s and no @racket[prop]s are supplied, then +@racket[v] is returned unimpersonated. If any @racket[orig-proc] is itself an impersonator, then a use of the accessor or mutator that @racket[orig-proc] impersonates is redirected @@ -536,7 +576,7 @@ order of the supplied arguments' keywords.} struct-mutator-procedure? struct-type-property-accessor-procedure? (one-of/c struct-info))] - [redirect-proc procedure?] ... ... + [redirect-proc (or/c procedure? #f)] ... ... [prop impersonator-property?] [prop-val any] ... ...) any/c]{ diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl index f738146e19..2cb96f0fb9 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl @@ -1449,6 +1449,8 @@ ;; ---------------------------------------- (let () + (define-values (prop:blue blue? blue-ref) (make-impersonator-property 'blue)) + (define-values (prop:green green? green-ref) (make-struct-type-property 'green 'can-impersonate)) (define (a-impersonator-of v) (a-x v)) (define a-equal+hash (list (lambda (v1 v2 equal?) @@ -1459,7 +1461,8 @@ (hash (aa-y v2))))) (define (aa-y v) (if (a? v) (a-y v) (pre-a-y v))) (define-struct pre-a (x y) - #:property prop:equal+hash a-equal+hash) + #:property prop:equal+hash a-equal+hash + #:property prop:green 'color) (define-struct a (x y) #:property prop:impersonator-of a-impersonator-of #:property prop:equal+hash a-equal+hash) @@ -1492,6 +1495,27 @@ (err/rt-test (impersonator-of? (make-a-new-impersonator a1 1) a1)) (err/rt-test (impersonator-of? (make-a-new-equal a1 1) a1)) (err/rt-test (equal? (make-a-new-equal a1 1) a1)) + + (define a-pre-a (chaperone-struct (make-pre-a 17 1) pre-a-y (lambda (a v) v))) + (test 1 pre-a-y a-pre-a) + (test #t chaperone-of? a-pre-a a-pre-a) + (test #t chaperone-of? (make-pre-a 17 1) (chaperone-struct (make-pre-a 17 1) pre-a-y #f prop:blue 'color)) + (test #f chaperone-of? (make-pre-a 17 1) (chaperone-struct a-pre-a pre-a-y #f prop:blue 'color)) + (test #t chaperone-of? a-pre-a (chaperone-struct a-pre-a pre-a-y #f prop:blue 'color)) + (test #t chaperone-of? (chaperone-struct a-pre-a pre-a-y #f prop:blue 'color) a-pre-a) + (test #f chaperone-of? a-pre-a (chaperone-struct a-pre-a pre-a-y (lambda (a v) v) prop:blue 'color)) + (test #f chaperone-of? a-pre-a (chaperone-struct a-pre-a green-ref (lambda (a v) v))) + + (define (exn:second-time? e) (and (exn? e) (regexp-match? #rx"same value as" (exn-message e)))) + (err/rt-test (chaperone-struct (make-pre-a 1 2) pre-a-y #f pre-a-y #f) exn:second-time?) + (err/rt-test (chaperone-struct (make-pre-a 1 2) pre-a-y (lambda (a v) v) pre-a-y #f) exn:second-time?) + (err/rt-test (chaperone-struct (make-pre-a 1 2) pre-a-y #f pre-a-y (lambda (a v) v)) exn:second-time?) + + (eq? a-pre-a (chaperone-struct a-pre-a pre-a-y #f)) + (eq? a-pre-a (chaperone-struct a-pre-a green-ref #f)) + + (test #t impersonator-of? (make-pre-a 17 1) (chaperone-struct (make-pre-a 17 1) pre-a-y #f prop:blue 'color)) + (test #f impersonator-of? (make-pre-a 17 1) (chaperone-struct a-pre-a pre-a-y #f prop:blue 'color)) (void))) ;; ---------------------------------------- diff --git a/racket/src/racket/src/bool.c b/racket/src/racket/src/bool.c index fbd653cf3b..3940dc32d6 100644 --- a/racket/src/racket/src/bool.c +++ b/racket/src/racket/src/bool.c @@ -564,6 +564,13 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) if (cmp > -1) return cmp; + if (eql->for_chaperone + && SCHEME_CHAPERONEP(obj2) + && scheme_is_noninterposing_chaperone(obj2)) { + obj2 = ((Scheme_Chaperone *)obj2)->prev; + goto top_after_next; + } + if (eql->for_chaperone && SCHEME_CHAPERONEP(obj1) && (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR) diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 575d5ed4ca..9b9cd8cbc4 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -1023,6 +1023,8 @@ void scheme_chaperone_hash_set(Scheme_Object *table, Scheme_Object *key, Scheme_ Scheme_Object *scheme_chaperone_not_undefined(Scheme_Object *orig_val); +int scheme_is_noninterposing_chaperone(Scheme_Object *obj); + /*========================================================================*/ /* syntax objects */ /*========================================================================*/ diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 8af9585157..364f9fcfde 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -2197,9 +2197,9 @@ static void chaperone_struct_set(const char *who, Scheme_Object *prim, return; } } - } if (SCHEME_VECTORP(px->redirects) - && !(SCHEME_VEC_SIZE(px->redirects) & 1) - && SAME_OBJ(SCHEME_VEC_ELS(px->redirects)[1], scheme_undefined)) { + } else if (SCHEME_VECTORP(px->redirects) + && !(SCHEME_VEC_SIZE(px->redirects) & 1) + && SAME_OBJ(SCHEME_VEC_ELS(px->redirects)[1], scheme_undefined)) { /* chaperone on every field: check that current value is not undefined --- unless check is disabled by a mark (bit it's faster to check for `undefined` before checking the mark) */ @@ -2226,6 +2226,31 @@ void scheme_struct_set(Scheme_Object *sv, int pos, Scheme_Object *v) } } +int scheme_is_noninterposing_chaperone(Scheme_Object *o) +/* Checks whether the immediate impersonator layer for `o` is known to + interpose on no operations (i.e., it's for impersonator properties, + only) */ +{ + Scheme_Chaperone *px = (Scheme_Chaperone *)o; + int i; + + if (!SCHEME_VECTORP(px->redirects)) + return 0; + + if (SCHEME_VEC_SIZE(px->redirects) & 1) + return 0; + + if (SCHEME_TRUEP(SCHEME_VEC_ELS(px->redirects)[0])) + return 0; + + for (i = SCHEME_VEC_SIZE(px->redirects); i-- > PRE_REDIRECTS; ) { + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[i])) + return 0; + } + + return 1; +} + static Scheme_Object **apply_guards(Scheme_Struct_Type *stype, int argc, Scheme_Object **args, int *_chaperone_undefined) { @@ -5714,8 +5739,9 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, Scheme_Object *a[1], *inspector, *getter_positions = scheme_null; int i, offset, arity, non_applicable_op, repeat_op; const char *kind; - Scheme_Hash_Tree *props = NULL, *red_props = NULL, *setter_positions = NULL; + Scheme_Hash_Tree *props = NULL, *red_props = NULL, *empty_red_props = NULL, *setter_positions = NULL; intptr_t field_pos; + int empty_si_chaperone = 0, *empty_redirects = NULL; if (argc == 1) return argv[0]; @@ -5778,7 +5804,7 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, repeat_op = 0; if (offset == -2) { - if (SCHEME_TRUEP(si_chaperone)) + if (SCHEME_TRUEP(si_chaperone) || empty_si_chaperone) scheme_contract_error(name, "struct-info procedure supplied a second time", "procedure", 1, a[0], @@ -5804,10 +5830,9 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, non_applicable_op = 1; arity = 0; } else { - if (!red_props) - red_props = scheme_make_hash_tree(0); - - if (scheme_hash_tree_get(red_props, prop)) + if (red_props && scheme_hash_tree_get(red_props, prop)) + repeat_op = 1; + if (empty_red_props && scheme_hash_tree_get(empty_red_props, prop)) repeat_op = 1; arity = 2; @@ -5821,6 +5846,8 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, non_applicable_op = 1; else if (SCHEME_TRUEP(SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos])) repeat_op = 1; + else if (empty_redirects && empty_redirects[offset + field_pos]) + repeat_op = 1; else { if (is_impersonator) { intptr_t loc_field_pos; @@ -5881,9 +5908,10 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, NULL); proc = argv[i]; - if (!scheme_check_proc_arity(NULL, arity, i, argc, argv)) { - char buf[32]; - sprintf(buf, "(procedure-arity-includes/c %d)", arity); + if (SCHEME_TRUEP(proc) + && !scheme_check_proc_arity(NULL, arity, i, argc, argv)) { + char buf[64]; + sprintf(buf, "(or/c (procedure-arity-includes/c %d) #f)", arity); scheme_contract_error(name, "operation's redirection procedure does not match the expected arity", "given", 1, proc, @@ -5894,8 +5922,8 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, } /* If the operation to chaperone was itself a chaperone, we need to - preserve and use he chaperoned variant of the operation. */ - if (SCHEME_CHAPERONEP(a[0])) { + preserve and use the chaperoned variant of the operation. */ + if (SCHEME_CHAPERONEP(a[0]) && SCHEME_TRUEP(proc)) { Scheme_Chaperone *ppx = (Scheme_Chaperone *)a[0]; if (!is_impersonator && (SCHEME_CHAPERONE_FLAGS(ppx) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) { @@ -5907,12 +5935,30 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, proc = scheme_make_pair(a[0], proc); } - if (prop) - red_props = scheme_hash_tree_set(red_props, prop, proc); - else if (st) - SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos] = proc; - else - si_chaperone = proc; + if (prop) { + if (SCHEME_TRUEP(prop)) { + if (!red_props) + red_props = scheme_make_hash_tree(0); + red_props = scheme_hash_tree_set(red_props, prop, proc); + } else { + if (!empty_red_props) + empty_red_props = scheme_make_hash_tree(0); + empty_red_props = scheme_hash_tree_set(empty_red_props, prop, proc); + } + } else if (st) { + if (SCHEME_TRUEP(proc)) + SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos] = proc; + else { + if (!empty_redirects) + empty_redirects = MALLOC_N_ATOMIC(int, 2 * stype->num_slots); + empty_redirects[offset + field_pos] = 1; + } + } else { + if (SCHEME_TRUEP(proc)) + si_chaperone = proc; + else + empty_si_chaperone = 1; + } } if (is_impersonator) {