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.

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)

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