Merge pull request #151 from mflatt/equal+hash

add record-equal+hash
original commit: 20ee3aea2e554ea0f6d07fbe4ed39501138656e9

LOG

@@ -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

csug/objects.stex

@@ -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.

mats/record.ms

@@ -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?

s/5_1.ss

@@ -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)])

s/newhash.ss

@@ -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))))))
 )

s/primdata.ss

@@ -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])