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

require a #:offset keyword before a field offset in define-cstruct

Browse Source 
Also, allow `#:offset` specifications on individual fields, instead
of all or node.
This commit is contained in:
Matthew Flatt 2015-02-14 09:27:05 -07:00
parent 7dfa02cc5f
commit d747f8f806
3 changed files with 35 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkgs/racket-doc/scribblings/foreign/types.scrbl
View File

@ -1002,14 +1002,17 @@ below for a more efficient approach.
@history[#:changed "6.0.0.6" @elem{Added @racket[#:malloc-mode].}]} @history[#:changed "6.0.0.6" @elem{Added @racket[#:malloc-mode].}]}
@defform[(define-cstruct id/sup ([field-id type-expr] ...) property ...) @defform[(define-cstruct id/sup ([field-id type-expr field-option ...] ...)
property ...)
#:grammar [(id/sup _id #:grammar [(id/sup _id
(_id _super-id)) (_id _super-id))
(field-option (code:line #:offset offset-expr))
(property (code:line #:alignment alignment-expr) (property (code:line #:alignment alignment-expr)
(code:line #:malloc-mode malloc-mode-expr) (code:line #:malloc-mode malloc-mode-expr)
(code:line #:property prop-expr val-expr) (code:line #:property prop-expr val-expr)
#:no-equal)] #:no-equal)]
#:contracts ([alignment-expr (or/c #f 1 2 4 8 16)] #:contracts ([offset-expr exact-integer?]
[alignment-expr (or/c #f 1 2 4 8 16)]
[malloc-mode-expr (one-of/c 'raw 'atomic 'nonatomic [malloc-mode-expr (one-of/c 'raw 'atomic 'nonatomic
'atomic-interior 'interior 'atomic-interior 'interior
'stubborn 'uncollectable 'eternal)] 'stubborn 'uncollectable 'eternal)]
@ -1020,7 +1023,8 @@ resulting type deals with C structs in binary form, rather than
marshaling them to Racket values. The syntax is similar to marshaling them to Racket values. The syntax is similar to
@racket[define-struct], providing accessor functions for raw struct @racket[define-struct], providing accessor functions for raw struct
values (which are pointer objects); the @racket[_id] values (which are pointer objects); the @racket[_id]
must start with @litchar{_}, and at most one @racket[#:alignment] must start with @litchar{_}, at most one @racket[#:offset] can be
supplied for a field, and at most one @racket[#:alignment]
or @racket[#:malloc-mode] can be supplied. If no @racket[_super-id] or @racket[#:malloc-mode] can be supplied. If no @racket[_super-id]
is provided, then at least one field must be specified. is provided, then at least one field must be specified.
@ -1088,6 +1092,11 @@ should not be used when a pointer is expected, since it will cause the
struct to be copied rather than use the pointer value, leading to struct to be copied rather than use the pointer value, leading to
memory corruption. memory corruption.
Field offsets within the structure are normally computed
automatically, but the offset for a field can be specified with
@racket[#:offset]. Specifying @racket[#:offset] for a field affects
the default offsets computed for all remaining fields.
Instances of the new type are not normally Racket structure instances. Instances of the new type are not normally Racket structure instances.
However, if at least one @racket[#:property] modifier is specified, However, if at least one @racket[#:property] modifier is specified,
then struct creation and coercions from @racket[_id] variants wrap a then struct creation and coercions from @racket[_id] variants wrap a
@ -1247,7 +1256,8 @@ expects arguments for both the super fields and the new ones:
(define b (make-B 1 2 3)) (define b (make-B 1 2 3))
] ]
@history[#:changed "6.0.0.6" @elem{Added @racket[#:malloc-mode].}]} @history[#:changed "6.0.0.6" @elem{Added @racket[#:malloc-mode].}
#:changed "6.1.1.8" @elem{Added @racket[#:offset] for fields.}]}
@; ------------------------------------------------------------ @; ------------------------------------------------------------

8
pkgs/racket-test-core/tests/racket/cstruct.rktl
View File

@ -57,7 +57,7 @@
(test '((10 20 30 40.0) 500.0) quint->list* kv) (test '((10 20 30 40.0) 500.0) quint->list* kv)
(test '((11 21 31 40.25) 500.25) quint->list* (list*->quint '((11 21 31 40.25) 500.25))) (test '((11 21 31 40.25) 500.25) quint->list* (list*->quint '((11 21 31 40.25) 500.25)))
(define-cstruct _due [(x _byte 0) (y _byte 1)]) (define-cstruct _due [(x _byte #:offset 0) (y _byte #:offset 1)])
(define cv (make-due 255 1)) (define cv (make-due 255 1))
(test 255 due-x cv) (test 255 due-x cv)
(test 1 due-y cv) (test 1 due-y cv)
@ -65,8 +65,10 @@
(set-due-x! cv 1) (set-due-x! cv 1)
(test 1 due-x cv) (test 1 due-x cv)
(test 1 due-y cv) (test 1 due-y cv)
(define-cstruct _due2 [(x _byte #:offset 0) (y _byte)])
(test 1 due2-y (cast cv _due-pointer _due2-pointer))
(define-cstruct (_tre _due) [(z _short 2)]) (define-cstruct (_tre _due) [(z _short #:offset 2)])
(define dv (make-tre 255 1 20)) (define dv (make-tre 255 1 20))
(test 255 due-x dv) (test 255 due-x dv)
(test 1 due-y dv) (test 1 due-y dv)
@ -75,7 +77,7 @@
(test 255 due-y dv) (test 255 due-y dv)
(test 20 tre-z dv) (test 20 tre-z dv)
(define-cstruct _quattro [(pre _tre 0) (v _int 4)]) (define-cstruct _quattro [(pre _tre) (v _int #:offset 4)])
(define qtv (make-quattro dv 50)) (define qtv (make-quattro dv 50))
(test 255 due-x qtv) (test 255 due-x qtv)
(test 255 due-y qtv) (test 255 due-y qtv)

31
racket/collects/ffi/unsafe.rkt
View File

@ -1303,18 +1303,20 @@
;; ---------------------------------------------------------------------------- ;; ----------------------------------------------------------------------------
;; Struct wrappers ;; Struct wrappers
(define (compute-offsets types alignment) (define (compute-offsets types alignment declared)
(let ([alignment (if (memq alignment '(#f 1 2 4 8 16)) (let ([alignment (if (memq alignment '(#f 1 2 4 8 16))
alignment alignment
#f)]) #f)])
(let loop ([ts types] [cur 0] [r '()]) (let loop ([ts types] [ds declared] [cur 0] [r '()])
(if (null? ts) (if (null? ts)
(reverse r) (reverse r)
(let* ([algn (if alignment (let* ([algn (if alignment
(min alignment (ctype-alignof (car ts))) (min alignment (ctype-alignof (car ts)))
(ctype-alignof (car ts)))] (ctype-alignof (car ts)))]
[pos (+ cur (modulo (- (modulo cur algn)) algn))]) [pos (or (car ds)
(+ cur (modulo (- (modulo cur algn)) algn)))])
(loop (cdr ts) (loop (cdr ts)
(cdr ds)
(+ pos (ctype-sizeof (car ts))) (+ pos (ctype-sizeof (car ts)))
(cons pos r))))))) (cons pos r)))))))
@ -1497,7 +1499,7 @@
(define-values (stype ...) (values slot-type ...)) (define-values (stype ...) (values slot-type ...))
(define types (list stype ...)) (define types (list stype ...))
(define alignment-v alignment) (define alignment-v alignment)
(define offsets (map (lambda (u c) (or u c)) (list slot-offset ...) (compute-offsets types alignment-v))) (define offsets (compute-offsets types alignment-v (list slot-offset ...)))
(define-values (offset ...) (apply values offsets)) (define-values (offset ...) (apply values offsets))
(define all-tags (cons TYPE-tag super-tags)) (define all-tags (cons TYPE-tag super-tags))
(define _TYPE* (define _TYPE*
@ -1658,17 +1660,16 @@
(unless (regexp-match? #rx"^_." (symbol->string (syntax-e _TYPE))) (unless (regexp-match? #rx"^_." (symbol->string (syntax-e _TYPE)))
(err "cstruct name must begin with a `_'" _TYPE)) (err "cstruct name must begin with a `_'" _TYPE))
(with-syntax (with-syntax ([(#(slot slot-type slot-offset) ...)
([((slot slot-type slot-offset) ...) (for/list ([slot-def (in-list (syntax->list #'(slot-def ...)))])
(syntax-case #'(slot-def ...) () (define (check-slot name type offset)
[((slot slot-type) ...) #'((slot slot-type #f) ...)] (unless (identifier? name)
[((slot slot-type slot-offset) ...) #'((slot slot-type slot-offset) ...)] (err "bad field name, expecting an identifier" name))
[_ (err "bad field specification, expecting `[name ctype]' or `[name ctype offset]'" #'(slot-def ...))])]) (vector name type offset))
(syntax-case slot-def ()
(for ([s (in-list (syntax->list #'(slot ...)))]) [(slot slot-type) (check-slot #'slot #'slot-type #f)]
(unless (identifier? s) [(slot slot-type #:offset slot-offset) (check-slot #'slot #'slot-type #'slot-offset)]
(err "bad field name, expecting an identifier" s))) [_ (err "bad field specification, expecting `[name ctype]' or `[name ctype #:offset offset]'" #'slot-def)]))])
(if _SUPER (if _SUPER
(make-syntax _TYPE #t (make-syntax _TYPE #t
#`(#,(datum->syntax _TYPE 'super _TYPE) slot ...) #`(#,(datum->syntax _TYPE 'super _TYPE) slot ...)