From bc12019af417bc54664479ba5994924c75e79b8e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 27 Dec 2015 21:02:20 -0600 Subject: [PATCH] allow the interposition procedures to all be #f in chaperone-hash-set and impersonate-hash-set --- .../scribblings/reference/sets.scrbl | 16 ++-- pkgs/racket-test-core/tests/racket/set.rktl | 10 +++ racket/collects/racket/private/set-types.rkt | 82 ++++++++++++------- 3 files changed, 71 insertions(+), 37 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/sets.scrbl b/pkgs/racket-doc/scribblings/reference/sets.scrbl index 966eb7238e..03b10fd6ae 100644 --- a/pkgs/racket-doc/scribblings/reference/sets.scrbl +++ b/pkgs/racket-doc/scribblings/reference/sets.scrbl @@ -696,9 +696,9 @@ Supported for any @racket[st] that @supp{supports} @racket[set->stream]. } @defproc[(impersonate-hash-set [st mutable-set?] - [ref-proc (-> set? any/c any/c)] - [add-proc (-> set? any/c any/c)] - [remove-proc (-> set? any/c any/c)] + [ref-proc (or/c #f (-> set? any/c any/c))] + [add-proc (or/c #f (-> set? any/c any/c))] + [remove-proc (or/c #f (-> set? any/c any/c))] [clear-proc (or/c #f (-> set? any)) #f] [prop impersonator-property?] [prop-val any/c] ... ...) @@ -718,6 +718,10 @@ Supported for any @racket[st] that @supp{supports} @racket[set->stream]. from @racket[st]. Its first argument is the set and its second argument is the element being removed. The result of the procedure is the element that actually gets removed from the set. + + If any of the @racket[ref-proc], @racket[add-proc], or @racket[remove-proc] arguments + is @racket[#f], then all three must be and there must be at least one property supplied. + In that case, a more efficient chaperone wrapper is created. If @racket[clear-proc] is not @racket[#f], it must accept @racket[set] as an argument and is result is ignored. The fact that @racket[clear-proc] @@ -734,9 +738,9 @@ Supported for any @racket[st] that @supp{supports} @racket[set->stream]. } @defproc[(chaperone-hash-set [st (or/c set? mutable-set?)] - [ref-proc (-> set? any/c any/c)] - [add-proc (-> set? any/c any/c)] - [remove-proc (-> set? any/c any/c)] + [ref-proc (or/c #f (-> set? any/c any/c))] + [add-proc (or/c #f (-> set? any/c any/c))] + [remove-proc (or/c #f (-> set? any/c any/c))] [clear-proc (or/c #f (-> set? any)) #f] [prop impersonator-property?] [prop-val any/c] ... ...) diff --git a/pkgs/racket-test-core/tests/racket/set.rktl b/pkgs/racket-test-core/tests/racket/set.rktl index 2965ec0e7b..6270e66779 100644 --- a/pkgs/racket-test-core/tests/racket/set.rktl +++ b/pkgs/racket-test-core/tests/racket/set.rktl @@ -658,4 +658,14 @@ impersonator-prop:p 11)]) (test 11 get-impersonator-prop:p s))) +(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p) + (make-impersonator-property 'p)]) + (let ([s (chaperone-hash-set (set) #f #f #f impersonator-prop:p 11)]) + (test #t has-impersonator-prop:p? s))) + +(let-values ([(impersonator-prop:p has-impersonator-prop:p? get-impersonator-prop:p) + (make-impersonator-property 'p)]) + (let ([s (impersonate-hash-set (mutable-set) #f #f #f impersonator-prop:p 11)]) + (test 11 get-impersonator-prop:p s))) + (report-errs) diff --git a/racket/collects/racket/private/set-types.rkt b/racket/collects/racket/private/set-types.rkt index 222ef87996..4a0539060d 100644 --- a/racket/collects/racket/private/set-types.rkt +++ b/racket/collects/racket/private/set-types.rkt @@ -358,19 +358,21 @@ who original new)) new) (add-impersonator-properties - (update-custom-set-table - s - (chaperone-hash - (custom-set-table s) - (λ (hash key) - (values (check-it 'ref-proc key (ref-proc (update-custom-set-table s hash) key)) - (λ (hash key val) val))) - (λ (hash key val) - (values (check-it 'add-proc key (add-proc (update-custom-set-table s hash) key)) - val)) - (λ (hash key) (check-it 'remove-proc key (remove-proc (update-custom-set-table s hash) key))) - (λ (hash key) (check-it 'ref-proc key (ref-proc (update-custom-set-table s hash) key))) - (and clear-proc (λ (hash) (clear-proc (update-custom-set-table s hash)))))) + (if ref-proc + (update-custom-set-table + s + (chaperone-hash + (custom-set-table s) + (λ (hash key) + (values (check-it 'ref-proc key (ref-proc (update-custom-set-table s hash) key)) + (λ (hash key val) val))) + (λ (hash key val) + (values (check-it 'add-proc key (add-proc (update-custom-set-table s hash) key)) + val)) + (λ (hash key) (check-it 'remove-proc key (remove-proc (update-custom-set-table s hash) key))) + (λ (hash key) (check-it 'ref-proc key (ref-proc (update-custom-set-table s hash) key))) + (and clear-proc (λ (hash) (clear-proc (update-custom-set-table s hash)))))) + s) prop-args)) (define (impersonate-hash-set s @@ -387,15 +389,18 @@ remove-proc clear-proc+props)) (add-impersonator-properties - (update-custom-set-table - s - (impersonate-hash - (custom-set-table s) - (λ (hash key) (values (ref-proc (update-custom-set-table s hash) key) (λ (hash key val) val))) - (λ (hash key val) (values (add-proc (update-custom-set-table s hash) key) val)) - (λ (hash key) (remove-proc (update-custom-set-table s hash) key)) - (λ (hash key) (ref-proc (update-custom-set-table s hash) key)) - (and clear-proc (λ (hash) (clear-proc (update-custom-set-table s hash)))))) + (if ref-proc + (update-custom-set-table + s + (impersonate-hash + (custom-set-table s) + (λ (hash key) (values (ref-proc (update-custom-set-table s hash) key) + (λ (hash key val) val))) + (λ (hash key val) (values (add-proc (update-custom-set-table s hash) key) val)) + (λ (hash key) (remove-proc (update-custom-set-table s hash) key)) + (λ (hash key) (ref-proc (update-custom-set-table s hash) key)) + (and clear-proc (λ (hash) (clear-proc (update-custom-set-table s hash)))))) + s) prop-args)) (define (add-impersonator-properties without-props prop-args) @@ -425,24 +430,34 @@ '(or/c set-mutable? set-weak?) '(or/c set? set-mutable? set-weak?))) 0 s ref-proc add-proc clear-proc+props)) - (unless (and (procedure? ref-proc) - (procedure-arity-includes? ref-proc 2)) + (unless (or (not ref-proc) + (and (procedure? ref-proc) + (procedure-arity-includes? ref-proc 2))) (apply raise-argument-error who - "(procedure-arity-includes/c 2)" + "(or/c #f (procedure-arity-includes/c 2))" 1 s ref-proc add-proc clear-proc+props)) - (unless (and (procedure? add-proc) - (procedure-arity-includes? add-proc 2)) + (unless (or (not add-proc) + (and (procedure? add-proc) + (procedure-arity-includes? add-proc 2))) (apply raise-argument-error who - "(procedure-arity-includes/c 2)" + "(or/c #f (procedure-arity-includes/c 2))" 2 s ref-proc add-proc clear-proc+props)) - (unless (and (procedure? remove-proc) - (procedure-arity-includes? remove-proc 2)) + (unless (or (not remove-proc) + (and (procedure? remove-proc) + (procedure-arity-includes? remove-proc 2))) (apply raise-argument-error who - "(procedure-arity-includes/c 2)" + "(or/c #f (procedure-arity-includes/c 2))" 3 s ref-proc add-proc clear-proc+props)) + (when (or (not ref-proc) (not add-proc) (not remove-proc)) + (unless (and (not ref-proc) (not add-proc) (not remove-proc)) + (raise-arguments-error who + "if one of ref-proc, add-proc, or remove-proc is #f, they must all be" + "ref-proc" ref-proc + "add-proc" add-proc + "remove-proc" remove-proc))) (unless (null? clear-proc+props) (unless (or (not (car clear-proc+props)) (and (procedure? (car clear-proc+props)) @@ -472,6 +487,11 @@ "impersonator-property?" (+ i (if supplied-clear-proc? 1 0) 4) s ref-proc add-proc clear-proc+props))) + (unless ref-proc + (when (null? args) + (raise-arguments-error + who + "when ref-proc, add-proc, and remove-proc are #f, at least one property must be supplied"))) (values clear-proc args)) (define (set-check-compatible name s1 s2)