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

Merge pull request #151 from mflatt/equal+hash

Browse Source 
add record-equal+hash
original commit: 20ee3aea2e554ea0f6d07fbe4ed39501138656e9
This commit is contained in:
R. Kent Dybvig 2017-03-24 10:42:01 -04:00 committed by GitHub
commit 1fab28ca11
6 changed files with 633 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
LOG
View File

@ -419,3 +419,10 @@
occupy up to 1/2 of virtual memory, strings and fxvectors 1/4,
and bytevectors 1/8.
cmacros.ss
- added record-type-equal-procedure, record-type-hash-procedure,
record-equal-procedure, and record-hash-procedure to enable
per-type customization of the behavior of equal? and equal-hash
for a record value
5_1.ss, newhash.ss, primdata.ss,
record.ms, root-experr*,
objects.stex

206
csug/objects.stex
View File

@ -2260,6 +2260,208 @@ requires a nongenerative clause.
The default value is \scheme{#f}.
The lead-in above describes why one might want to set this to \scheme{#t}.
\section{Record Equality and Hashing\label{SECTRECORDEQUALTYANDHASHING}}
\index{record equality}\index{\scheme{equal?} on records}%
By default, the \index{\scheme{equal?}}\scheme{equal?} primitive
compares record instances using \scheme{eq?}, i.e., it distinguishes
non-eq? instances even if they are of the same type and have equal
contents.
A program can override this behavior for instances of a
record type (and its subtypes that do not have their own equality
procedures) by using
\index{\scheme{record-type-equal-procedure}}\scheme{record-type-equal-procedure}
to associate an equality procedure with the record-type descriptor
(\var{rtd}) that describes the record type.
When comparing two eq? instances, \scheme{equal?} always returns
\scheme{#t}.
When comparing two non-eq? instances that share an equality procedure
\var{equal-proc}, \scheme{equal?} uses \var{equal-proc} to compare
the instances.
Two instances \var{x} and \var{y} share an equality procedure if
they inherit an equality procedure from the same point in the inheritance
chain, i.e., if
\index{\scheme{record-equal-procedure}}\scheme{(record-equal-procedure \var{x} \var{y})}
returns a procedure (\var{equal-proc}) rather
than \scheme{#f}.
\var{equal?} passes \var{equal-proc} three arguments: the two
instances plus a \var{eql?} procedure that should be used for
recursive comparison of values within the two instances.
Use of \var{eql?} for recursive comparison is necessary to allow
comparison of potentially cyclic structure.
When comparing two non-eq? instances that do not share an equality
procedure, \scheme{equal?} returns \scheme{#f}.
\index{record hashing}\index{\scheme{equal-hash} on records}%
Similarly, when the \index{\scheme{equal-hash}}\scheme{equal-hash}
primitive hashes a record instance, it defaults to a value that is
independent of the record type and contents of the instance.
A program can override this behavior for instances of a
record type by using \index{\scheme{record-type-hash-procedure}}\scheme{record-type-hash-procedure}
to associate a hash procedure with the record-type descriptor (\var{rtd})
that describes the record type.
The procedure \index{\scheme{record-hash-procedure}}\scheme{record-hash-procedure} can be used to find
the hash procedure for a given record instance, following the inheritance
chain.
\var{equal-hash} passes \var{hash-proc} two arguments: the
instance plus a \var{hash} procedure that should be used for
recursive hashing of values within the instance.
Use of \var{hash} for recursive hashing is necessary to allow
hashing of potentially cyclic structure.
The following example illustrates the setting of equality and hash
procedures.
\schemedisplay
(define-record-type marble
(nongenerative)
(fields color quality))
(record-type-equal-procedure (record-type-descriptor marble)) ;=> #f
(equal? (make-marble 'blue 'medium) (make-marble 'blue 'medium)) ;=> #f
(equal? (make-marble 'blue 'medium) (make-marble 'blue 'high)) ;=> #f
; Treat marbles as equal when they have the same color
(record-type-equal-procedure (record-type-descriptor marble)
(lambda (m1 m2 eql?)
(eql? (marble-color m1) (marble-color m2))))
(record-type-hash-procedure (record-type-descriptor marble)
(lambda (m hash)
(hash (marble-color m))))
(equal? (make-marble 'blue 'medium) (make-marble 'blue 'high)) ;=> #t
(equal? (make-marble 'red 'high) (make-marble 'blue 'high)) ;=> #f
(define ht (make-hashtable equal-hash equal?))
(hashtable-set! ht (make-marble 'blue 'medium) "glass")
(hashtable-ref ht (make-marble 'blue 'high) #f) ;=> "glass"
(define-record-type shooter
(nongenerative)
(parent marble)
(fields size))
(equal? (make-marble 'blue 'medium) (make-shooter 'blue 'large 17)) ;=> #t
(equal? (make-shooter 'blue 'large 17) (make-marble 'blue 'medium)) ;=> #t
(hashtable-ref ht (make-shooter 'blue 'high 17) #f) ;=> "glass"
\endschemedisplay
This example illustrates the application of equality and hash procedures
to cyclic record structures.
\schemedisplay
(define-record-type node
(nongenerative)
(fields (mutable left) (mutable right)))
(record-type-equal-procedure (record-type-descriptor node)
(lambda (x y e?)
(and
(e? (node-left x) (node-left y))
(e? (node-right x) (node-right y)))))
(record-type-hash-procedure (record-type-descriptor node)
(lambda (x hash)
(+ (hash (node-left x)) (hash (node-right x)) 23)))
(define graph1
(let ([x (make-node "a" (make-node #f "b"))])
(node-left-set! (node-right x) x)
x))
(define graph2
(let ([x (make-node "a" (make-node (make-node "a" #f) "b"))])
(node-right-set! (node-left (node-right x)) (node-right x))
x))
(define graph3
(let ([x (make-node "a" (make-node #f "c"))])
(node-left-set! (node-right x) x)
x))
(equal? graph1 graph2) ;=> #t
(equal? graph1 graph3) ;=> #f
(equal? graph2 graph3) ;=> #f
(define h (make-hashtable equal-hash equal?))
(hashtable-set! h graph1 #t)
(hashtable-ref h graph1 #f) ;=> #t
(hashtable-ref h graph2 #f) ;=> #t
(hashtable-ref h graph3 #f) ;=> #f
\endschemedisplay
\entryheader
\formdef{record-type-equal-procedure}{\categoryprocedure}{(record-type-equal-procedure \var{rtd} \var{equal-proc})}
\returns unspecified
\formdef{record-type-equal-procedure}{\categoryprocedure}{(record-type-equal-procedure \var{rtd})}
\returns equality procedure associated with \var{rtd}, if any, otherwise \scheme{#f}
\listlibraries
\endentryheader
\noindent
In the first form, \var{equal-proc} must be a procedure or \scheme{#f}.
If \var{equal-proc} is a procedure, a new association between
\var{rtd} and \var{equal-proc} is established, replacing any existing
such association.
If \var{equal-proc} is \scheme{#f}, any existing association between
\var{rtd} and an equality procedure is dropped.
In the second form, \scheme{record-type-equal-procedure} returns
the equality procedure associated with \var{rtd}, if any, otherwise \scheme{#f}.
When changing a record type's equality procedure, the record type's
hash procedure, if any, should be updated if necessary to maintain
the property that it produces the same hash value for any two
instances the equality procedure considers equal.
\entryheader
\formdef{record-equal-procedure}{\categoryprocedure}{(record-equal-procedure \var{record_1} \var{record_2})}
\returns the shared equality procedure for \var{record_1} and \var{record_2}, if there is one, otherwise \scheme{#f}
\listlibraries
\endentryheader
\noindent
\scheme{record-equal-procedure} traverses the inheritance chains
for both record instances in an attempt to find the most specific
type for each that is associated with an equality procedure, if any.
If such type is found and is the same for both instances, the
equality procedure associated with the type is returned.
Otherwise, \scheme{#f} is returned.
\entryheader
\formdef{record-type-hash-procedure}{\categoryprocedure}{(record-type-hash-procedure \var{rtd} \var{hash-proc})}
\returns unspecified
\formdef{record-type-hash-procedure}{\categoryprocedure}{(record-type-hash-procedure \var{rtd})}
\returns hash procedure associated with \var{rtd}, if any, otherwise \scheme{#f}
\listlibraries
\endentryheader
\noindent
In the first form, \var{hash-proc} must be a procedure or \scheme{#f}.
If \var{hash-proc} is a procedure, a new association between
\var{rtd} and \var{hash-proc} is established, replacing any existing
such association.
If \var{hash-proc} is \scheme{#f}, any existing association between
\var{rtd} and a hash procedure is dropped.
In the second form, \scheme{record-type-hash-procedure} returns
the hash procedure associated with \var{rtd}, if any, otherwise \scheme{#f}.
A record type's hash procedure should produce the same hash value
for any two instances the record type's equality procedure considers
equal.
\entryheader
\formdef{record-hash-procedure}{\categoryprocedure}{(record-hash-procedure \var{record})}
\returns the hash procedure for \var{record}, if there is one, otherwise \scheme{#f}
\listlibraries
\endentryheader
\noindent
\scheme{record-hash-procedure} traverses the inheritance chain
for the record instance in an attempt to find the most specific
type that is associated with a hash procedure, if any.
If such type is found, the hash procedure associated with the type
is returned.
Otherwise, \scheme{#f} is returned.
\section{Legacy Record Types\label{SECTCSV7RECORDS}}
@ -2423,7 +2625,7 @@ Otherwise, it is a gensym whose ``pretty'' name
\scheme{define-record} or \scheme{make-record-type}.
The default printing of records of a given type may be overridden
with \var{record-writer}.
with \scheme{record-writer}.
The default syntax may be used as input to the reader as well, as long
as the corresponding record type has already been defined in the Scheme
@ -2792,7 +2994,7 @@ contexts where they are recognized as auxiliary keywords.
\noindent
\var{name} must name a record type defined by \scheme{define-record}
of \scheme{define-record-type}.
or \scheme{define-record-type}.
This form is equivalent to the Revised$^6$ Report
\scheme{record-type-descriptor} form.

251
mats/record.ms
View File

@ -2883,6 +2883,257 @@
(equal? (format "~s" x) "#0=(#0# . 4)"))))
)
(mat record-equal/hash
(begin
(define (equiv? v1 v2)
(and (equal? v1 v2)
(= (equal-hash v1) (equal-hash v2))
(let ([ht (make-hashtable equal-hash equal?)])
(hashtable-set! ht v1 "yes")
(equal? "yes" (hashtable-ref ht v2 "no")))))
(define (not-equiv? v1 v2)
(and (not (equal? v1 v2))
(let ([ht (make-hashtable equal-hash equal?)])
(hashtable-set! ht v1 "yes")
(equal? "no" (hashtable-ref ht v2 "no")))))
(define-record-type E+H$a
(fields (mutable x)
(immutable y)))
(define-record-type E+H$a+
(parent E+H$a)
(fields (mutable z)))
(define-record-type E+H$b
(fields (immutable x)
(mutable y))
(opaque #t))
(define-record-type E+H$b+
(parent E+H$b)
(fields (mutable z))
(opaque #t))
(define (E+H$a-equal? a1 a2 eql?)
(eql? (E+H$a-x a1) (E+H$a-x a2)))
(define (E+H$a-hash a hc)
(hc (E+H$a-x a)))
(define (E+H$b-equal? b1 b2 eql?)
(eql? (E+H$b-y b1) (E+H$b-y b2)))
(define (E+H$b-hash b hc)
(hc (E+H$b-y b)))
(define cyclic-E+H$a1 (make-E+H$a 1 2))
(E+H$a-x-set! cyclic-E+H$a1 cyclic-E+H$a1)
(define cyclic-E+H$a2 (make-E+H$a 1 2))
(E+H$a-x-set! cyclic-E+H$a2 cyclic-E+H$a2)
(define cyclic-E+H$b+1 (make-E+H$b+ 1 2 3))
(define cyclic-E+H$b+2 (make-E+H$b+ 1 2 3))
(E+H$b-y-set! cyclic-E+H$b+1 (list 1 2 3 (box cyclic-E+H$b+2)))
(E+H$b-y-set! cyclic-E+H$b+2 (list 1 2 3 (box cyclic-E+H$b+1)))
#t)
(not-equiv? (make-E+H$a 1 2) (make-E+H$a 1 2))
(not-equiv? (make-E+H$b 1 2) (make-E+H$b 1 2))
(not (record-type-equal-procedure (record-type-descriptor E+H$a)))
(not (record-type-hash-procedure (record-type-descriptor E+H$a)))
(not (record-type-equal-procedure (record-type-descriptor E+H$a+)))
(not (record-type-hash-procedure (record-type-descriptor E+H$a+)))
(not (record-type-equal-procedure (record-type-descriptor E+H$b+)))
(not (record-type-hash-procedure (record-type-descriptor E+H$b+)))
(not (record-type-equal-procedure (record-type-descriptor E+H$b)))
(not (record-type-hash-procedure (record-type-descriptor E+H$b)))
(begin
(record-type-equal-procedure (record-type-descriptor E+H$a) E+H$a-equal?)
(record-type-hash-procedure (record-type-descriptor E+H$a) E+H$a-hash)
#t)
(eq? (record-type-equal-procedure (record-type-descriptor E+H$a)) E+H$a-equal?)
(eq? (record-type-hash-procedure (record-type-descriptor E+H$a)) E+H$a-hash)
(not (record-type-equal-procedure (record-type-descriptor E+H$a+)))
(not (record-type-hash-procedure (record-type-descriptor E+H$a+)))
(eq? (record-equal-procedure (make-E+H$a 1 2) (make-E+H$a 1 2)) E+H$a-equal?)
(eq? (record-equal-procedure (make-E+H$a+ 1 3 5) (make-E+H$a 1 2)) E+H$a-equal?)
(eq? (record-equal-procedure (make-E+H$a 1 2) (make-E+H$a+ 1 3 5)) E+H$a-equal?)
(eq? (record-equal-procedure (make-E+H$a+ 1 3 5) (make-E+H$a+ 1 3 5)) E+H$a-equal?)
(eq? (record-hash-procedure (make-E+H$a 1 2)) E+H$a-hash)
(eq? (record-hash-procedure (make-E+H$a+ 1 3 5)) E+H$a-hash)
(not (record-type-equal-procedure (record-type-descriptor E+H$a+)))
(not (record-type-hash-procedure (record-type-descriptor E+H$a+)))
(equiv? (make-E+H$a 1 2) (make-E+H$a 1 2))
(equiv? (make-E+H$a 1 2) (make-E+H$a 1 3))
(equiv? (make-E+H$a 1 2) (make-E+H$a+ 1 3 5))
(equiv? (make-E+H$a+ 1 3 5) (make-E+H$a 1 2))
(not-equiv? (make-E+H$a+ 2 3 5) (make-E+H$a 1 2))
(not-equiv? (make-E+H$a+ 2 3 5) (make-E+H$a+ 1 2 4))
(not (equiv? (make-E+H$a 1 2) (make-E+H$b 1 2)))
(not-equiv? (make-E+H$b 1 2) (make-E+H$b 1 2))
(not-equiv? (make-E+H$b+ 1 2 3) (make-E+H$b+ 1 2 3))
(not (record-type-equal-procedure (record-type-descriptor E+H$b+)))
(not (record-type-hash-procedure (record-type-descriptor E+H$b+)))
(not (record-type-equal-procedure (record-type-descriptor E+H$b)))
(not (record-type-hash-procedure (record-type-descriptor E+H$b)))
(begin
(record-type-equal-procedure (record-type-descriptor E+H$b+) E+H$b-equal?)
(record-type-hash-procedure (record-type-descriptor E+H$b+) E+H$b-hash)
#t)
(not-equiv? (make-E+H$b 1 2) (make-E+H$b 1 2))
(equiv? (make-E+H$b+ 0 2 4) (make-E+H$b+ 1 2 3))
(equiv? cyclic-E+H$a1 cyclic-E+H$a2)
(equiv? cyclic-E+H$a1 (make-E+H$a cyclic-E+H$a2 3))
(equiv? cyclic-E+H$b+1 cyclic-E+H$b+2)
(begin
(record-type-equal-procedure (record-type-descriptor E+H$a+) E+H$a-equal?)
(record-type-hash-procedure (record-type-descriptor E+H$a+) E+H$a-hash)
#t)
(eq? (record-type-equal-procedure (record-type-descriptor E+H$a)) E+H$a-equal?)
(eq? (record-type-hash-procedure (record-type-descriptor E+H$a)) E+H$a-hash)
(equiv? (make-E+H$a+ 1 2 4) (make-E+H$a+ 1 3 5))
(not-equiv? (make-E+H$a+ 1 3 5) (make-E+H$a 1 2))
(not-equiv? (make-E+H$a 1 2) (make-E+H$a+ 1 3 5))
(begin
(record-type-equal-procedure (record-type-descriptor E+H$a) E+H$a-equal?)
(record-type-hash-procedure (record-type-descriptor E+H$a) E+H$a-hash)
#t)
(not (record-equal-procedure (make-E+H$a+ 1 3 5) (make-E+H$a 1 2)))
(equiv? (make-E+H$a+ 1 2 4) (make-E+H$a+ 1 3 5))
(not-equiv? (make-E+H$a+ 1 3 5) (make-E+H$a 1 2))
(not-equiv? (make-E+H$a 1 2) (make-E+H$a+ 1 3 5))
(begin
(record-type-equal-procedure (record-type-descriptor E+H$a+) #f)
(record-type-hash-procedure (record-type-descriptor E+H$a+) #f)
#t)
(not (record-type-equal-procedure (record-type-descriptor E+H$a+)))
(not (record-type-hash-procedure (record-type-descriptor E+H$a+)))
(eq? (record-equal-procedure (make-E+H$a+ 1 3 5) (make-E+H$a 1 2)) E+H$a-equal?)
(eq? (record-hash-procedure (make-E+H$a+ 1 3 5)) E+H$a-hash)
(equiv? (make-E+H$a+ 1 3 5) (make-E+H$a 1 2))
(equiv? (make-E+H$a 1 2) (make-E+H$a+ 1 3 5))
(equiv? (make-E+H$a+ 1 2 4) (make-E+H$a+ 1 3 5))
(error? ; not an rtd
(record-type-equal-procedure 7))
(error? ; not an rtd
(record-type-equal-procedure 7 (lambda (x y e?) #f)))
(error? ; not a procedure or #f
(record-type-equal-procedure (record-type-descriptor E+H$a+) 7))
(error? ; not an rtd
(record-type-hash-procedure 7))
(error? ; not an rtd
(record-type-hash-procedure 7 (lambda (x y e?) #f)))
(error? ; not a procedure or #f
(record-type-hash-procedure (record-type-descriptor E+H$a+) 7))
(error? ; not a record
(record-equal-procedure 7 (make-E+H$a 1 2)))
(error? ; not a record
(record-equal-procedure (make-E+H$a 1 2) 7))
(error? ; not a record
(record-hash-procedure 7))
; csug examples
(begin
(define-record marble (color quality))
#t)
(not (record-type-equal-procedure (record-type-descriptor marble)))
(not (equal? (make-marble 'blue 'medium) (make-marble 'blue 'medium)))
(not (equal? (make-marble 'blue 'medium) (make-marble 'blue 'high)))
; Treat marbles as equal when they have the same color
(begin
(record-type-equal-procedure (record-type-descriptor marble)
(lambda (m1 m2 eql?)
(eql? (marble-color m1) (marble-color m2))))
(record-type-hash-procedure (record-type-descriptor marble)
(lambda (m hash)
(hash (marble-color m))))
#t)
(equal? (make-marble 'blue 'medium) (make-marble 'blue 'high))
(not (equal? (make-marble 'red 'high) (make-marble 'blue 'high)))
(begin
(define ht (make-hashtable equal-hash equal?))
(hashtable-set! ht (make-marble 'blue 'medium) "glass")
#t)
(equal? (hashtable-ref ht (make-marble 'blue 'high) #f) "glass")
(begin
(define-record shooter marble (size))
#t)
(equal? (make-marble 'blue 'medium) (make-shooter 'blue 'large 17)) ;=> #t
(equal? (make-shooter 'blue 'large 17) (make-marble 'blue 'medium)) ;=> #t
(equal? (hashtable-ref ht (make-shooter 'blue 'high 17) #f) "glass")
(begin
(define-record-type node
(nongenerative)
(fields (mutable left) (mutable right)))
(record-type-equal-procedure (record-type-descriptor node)
(lambda (x y e?)
(and
(e? (node-left x) (node-left y))
(e? (node-right x) (node-right y)))))
(record-type-hash-procedure (record-type-descriptor marble)
(lambda (x hash)
(+ (hash (node-left x)) (hash (node-right x)) 23)))
(define graph1
(let ([x (make-node "a" (make-node #f "b"))])
(node-left-set! (node-right x) x)
x))
(define graph2
(let ([x (make-node "a" (make-node (make-node "a" #f) "b"))])
(node-right-set! (node-left (node-right x)) (node-right x))
x))
(define graph3
(let ([x (make-node "a" (make-node #f "c"))])
(node-left-set! (node-right x) x)
x))
#t)
(equal? graph1 graph2)
(not (equal? graph1 graph3))
(not (equal? graph2 graph3))
(begin
(define h (make-hashtable equal-hash equal?))
(hashtable-set! h graph1 #t)
#t)
(hashtable-ref h graph1 #f)
(hashtable-ref h graph2 #f)
(not (hashtable-ref h graph3 #f))
)
(mat record19
; test ellipses in init expressions
(equal?

46
s/5_1.ss
View File

@ -160,6 +160,23 @@
(if (union-find ht x y)
0
(e? (unbox x) (unbox y) (fx- k 1))))]
[($record? x)
(and ($record? y)
(let ([rec-equal? ($record-equal-procedure x y)])
(and rec-equal?
(if (union-find ht x y)
0
(let ([next-k k] [decr 1])
(and (rec-equal? x y
(lambda (x1 y1)
; decrementing only on first subfield, if any, like vectors and pairs
(let ([k (e? x1 y1 (fx- next-k decr))])
(and k
(begin
(set! next-k k)
(set! decr 0)
#t)))))
next-k))))))]
[else (and (eqv? x y) k)]))
(define (fast? x y k)
(let ([k (fx- k 1)])
@ -198,6 +215,19 @@
(and (fx= (fxvector-ref x i) (fxvector-ref y i))
(f (fx1- i))))))]
[(box? x) (and (box? y) (e? (unbox x) (unbox y) k))]
[($record? x)
(and ($record? y)
(let ([rec-equal? ($record-equal-procedure x y)])
(and rec-equal?
(let ([next-k k])
(and (rec-equal? x y
(lambda (x1 y1)
(let ([k (e? x1 y1 next-k)])
(and k
(begin
(set! next-k k)
#t)))))
next-k)))))]
[else (and (eqv? x y) k)])))
(and (e? x y k) #t)))
@ -246,6 +276,22 @@
(if (fx<= k 0)
k
(precheck? (unbox x) (unbox y) (fx- k 1))))]
[($record? x)
(and ($record? y)
(let ([rec-equal? ($record-equal-procedure x y)])
(and rec-equal?
(if (fx<= k 0)
k
(let ([next-k k])
(and (rec-equal? x y
(lambda (x1 y1)
; decrementing k for each field, like vectors but unlike pairs
(let ([k (precheck? x1 y1 (fx- next-k 1))])
(and k
(begin
(set! next-k k)
#t)))))
next-k))))))]
[else (and (eqv? x y) k)]))
(let ([k (precheck? x y k0)])

119
s/newhash.ss
View File

@ -914,6 +914,21 @@ Documentation notes:
[(bytevector? x) (values (update hc (bytevector-hash x)) i)]
[(boolean? x) (values (update hc (if x 336200167 307585980)) i)]
[(char? x) (values (update hc (char->integer x)) i)]
[(and ($record? x) ($record-hash-procedure x))
=> (lambda (rec-hash)
(let ([new-i i])
(let ([sub-hc (rec-hash
x
(lambda (v)
(if (fx<= new-i 0)
0
(let-values ([(sub-hc sub-i) (f v 0 i)])
(set! new-i sub-i)
sub-hc))))])
(let ([hc (update hc (if (fixnum? sub-hc)
sub-hc
(modulo (abs sub-hc) (greatest-fixnum))))])
(values hc new-i)))))]
[else (values (update hc 120634730) i)])))
(let-values ([(hc i) (f x 523658599 64)])
(hcabs hc)))))
@ -1023,4 +1038,108 @@ Documentation notes:
(ht-size-set! h 0)
(unless (fx= n minlen)
(ht-vec-set! h ($make-eqhash-vector minlen))))))
(let ()
;; An equal/hash mapping contains an equal or hash procedure (or #f)
;; plus the rtd where the procedure was installed. It also has a weak
;; list of uids for child rtds that have inherited the setting, in
;; case the rtd's setting changes.
(define-record-type equal/hash
(fields maybe-proc rtd (mutable inheritors))
(nongenerative)
(sealed #t)
(protocol
(lambda (new)
(lambda (maybe-proc rtd)
(new maybe-proc rtd '())))))
(let ()
(define (get-equal/hash who rtd key)
(unless (record-type-descriptor? rtd)
($oops who "~s is not a record-type descriptor" rtd))
(let ([e/h ($sgetprop (record-type-uid rtd) key #f)])
(and e/h
(eq? (equal/hash-rtd e/h) rtd)
(equal/hash-maybe-proc e/h))))
(define (set-equal/hash! who rtd key proc)
(unless (record-type-descriptor? rtd)
($oops who "~s is not a record-type descriptor" rtd))
(unless (or (not proc) (procedure? proc))
($oops who "~s is not a procedure or #f" proc))
(with-tc-mutex
(let* ([uid (record-type-uid rtd)]
[old-e/h ($sgetprop uid key #f)])
;; Remove the old record from anywhere that it's inherited,
;; and a later lookup will re-inherit:
(when old-e/h
(for-each
(lambda (uid)
(unless (bwp-object? uid)
(when (eq? ($sgetprop uid key #f) old-e/h)
($sremprop uid key))))
(equal/hash-inheritors old-e/h)))
(if proc
($sputprop uid key (make-equal/hash proc rtd))
($sremprop uid key)))))
(set-who! record-type-equal-procedure
(case-lambda
[(rtd) (get-equal/hash who rtd 'equal-proc)]
[(rtd equal-proc) (set-equal/hash! who rtd 'equal-proc equal-proc)]))
(set-who! record-type-hash-procedure
(case-lambda
[(rtd) (get-equal/hash who rtd 'hash-proc)]
[(rtd hash-proc) (set-equal/hash! who rtd 'hash-proc hash-proc)])))
(let ()
;; Gets an `equal/hash` record for the given rtd, finding
;; it from a parent rtd and caching if necessary:
(define (lookup-equal/hash record key)
(let* ([rtd ($record-type-descriptor record)] [uid (record-type-uid rtd)])
; Get out quick w/o mutex if equal/hash record is present
(or ($sgetprop uid key #f)
(with-tc-mutex
(let f ([uid uid] [rtd rtd])
;; Double-check first time around to avoid a race
(or ($sgetprop uid key #f)
(let ([parent-rtd (record-type-parent rtd)])
(if parent-rtd
;; Cache parent's value, and register as an inheritor:
(let ([e/h (f (record-type-uid parent-rtd) parent-rtd)])
(equal/hash-inheritors-set! e/h (weak-cons uid (equal/hash-inheritors e/h)))
($sputprop uid key e/h)
e/h)
;; Cache an empty `equal/hash` record:
(let ([e/h (make-equal/hash #f rtd)])
($sputprop uid key e/h)
e/h)))))))))
(let ()
(define (lookup-equal-procedure record1 record2)
(let ([e/h (lookup-equal/hash record1 'equal-proc)])
(and e/h
(let ([proc (equal/hash-maybe-proc e/h)])
(and proc
(let ([rtd (equal/hash-rtd e/h)])
(let ([e/h (lookup-equal/hash record2 'equal-proc)])
(and e/h
(eq? (equal/hash-rtd e/h) rtd)
proc))))))))
(set-who! $record-equal-procedure
(lambda (record1 record2)
(lookup-equal-procedure record1 record2)))
(set-who! record-equal-procedure
(lambda (record1 record2)
(unless ($record? record1) ($oops who "~s is not a record" record1))
(unless ($record? record2) ($oops who "~s is not a record" record2))
(lookup-equal-procedure record1 record2))))
(let ()
(define (lookup-hash-procedure record)
(let ([e/h (lookup-equal/hash record 'hash-proc)])
(and e/h (equal/hash-maybe-proc e/h))))
(set-who! $record-hash-procedure
(lambda (record)
(lookup-hash-procedure record)))
(set-who! record-hash-procedure
(lambda (record)
(unless ($record? record) ($oops who "~s is not a record" record))
(lookup-hash-procedure record))))))
)

6
s/primdata.ss
View File

@ -1513,7 +1513,11 @@
(record? [sig [(ptr) (ptr rtd) -> (boolean)]] [flags pure mifoldable discard cp02])
(record-constructor [sig [(sub-ptr) -> (procedure)]] [flags cp02]) ; accepts rtd or rcd
(record-constructor-descriptor? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard cp02])
(record-equal-procedure [sig [(record record) -> (maybe-procedure)]] [flags discard])
(record-hash-procedure [sig [(record) -> (maybe-procedure)]] [flags discard])
(record-reader [sig [(sub-ptr) -> (ptr)] [(sub-ptr sub-ptr) -> (void)]] [flags])
(record-type-equal-procedure [sig [(rtd) -> (maybe-procedure)] [(rtd maybe-procedure) -> (void)]] [flags])
(record-type-hash-procedure [sig [(rtd) -> (maybe-procedure)] [(rtd maybe-procedure) -> (void)]] [flags])
(record-writer [sig [(rtd) -> (maybe-procedure)] [(rtd maybe-procedure) -> (void)]] [flags])
(register-signal-handler [sig [(sint procedure) -> (void)]] [flags])
(remove-foreign-entry [sig [(string) -> (void)]] [flags true])
@ -2098,6 +2102,8 @@
($recompile-importer-path [flags])
($record [flags cp02 unrestricted alloc]) ; first arg should be an rtd, but we don't check
($record? [flags pure mifoldable discard])
($record-equal-procedure [flags discard])
($record-hash-procedure [flags discard])
($record-oops #;[sig [(who sub-ptr rtd) -> (bottom)]] [flags abort-op])
($record-type-descriptor [flags pure mifoldable discard true])
($record-type-field-offsets [flags pure mifoldable discard true])