equality for `define-cstruct'-generated wrappers

Closes PR 13650

Merge to v5.3.4
(cherry picked from commit 06c42f0887)

collects/ffi/unsafe.rkt

@@ -1339,7 +1339,8 @@
 (provide define-cstruct)
 (define-syntax (define-cstruct stx)
   (define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx 
-                       alignment-stx property-stxes property-binding-stxes)
+                       alignment-stx property-stxes property-binding-stxes
+                       no-equal?)
     (define name
       (cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx)))))
     (define slot-names (map (lambda (x) (symbol->string (syntax-e x)))
@@ -1399,7 +1400,10 @@
                            (lambda () (values #f '() #f #f #f #f #f values))))]
                     [define-wrapper-struct (if (null? property-stxes)
                                                #'(begin)
-                                               (with-syntax ([(prop ...) property-stxes])
+                                               (with-syntax ([(prop ...) property-stxes]
+                                                             [add-equality-property (if no-equal?
+                                                                                        #'values
+                                                                                        #'add-equality-property)])
                                                  #'(define-values (make-wrap-TYPE struct:cpointer:TYPE)
                                                      (let ()
                                                        (define-values (struct:cpointer:TYPE
@@ -1413,12 +1417,13 @@
                                                                                0
                                                                                1)
                                                                            0 #f
+                                                                           (add-equality-property
                                                                             (append
                                                                              (if struct:cpointer:super
                                                                                  null
                                                                                  (list
                                                                                   (cons prop:cpointer 0)))
-                                                                            (list prop ...))
+                                                                             (list prop ...)))
                                                                            (current-inspector)
                                                                            #f
                                                                            (if struct:cpointer:super
@@ -1570,26 +1575,38 @@
                    (syntax-case #'type ()
                      [(t s) (values #'t #'s)]
                      [_ (values #'type #f)])]
-                  [(alignment properties property-bindings)
+                  [(alignment properties property-bindings no-equal?)
-                   (let loop ([more #'more] [alignment #f] [properties null] [property-bindings null])
+                   (let loop ([more #'more] 
+                              [alignment #f]
+                              [properties null] 
+                              [property-bindings null] 
+                              [no-equal? #f])
                      (define (head) (syntax-case more () [(x . _) #'x]))
                      (syntax-case more ()
-                       [() (values alignment (reverse properties) (reverse property-bindings))]
+                       [() (values alignment (reverse properties) (reverse property-bindings) no-equal?)]
                        [(#:alignment) (err "missing expression for #:alignment" (head))]
                        [(#:alignment a . rest) 
                         (not alignment)
-                        (loop #'rest #'a properties property-bindings)]
+                        (loop #'rest #'a properties property-bindings no-equal?)]
+                       [(#:alignment a . rest) 
+                        (err "multiple specifications of #:alignment" (head))]
                        [(#:property) (err "missing property expression for #:property" (head))]
                        [(#:property prop) (err "missing value expression for #:property" (head))]
                        [(#:property prop val . rest)
                         (let ()
                           (define prop-id (car (generate-temporaries '(prop))))
                           (define val-id (car (generate-temporaries '(prop-val))))
-                          (loop #'rest alignment 
+                          (loop #'rest 
+                                alignment 
                                 (list* #`(cons #,prop-id #,val-id) properties)
                                 (list* (list (list val-id) #'val) 
                                        (list (list prop-id) #'(check-is-property prop))
-                                       property-bindings)))]
+                                       property-bindings)
+                                no-equal?))]
+                       [(#:no-equal . rest)
+                        (if no-equal?
+                            (err "multiple specifications of #:no-equal" (head))
+                            (loop #'rest alignment properties property-bindings #t))]
                        [(x . _) (err (if (keyword? (syntax-e #'x))
                                          "unknown keyword" "unexpected form")
                                      #'x)]
@@ -1608,9 +1625,10 @@
                       #`(#,_SUPER slot-type ...)
                       alignment
                       properties
-                      property-bindings)
+                      property-bindings
+                      no-equal?)
          (make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) 
-                      alignment properties property-bindings)))]
+                      alignment properties property-bindings no-equal?)))]
     ;; specific errors for bad slot specs, leave the rest for a generic error
     [(_ type (bad ...) . more)
      (err "bad slot specification, expecting [name ctype]"
@@ -1620,6 +1638,21 @@
      (err "bad slot specification, expecting a sequence of [name ctype]"
           #'bad)]))
 
+;; Add `prop:equal+hash' to use pointer equality
+;; if `props' does not already have `prop:equal+hash'
+;; property:
+(define (add-equality-property props)
+  (if (ormap (lambda (p) (equal? (car p) prop:equal+hash)) props)
+      props
+      (append props
+              (list (cons prop:equal+hash
+                          (list (lambda (a b eql?)
+                                  (ptr-equal? a b))
+                                (lambda (a hsh)
+                                  (hsh (cast a _pointer _pointer)))
+                                (lambda (a hsh)
+                                  (hsh (cast a _pointer _pointer)))))))))
+
 ;; helper for the above: keep runtime information on structs
 (define cstruct-info
   (let ([table (make-weak-hasheq)])

collects/scribblings/foreign/pointers.scrbl

@@ -18,8 +18,9 @@ Compares the values of the two pointers. Two different Racket
 pointer objects can contain the same pointer.
 
 If the values are both pointers that are not represented by
-@racket[#f], a byte string, a callback, or a pointer based on
+@racket[#f], a byte string, a callback, a pointer based on
-@racket[_fpointer], then the @racket[ptr-equal?] comparison is the
+@racket[_fpointer], or a structure with the @racket[prop:cpointer]
+property, then the @racket[ptr-equal?] comparison is the
 same as using @racket[equal?].}
 
 

collects/scribblings/foreign/types.scrbl

@@ -344,7 +344,9 @@ The reference is not traced or updated by the garbage collector.
 
 The @racket[equal?] predicate equates C pointers (including pointers
 for @racket[_gcpointer] and possibly containing an offset) when they
-refer to the same address.}
+refer to the same address---except for C pointers that are instances
+of structure types with the @racket[prop:cpointer] property, in which
+case the equality rules of the relevant structure types apply.}
 
 
 @defthing[_gcpointer ctype?]{
@@ -940,7 +942,8 @@ below for a more efficient approach.}
               [(id/sup _id
                        (_id super-id))
                (property (code:line #:alignment alignment-expr)
-                         (code:line #:property prop-expr val-expr))]]{
+                         (code:line #:property prop-expr val-expr)
+                         #:no-equal)]]{
 
 Defines a new C struct type, but unlike @racket[_list-struct], the
 resulting type deals with C structs in binary form, rather than
@@ -1023,7 +1026,11 @@ specified properties. The wrapper Racket structure also has a
 treated the same as unwrapped C pointers. If a @racket[super-id] is
 provided and it corresponds to a C struct type with a wrapper
 structure type, then the wrapper structure type is a subtype of
-@racket[super-id]'s wrapper structure type.
+@racket[super-id]'s wrapper structure type. If a @racket[#:property]
+modifier is specified, @racket[#:no-equal] is not specified,
+and if @racket[prop:equal+hash] is not specified as any @racket[#:property],
+then the @racket[prop:equal+hash] property is automatically implemented
+for the wrapper structure type to use @racket[ptr-equal?].
 
 If the first field is itself a C struct type, its tag will be used in
 addition to the new tag.  This feature supports common cases of object

collects/scribblings/reference/booleans.scrbl

@@ -238,7 +238,8 @@ non-@racket[#f] value when applied to the structure.
 
 A deprecated @tech{structure type property} (see @secref["structprops"])
 that supplies an equality predicate and hashing functions for a structure
-type. @racket[gen:equal+hash] should be used instead. Accepts a list of
+type. The @racket[gen:equal+hash] @tech{generic interface} should be used,
+instead. A @racket[prop:equal+hash] property value is a list of
 three procedures that correspond to the methods of @racket[gen:equal+hash].
 }
 

collects/tests/racket/cstruct.rktl

@@ -73,9 +73,11 @@
 (syntax-test #'(define-cstruct #f ()))
 (syntax-test #'(define-cstruct _y (y)))
 (syntax-test #'(define-cstruct _y () #:alignment))
+(syntax-test #'(define-cstruct _y () #:alignment 2 #:alignment 2))
 (syntax-test #'(define-cstruct _y () #:property))
 (syntax-test #'(define-cstruct _y () #:property x))
 (syntax-test #'(define-cstruct _y () #:property x y . 10))
+(syntax-test #'(define-cstruct _y () #:no-equal #:no-equal))
 
 ;; ----------------------------------------
 ;; Check struct properties and subtypes:
@@ -100,6 +102,26 @@
   (test #t p? struct:cpointer:W)
   (test #t Z? (ptr-ref (malloc _W) _W)))
 
+;; ----------------------------------------
+;; Check struct properties and equality:
+
+(let ()
+  (define-cstruct _B ([a _int]) 
+    #:property prop:procedure void)
+  
+  (define b (make-B 123))
+  
+  (test #t equal? b (cast b _B-pointer _B-pointer))) ; cast forces new wrapper
+
+(let ()
+  (define-cstruct _B ([a _int]) 
+    #:property prop:procedure void
+    #:no-equal)
+  
+  (define b (make-B 123))
+  
+  (test #f equal? b (cast b _B-pointer _B-pointer))) ; cast forces new wrapper
+
 ;; ----------------------------------------
 
 (report-errs)