From 7dfa02cc5f91c15c220316a78da5470314c83048 Mon Sep 17 00:00:00 2001 From: BartAdv Date: Tue, 10 Feb 2015 03:51:12 +0000 Subject: [PATCH] Add field offsets specification for define-cstruct This allows to define the offsets for each field instead of relying on the calculated ones - useful when struct might be defined differently across platforms. --- .../tests/racket/cstruct.rktl | 31 ++++++++++++- racket/collects/ffi/unsafe.rkt | 46 +++++++++++-------- 2 files changed, 56 insertions(+), 21 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/cstruct.rktl b/pkgs/racket-test-core/tests/racket/cstruct.rktl index 69134cfdd4..49e800dfe4 100644 --- a/pkgs/racket-test-core/tests/racket/cstruct.rktl +++ b/pkgs/racket-test-core/tests/racket/cstruct.rktl @@ -55,7 +55,36 @@ (test 500.0 quint-r kv) (test 500.0 cadr (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 cv (make-due 255 1)) + (test 255 due-x cv) + (test 1 due-y cv) + (test '(255 1) due->list cv) + (set-due-x! cv 1) + (test 1 due-x cv) + (test 1 due-y cv) + + (define-cstruct (_tre _due) [(z _short 2)]) + (define dv (make-tre 255 1 20)) + (test 255 due-x dv) + (test 1 due-y dv) + (test 20 tre-z dv) + (set-due-y! dv 255) + (test 255 due-y dv) + (test 20 tre-z dv) + + (define-cstruct _quattro [(pre _tre 0) (v _int 4)]) + (define qtv (make-quattro dv 50)) + (test 255 due-x qtv) + (test 255 due-y qtv) + (test 20 tre-z qtv) + (test 50 quattro-v qtv) + (set-tre-z! qtv 255) + (test 255 tre-z qtv) + (test '((255 255 255) 50) quattro->list* qtv) + (test '((255 127 1) 2048) quattro->list* (list*->quattro '((255 127 1) 2048))))) (make-test [] void [] void) diff --git a/racket/collects/ffi/unsafe.rkt b/racket/collects/ffi/unsafe.rkt index 3281eb0c69..5a3271082c 100644 --- a/racket/collects/ffi/unsafe.rkt +++ b/racket/collects/ffi/unsafe.rkt @@ -1363,7 +1363,7 @@ ;; type. (provide define-cstruct) (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 slot-offsets-stx alignment-stx malloc-mode-stx property-stxes property-binding-stxes no-equal?) (define name @@ -1389,6 +1389,7 @@ [struct-string (format "~a?" name)] [(slot ...) slot-names-stx] [(slot-type ...) slot-types-stx] + [(slot-offset ...) slot-offsets-stx] [TYPE (id name)] [cpointer:TYPE (id "cpointer:"name)] [struct:cpointer:TYPE (if (null? property-stxes) @@ -1496,7 +1497,7 @@ (define-values (stype ...) (values slot-type ...)) (define types (list stype ...)) (define alignment-v alignment) - (define offsets (compute-offsets types alignment-v)) + (define offsets (map (lambda (u c) (or u c)) (list slot-offset ...) (compute-offsets types alignment-v))) (define-values (offset ...) (apply values offsets)) (define all-tags (cons TYPE-tag super-tags)) (define _TYPE* @@ -1596,9 +1597,9 @@ (if (list? what) (apply string-append what) what) stx xs)) (syntax-case stx () - [(_ type ([slot slot-type] ...) . more) + [(_ type (slot-def ...) . more) (or (stx-pair? #'type) - (stx-pair? #'(slot ...))) + (stx-pair? #'(slot-def ...))) (let-values ([(_TYPE _SUPER) (syntax-case #'type () [(t s) (values #'t #'s)] @@ -1656,28 +1657,33 @@ _TYPE)) (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))) - (if _SUPER - (make-syntax _TYPE #t - #`(#,(datum->syntax _TYPE 'super _TYPE) slot ...) - #`(#,_SUPER slot-type ...) - alignment - malloc-mode - properties - property-bindings - no-equal?) - (make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) - alignment malloc-mode properties property-bindings no-equal?)))] + + (if _SUPER + (make-syntax _TYPE #t + #`(#,(datum->syntax _TYPE 'super _TYPE) slot ...) + #`(#,_SUPER slot-type ...) + #'(0 slot-offset ...) + alignment + malloc-mode + properties + property-bindings + no-equal?) + (make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) #`(slot-offset ...) + alignment malloc-mode properties property-bindings no-equal?))))] [(_ type () . more) (identifier? #'type) (err "must have either a supertype or at least one field")] - ;; specific errors for bad slot specs, leave the rest for a generic error - [(_ type (bad ...) . more) - (err "bad field specification, expecting `[name ctype]'" - (ormap (lambda (s) (syntax-case s () [[n ct] #t] [_ s])) - (syntax->list #'(bad ...))))] [(_ type bad . more) (err "bad field specification, expecting a sequence of `[name ctype]'" #'bad)]))