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

equality for `define-cstruct'-generated wrappers

Browse Source 
Closes PR 13650

Merge to v5.3.4
(cherry picked from commit 06c42f0887)
This commit is contained in:
Matthew Flatt 2013-04-11 14:44:52 -06:00 committed by Ryan Culpepper
parent e8c6a5b806
commit e23bcf523f
5 changed files with 86 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
collects/ffi/unsafe.rkt
View File

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

5
collects/scribblings/foreign/pointers.scrbl
View File

@ -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?].}

13
collects/scribblings/foreign/types.scrbl
View File

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

3
collects/scribblings/reference/booleans.scrbl
View File

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

22
collects/tests/racket/cstruct.rktl
View File

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