From d747f8f806f643911f1d4e42b61af2740cfbfb2e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 14 Feb 2015 09:27:05 -0700 Subject: [PATCH] require a `#:offset` keyword before a field offset in `define-cstruct` Also, allow `#:offset` specifications on individual fields, instead of all or node. --- .../scribblings/foreign/types.scrbl | 18 ++++++++--- .../tests/racket/cstruct.rktl | 8 +++-- racket/collects/ffi/unsafe.rkt | 31 ++++++++++--------- 3 files changed, 35 insertions(+), 22 deletions(-) diff --git a/pkgs/racket-doc/scribblings/foreign/types.scrbl b/pkgs/racket-doc/scribblings/foreign/types.scrbl index 26bf72ae0e..d9b32bc8ee 100644 --- a/pkgs/racket-doc/scribblings/foreign/types.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/types.scrbl @@ -1002,14 +1002,17 @@ below for a more efficient approach. @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 (_id _super-id)) + (field-option (code:line #:offset offset-expr)) (property (code:line #:alignment alignment-expr) (code:line #:malloc-mode malloc-mode-expr) (code:line #:property prop-expr val-expr) #: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 'atomic-interior 'interior '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 @racket[define-struct], providing accessor functions for raw struct 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] 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 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. However, if at least one @racket[#:property] modifier is specified, 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)) ] -@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.}]} @; ------------------------------------------------------------ diff --git a/pkgs/racket-test-core/tests/racket/cstruct.rktl b/pkgs/racket-test-core/tests/racket/cstruct.rktl index 49e800dfe4..3a4821c920 100644 --- a/pkgs/racket-test-core/tests/racket/cstruct.rktl +++ b/pkgs/racket-test-core/tests/racket/cstruct.rktl @@ -57,7 +57,7 @@ (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))) - (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)) (test 255 due-x cv) (test 1 due-y cv) @@ -65,8 +65,10 @@ (set-due-x! cv 1) (test 1 due-x 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)) (test 255 due-x dv) (test 1 due-y dv) @@ -75,7 +77,7 @@ (test 255 due-y 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)) (test 255 due-x qtv) (test 255 due-y qtv) diff --git a/racket/collects/ffi/unsafe.rkt b/racket/collects/ffi/unsafe.rkt index 5a3271082c..284d5e42d4 100644 --- a/racket/collects/ffi/unsafe.rkt +++ b/racket/collects/ffi/unsafe.rkt @@ -1303,18 +1303,20 @@ ;; ---------------------------------------------------------------------------- ;; Struct wrappers -(define (compute-offsets types alignment) +(define (compute-offsets types alignment declared) (let ([alignment (if (memq alignment '(#f 1 2 4 8 16)) alignment #f)]) - (let loop ([ts types] [cur 0] [r '()]) + (let loop ([ts types] [ds declared] [cur 0] [r '()]) (if (null? ts) (reverse r) (let* ([algn (if alignment (min alignment (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) + (cdr ds) (+ pos (ctype-sizeof (car ts))) (cons pos r))))))) @@ -1497,7 +1499,7 @@ (define-values (stype ...) (values slot-type ...)) (define types (list stype ...)) (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 all-tags (cons TYPE-tag super-tags)) (define _TYPE* @@ -1658,17 +1660,16 @@ (unless (regexp-match? #rx"^_." (symbol->string (syntax-e _TYPE))) (err "cstruct name must begin with a `_'" _TYPE)) - (with-syntax - ([((slot slot-type slot-offset) ...) - (syntax-case #'(slot-def ...) () - [((slot slot-type) ...) #'((slot slot-type #f) ...)] - [((slot slot-type slot-offset) ...) #'((slot slot-type slot-offset) ...)] - [_ (err "bad field specification, expecting `[name ctype]' or `[name ctype offset]'" #'(slot-def ...))])]) - - (for ([s (in-list (syntax->list #'(slot ...)))]) - (unless (identifier? s) - (err "bad field name, expecting an identifier" s))) - + (with-syntax ([(#(slot slot-type slot-offset) ...) + (for/list ([slot-def (in-list (syntax->list #'(slot-def ...)))]) + (define (check-slot name type offset) + (unless (identifier? name) + (err "bad field name, expecting an identifier" name)) + (vector name type offset)) + (syntax-case slot-def () + [(slot slot-type) (check-slot #'slot #'slot-type #f)] + [(slot slot-type #:offset slot-offset) (check-slot #'slot #'slot-type #'slot-offset)] + [_ (err "bad field specification, expecting `[name ctype]' or `[name ctype #:offset offset]'" #'slot-def)]))]) (if _SUPER (make-syntax _TYPE #t #`(#,(datum->syntax _TYPE 'super _TYPE) slot ...)