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

allow the interposition procedures to all be #f in chaperone-hash-set and impersonate-hash-set

Browse Source
This commit is contained in:
Robby Findler 2015-12-27 21:02:20 -06:00
parent 8f2874e4b5
commit bc12019af4
3 changed files with 71 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -696,9 +696,9 @@ Supported for any @racket[st] that @supp{supports} @racket[set->stream].
} }
@defproc[(impersonate-hash-set [st mutable-set?] @defproc[(impersonate-hash-set [st mutable-set?]
[ref-proc (-> set? any/c any/c)] [ref-proc (or/c #f (-> set? any/c any/c))]
[add-proc (-> set? any/c any/c)] [add-proc (or/c #f (-> set? any/c any/c))]
[remove-proc (-> set? any/c any/c)] [remove-proc (or/c #f (-> set? any/c any/c))]
[clear-proc (or/c #f (-> set? any)) #f] [clear-proc (or/c #f (-> set? any)) #f]
[prop impersonator-property?] [prop impersonator-property?]
[prop-val any/c] ... ...) [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 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 element being removed. The result of the procedure is the element that actually
gets removed from the set. 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 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] 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?)] @defproc[(chaperone-hash-set [st (or/c set? mutable-set?)]
[ref-proc (-> set? any/c any/c)] [ref-proc (or/c #f (-> set? any/c any/c))]
[add-proc (-> set? any/c any/c)] [add-proc (or/c #f (-> set? any/c any/c))]
[remove-proc (-> set? any/c any/c)] [remove-proc (or/c #f (-> set? any/c any/c))]
[clear-proc (or/c #f (-> set? any)) #f] [clear-proc (or/c #f (-> set? any)) #f]
[prop impersonator-property?] [prop impersonator-property?]
[prop-val any/c] ... ...) [prop-val any/c] ... ...)

10
pkgs/racket-test-core/tests/racket/set.rktl
View File

@ -658,4 +658,14 @@
impersonator-prop:p 11)]) impersonator-prop:p 11)])
(test 11 get-impersonator-prop:p s))) (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) (report-errs)

82
racket/collects/racket/private/set-types.rkt
View File

@ -358,19 +358,21 @@
who original new)) who original new))
new) new)
(add-impersonator-properties (add-impersonator-properties
(update-custom-set-table (if ref-proc
s (update-custom-set-table
(chaperone-hash s
(custom-set-table s) (chaperone-hash
(λ (hash key) (custom-set-table s)
(values (check-it 'ref-proc key (ref-proc (update-custom-set-table s hash) key)) (λ (hash key)
(λ (hash key val) val))) (values (check-it 'ref-proc key (ref-proc (update-custom-set-table s hash) key))
(λ (hash key val) (λ (hash key val) val)))
(values (check-it 'add-proc key (add-proc (update-custom-set-table s hash) key)) (λ (hash key val)
val)) (values (check-it 'add-proc key (add-proc (update-custom-set-table s hash) key))
(λ (hash key) (check-it 'remove-proc key (remove-proc (update-custom-set-table s hash) key))) val))
(λ (hash key) (check-it 'ref-proc key (ref-proc (update-custom-set-table s hash) key))) (λ (hash key) (check-it 'remove-proc key (remove-proc (update-custom-set-table s hash) key)))
(and clear-proc (λ (hash) (clear-proc (update-custom-set-table s hash)))))) (λ (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)) prop-args))
(define (impersonate-hash-set s (define (impersonate-hash-set s
@ -387,15 +389,18 @@
remove-proc remove-proc
clear-proc+props)) clear-proc+props))
(add-impersonator-properties (add-impersonator-properties
(update-custom-set-table (if ref-proc
s (update-custom-set-table
(impersonate-hash s
(custom-set-table s) (impersonate-hash
(λ (hash key) (values (ref-proc (update-custom-set-table s hash) key) (λ (hash key val) val))) (custom-set-table s)
(λ (hash key val) (values (add-proc (update-custom-set-table s hash) key) val)) (λ (hash key) (values (ref-proc (update-custom-set-table s hash) key)
(λ (hash key) (remove-proc (update-custom-set-table s hash) key)) (λ (hash key val) val)))
(λ (hash key) (ref-proc (update-custom-set-table s hash) key)) (λ (hash key val) (values (add-proc (update-custom-set-table s hash) key) val))
(and clear-proc (λ (hash) (clear-proc (update-custom-set-table s hash)))))) (λ (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)) prop-args))
(define (add-impersonator-properties without-props prop-args) (define (add-impersonator-properties without-props prop-args)
@ -425,24 +430,34 @@
'(or/c set-mutable? set-weak?) '(or/c set-mutable? set-weak?)
'(or/c set? set-mutable? set-weak?))) '(or/c set? set-mutable? set-weak?)))
0 s ref-proc add-proc clear-proc+props)) 0 s ref-proc add-proc clear-proc+props))
(unless (and (procedure? ref-proc) (unless (or (not ref-proc)
(procedure-arity-includes? ref-proc 2)) (and (procedure? ref-proc)
(procedure-arity-includes? ref-proc 2)))
(apply raise-argument-error (apply raise-argument-error
who who
"(procedure-arity-includes/c 2)" "(or/c #f (procedure-arity-includes/c 2))"
1 s ref-proc add-proc clear-proc+props)) 1 s ref-proc add-proc clear-proc+props))
(unless (and (procedure? add-proc) (unless (or (not add-proc)
(procedure-arity-includes? add-proc 2)) (and (procedure? add-proc)
(procedure-arity-includes? add-proc 2)))
(apply raise-argument-error (apply raise-argument-error
who who
"(procedure-arity-includes/c 2)" "(or/c #f (procedure-arity-includes/c 2))"
2 s ref-proc add-proc clear-proc+props)) 2 s ref-proc add-proc clear-proc+props))
(unless (and (procedure? remove-proc) (unless (or (not remove-proc)
(procedure-arity-includes? remove-proc 2)) (and (procedure? remove-proc)
(procedure-arity-includes? remove-proc 2)))
(apply raise-argument-error (apply raise-argument-error
who who
"(procedure-arity-includes/c 2)" "(or/c #f (procedure-arity-includes/c 2))"
3 s ref-proc add-proc clear-proc+props)) 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 (null? clear-proc+props)
(unless (or (not (car clear-proc+props)) (unless (or (not (car clear-proc+props))
(and (procedure? (car clear-proc+props)) (and (procedure? (car clear-proc+props))
@ -472,6 +487,11 @@
"impersonator-property?" "impersonator-property?"
(+ i (if supplied-clear-proc? 1 0) 4) (+ i (if supplied-clear-proc? 1 0) 4)
s ref-proc add-proc clear-proc+props))) 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)) (values clear-proc args))
(define (set-check-compatible name s1 s2) (define (set-check-compatible name s1 s2)