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

ffi/unsafe: fixes related to `define-cstruct' and properties

Browse Source 
Fix the binding context for property and property-value
expressions. Propagate wrappers (and therefore properties)
to cstruct subtypes.
This commit is contained in:
Matthew Flatt 2012-11-10 21:05:42 -07:00
parent 54c4a1f21a
commit 4ca7e6bc77
3 changed files with 111 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

112
collects/ffi/unsafe.rkt
View File

@ -1323,7 +1323,7 @@
(provide define-cstruct) (provide define-cstruct)
(define-syntax (define-cstruct stx) (define-syntax (define-cstruct stx)
(define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx (define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx
alignment-stx property-stxes) alignment-stx property-stxes property-binding-stxes)
(define name (define name
(cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx))))) (cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx)))))
(define slot-names (map (lambda (x) (symbol->string (syntax-e x))) (define slot-names (map (lambda (x) (symbol->string (syntax-e x)))
@ -1349,6 +1349,9 @@
[(slot-type ...) slot-types-stx] [(slot-type ...) slot-types-stx]
[TYPE (id name)] [TYPE (id name)]
[cpointer:TYPE (id "cpointer:"name)] [cpointer:TYPE (id "cpointer:"name)]
[struct:cpointer:TYPE (if (null? property-stxes)
#'struct:cpointer:super
(id "struct:cpointer:"name))]
[_TYPE _TYPE-stx] [_TYPE _TYPE-stx]
[_TYPE-pointer (id "_"name"-pointer")] [_TYPE-pointer (id "_"name"-pointer")]
[_TYPE-pointer/null (id "_"name"-pointer/null")] [_TYPE-pointer/null (id "_"name"-pointer/null")]
@ -1359,9 +1362,7 @@
[make-wrap-TYPE (if (null? property-stxes) [make-wrap-TYPE (if (null? property-stxes)
#'values #'values
(id "make-wrap-"name))] (id "make-wrap-"name))]
[wrap-TYPE-type (if (null? property-stxes) [wrap-TYPE-type (id "wrap-"name "-type")]
#'values
(id "wrap-"name "-type"))]
[list->TYPE (id "list->"name)] [list->TYPE (id "list->"name)]
[list*->TYPE (id "list*->"name)] [list*->TYPE (id "list*->"name)]
[TYPE->list (id name"->list")] [TYPE->list (id name"->list")]
@ -1377,26 +1378,50 @@
;; the 1st-type might be a pointer to this type ;; the 1st-type might be a pointer to this type
(if (or (safe-id=? 1st-type #'_TYPE-pointer/null) (if (or (safe-id=? 1st-type #'_TYPE-pointer/null)
(safe-id=? 1st-type #'_TYPE-pointer)) (safe-id=? 1st-type #'_TYPE-pointer))
#'(values #f '() #f #f #f #f) #'(values #f '() #f #f #f #f #f values)
#`(cstruct-info #,1st-type #`(cstruct-info #,1st-type
(lambda () (values #f '() #f #f #f #f))))] (lambda () (values #f '() #f #f #f #f #f values))))]
[define-wrapper-struct (if (null? property-stxes) [define-wrapper-struct (if (null? property-stxes)
#'(begin) #'(begin)
(with-syntax ([(prop ...) property-stxes]) (with-syntax ([(prop ...) property-stxes])
#'(define make-wrap-TYPE #'(define-values (make-wrap-TYPE struct:cpointer:TYPE)
(let () (let ()
(struct cpointer:TYPE (ptr) (define-values (struct:cpointer:TYPE
#:property prop:cpointer 0 cpointer:TYPE
prop ...) ?
cpointer:TYPE))))] ref
set)
(make-struct-type 'cpointer:TYPE
struct:cpointer:super
(if struct:cpointer:super
0
1)
0 #f
(append
(if struct:cpointer:super
null
(list
(cons prop:cpointer 0)))
(list prop ...))
(current-inspector)
#f
(if struct:cpointer:super
null
'(0))))
(values cpointer:TYPE struct:cpointer:TYPE)))))]
[define-wrap-type (if (null? property-stxes) [define-wrap-type (if (null? property-stxes)
#'(begin) #'(define (wrap-TYPE-type t)
#'(define (wrap-TYPE-type t) (super-wrap-type-type t))
(make-ctype t #'(define (wrap-TYPE-type t)
values (make-ctype t
(lambda (p) values
(and p (lambda (p)
(make-wrap-TYPE p))))))]) (and p
(make-wrap-TYPE p))))))]
[(property-binding ...) property-binding-stxes]
[(maybe-struct:TYPE ...) (if (null? property-stxes)
null
(list #'struct:cpointer:TYPE))])
#'(begin #'(begin
(define-syntax TYPE (define-syntax TYPE
(make-struct-info (make-struct-info
@ -1409,10 +1434,13 @@
#t)))) #t))))
(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag (define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
list->TYPE list*->TYPE TYPE->list TYPE->list*) list->TYPE list*->TYPE TYPE->list TYPE->list*
maybe-struct:TYPE ...)
(let-values ([(super-pointer super-tags super-types super-offsets (let-values ([(super-pointer super-tags super-types super-offsets
super->list* list*->super) super->list* list*->super
get-super-info]) struct:cpointer:super super-wrap-type-type)
get-super-info]
property-binding ...)
(define-cpointer-type _TYPE super-pointer) (define-cpointer-type _TYPE super-pointer)
define-wrap-type define-wrap-type
;; these make it possible to use recursive pointer definitions ;; these make it possible to use recursive pointer definitions
@ -1481,10 +1509,10 @@
(for-each (for-each
(lambda (type ofs value) (lambda (type ofs value)
(let-values (let-values
([(ptr tags types offsets T->list* list*->T) ([(ptr tags types offsets T->list* list*->T struct:T wrap)
(cstruct-info (cstruct-info
type type
(lambda () (values #f '() #f #f #f #f)))]) (lambda () (values #f '() #f #f #f #f #f values)))])
(ptr-set! block type 'abs ofs (ptr-set! block type 'abs ofs
(if list*->T (list*->T value) value)))) (if list*->T (list*->T value) value))))
all-types all-offsets vals) all-types all-offsets vals)
@ -1502,18 +1530,20 @@
(map (lambda (type ofs) (map (lambda (type ofs)
(let-values (let-values
([(v) (ptr-ref x type 'abs ofs)] ([(v) (ptr-ref x type 'abs ofs)]
[(ptr tags types offsets T->list* list*->T) [(ptr tags types offsets T->list* list*->T struct:T wrap)
(cstruct-info (cstruct-info
type type
(lambda () (values #f '() #f #f #f #f)))]) (lambda () (values #f '() #f #f #f #f #f values)))])
(if T->list* (T->list* v) v))) (if T->list* (T->list* v) v)))
all-types all-offsets)) all-types all-offsets))
(cstruct-info (cstruct-info
_TYPE* 'set! _TYPE* 'set!
_TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE) _TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE
struct:cpointer:TYPE wrap-TYPE-type)
(values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
list->TYPE list*->TYPE TYPE->list TYPE->list*))))))) list->TYPE list*->TYPE TYPE->list TYPE->list*
maybe-struct:TYPE ...)))))))
(define (err what . xs) (define (err what . xs)
(apply raise-syntax-error #f (apply raise-syntax-error #f
(if (list? what) (apply string-append what) what) (if (list? what) (apply string-append what) what)
@ -1524,19 +1554,26 @@
(syntax-case #'type () (syntax-case #'type ()
[(t s) (values #'t #'s)] [(t s) (values #'t #'s)]
[_ (values #'type #f)])] [_ (values #'type #f)])]
[(alignment properties) [(alignment properties property-bindings)
(let loop ([more #'more] [alignment #f] [properties null]) (let loop ([more #'more] [alignment #f] [properties null] [property-bindings null])
(define (head) (syntax-case more () [(x . _) #'x])) (define (head) (syntax-case more () [(x . _) #'x]))
(syntax-case more () (syntax-case more ()
[() (values alignment (reverse properties))] [() (values alignment (reverse properties) (reverse property-bindings))]
[(#:alignment) (err "missing expression for #:alignment" (head))] [(#:alignment) (err "missing expression for #:alignment" (head))]
[(#:alignment a . rest) [(#:alignment a . rest)
(not alignment) (not alignment)
(loop #'rest #'a properties)] (loop #'rest #'a properties property-bindings)]
[(#:property) (err "missing property expression for #:property" (head))] [(#:property) (err "missing property expression for #:property" (head))]
[(#:property prop) (err "missing value expression for #:property" (head))] [(#:property prop) (err "missing value expression for #:property" (head))]
[(#:property prop val . rest) [(#:property prop val . rest)
(loop #'rest alignment (list* #'val #'prop (head) properties))] (let ()
(define prop-id (car (generate-temporaries '(prop))))
(define val-id (car (generate-temporaries '(prop-val))))
(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)))]
[(x . _) (err (if (keyword? (syntax-e #'x)) [(x . _) (err (if (keyword? (syntax-e #'x))
"unknown keyword" "unexpected form") "unknown keyword" "unexpected form")
#'x)] #'x)]
@ -1554,9 +1591,10 @@
#`(#,(datum->syntax _TYPE 'super _TYPE) slot ...) #`(#,(datum->syntax _TYPE 'super _TYPE) slot ...)
#`(#,_SUPER slot-type ...) #`(#,_SUPER slot-type ...)
alignment alignment
properties) properties
property-bindings)
(make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) (make-syntax _TYPE #f #'(slot ...) #`(slot-type ...)
alignment properties)))] alignment properties property-bindings)))]
;; specific errors for bad slot specs, leave the rest for a generic error ;; specific errors for bad slot specs, leave the rest for a generic error
[(_ type (bad ...) . more) [(_ type (bad ...) . more)
(err "bad slot specification, expecting [name ctype]" (err "bad slot specification, expecting [name ctype]"
@ -1579,6 +1617,12 @@
(if v (apply values v) (msg/fail-thunk))))] (if v (apply values v) (msg/fail-thunk))))]
[else (msg/fail-thunk)])))) [else (msg/fail-thunk)]))))
;; another helper:
(define (check-is-property p)
(unless (struct-type-property? p)
(raise-argument-error 'define-cstruct "struct-type-property?" p))
p)
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; ;;

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

@ -975,6 +975,10 @@ The resulting bindings are as follows:
@racketidfont{list->}@racketvarfont{id}, but fields that are structs @racketidfont{list->}@racketvarfont{id}, but fields that are structs
are recursively unpacked to lists or packed from lists.} are recursively unpacked to lists or packed from lists.}
@item{@racketidfont{struct:}@racketvarfont{id}@racketidfont{:cpointer}:
only when a @racket[#:property] is specified --- a structure type that
corresponds to a wrapper to reflect properties (see below).}
] ]
Objects of the new type are actually C pointers, with a type tag that Objects of the new type are actually C pointers, with a type tag that
@ -994,7 +998,10 @@ then struct creation and coercions from @racket[_id] variants wrap a
non-NULL C pointer representation in a Racket structure that has the non-NULL C pointer representation in a Racket structure that has the
specified properties. The wrapper Racket structure also has a specified properties. The wrapper Racket structure also has a
@racket[prop:cpointer] property, so that wrapped C pointers can be @racket[prop:cpointer] property, so that wrapped C pointers can be
treated the same as unwrapped C pointers. 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.
If the first field is itself a C struct type, its tag will be used in 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 addition to the new tag. This feature supports common cases of object

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

@ -77,4 +77,29 @@
(syntax-test #'(define-cstruct _y () #:property x)) (syntax-test #'(define-cstruct _y () #:property x))
(syntax-test #'(define-cstruct _y () #:property x y . 10)) (syntax-test #'(define-cstruct _y () #:property x y . 10))
;; ----------------------------------------
;; Check struct properties and subtypes:
(let ()
(define-values (p p? p-ref) (make-struct-type-property 'my-p))
(define-cstruct _S ([a (_array _byte 23)])
#:property p (lambda () _S))
(define s (ptr-ref (malloc _S) _S)) ; dummy instance
struct:cpointer:S
(test #t p? struct:cpointer:S)
(test #t p? s)
(define-cstruct (_Q _S) ())
(test #t p? (ptr-ref (malloc _Q) _Q))
(define-cstruct _Z ([a (_array _byte 23)]))
(define-cstruct (_W _Z) ()
#:property p (lambda () _Z))
(test #f p? (ptr-ref (malloc _Z) _Z))
(test #t p? (ptr-ref (malloc _W) _W))
(test #t p? struct:cpointer:W)
(test #t Z? (ptr-ref (malloc _W) _W)))
;; ----------------------------------------
(report-errs) (report-errs)