From e23bcf523fd67c25e69e56eb2da898a9990e8476 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 11 Apr 2013 14:44:52 -0600 Subject: [PATCH] equality for `define-cstruct'-generated wrappers Closes PR 13650 Merge to v5.3.4 (cherry picked from commit 06c42f0887278a9510d8c3ae308d3faf75e41c5b) --- collects/ffi/unsafe.rkt | 65 ++++++++++++++----- collects/scribblings/foreign/pointers.scrbl | 5 +- collects/scribblings/foreign/types.scrbl | 13 +++- collects/scribblings/reference/booleans.scrbl | 3 +- collects/tests/racket/cstruct.rktl | 22 +++++++ 5 files changed, 86 insertions(+), 22 deletions(-) diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt index 60a21ff9ca..c5d30e1720 100644 --- a/collects/ffi/unsafe.rkt +++ b/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 - (append - (if struct:cpointer:super - null - (list - (cons prop:cpointer 0))) - (list prop ...)) + (add-equality-property + (append + (if struct:cpointer:super + null + (list + (cons prop:cpointer 0))) + (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) - (let loop ([more #'more] [alignment #f] [properties null] [property-bindings null]) + [(alignment properties property-bindings no-equal?) + (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)]) diff --git a/collects/scribblings/foreign/pointers.scrbl b/collects/scribblings/foreign/pointers.scrbl index b7591d986b..0f0d4dbc53 100644 --- a/collects/scribblings/foreign/pointers.scrbl +++ b/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[_fpointer], then the @racket[ptr-equal?] comparison is the +@racket[#f], a byte string, a callback, a pointer based on +@racket[_fpointer], or a structure with the @racket[prop:cpointer] +property, then the @racket[ptr-equal?] comparison is the same as using @racket[equal?].} diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index bc63d5a7b3..4ae09d3307 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/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 diff --git a/collects/scribblings/reference/booleans.scrbl b/collects/scribblings/reference/booleans.scrbl index 7555b153b1..a73fa59e36 100644 --- a/collects/scribblings/reference/booleans.scrbl +++ b/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]. } diff --git a/collects/tests/racket/cstruct.rktl b/collects/tests/racket/cstruct.rktl index 51ef54d835..2c28e3f2df 100644 --- a/collects/tests/racket/cstruct.rktl +++ b/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)