From d6684dad8c8be7676fc386ac9e6c33d0c9390032 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 1 Oct 2010 10:49:40 -0600
Subject: [PATCH] fix cstruct alignment handling

---
 collects/ffi/unsafe.rkt                 | 28 ++++++++++++++-----------
 collects/tests/racket/foreign-test.rktl | 12 +++++++++++
 2 files changed, 28 insertions(+), 12 deletions(-)

diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt
index 451b409da6..abda3034a5 100644
--- a/collects/ffi/unsafe.rkt
+++ b/collects/ffi/unsafe.rkt
@@ -1131,21 +1131,24 @@
 ;; ----------------------------------------------------------------------------
 ;; Struct wrappers
 
-(define (compute-offsets types)
-  (let loop ([ts types] [cur 0] [r '()])
-    (if (null? ts)
-      (reverse r)
-      (let* ([algn (ctype-alignof (car ts))]
-             [pos  (+ cur (modulo (- (modulo cur algn)) algn))])
-        (loop (cdr ts)
-              (+ pos (ctype-sizeof (car ts)))
-              (cons pos r))))))
+(define (compute-offsets types alignment)
+  (let ([alignment (if (memq alignment '(#f 1 2 4 8 16))
+                       alignment
+                       #f)])
+    (let loop ([ts types] [cur 0] [r '()])
+      (if (null? ts)
+          (reverse r)
+          (let* ([algn (or alignment (ctype-alignof (car ts)))]
+                 [pos  (+ cur (modulo (- (modulo cur algn)) algn))])
+            (loop (cdr ts)
+                  (+ pos (ctype-sizeof (car ts)))
+                  (cons pos r)))))))
 
 ;; Simple structs: call this with a list of types, and get a type that marshals
 ;; C structs to/from Scheme lists.
 (define* (_list-struct #:alignment [alignment #f] . types)
   (let ([stype   (make-cstruct-type types #f alignment)]
-        [offsets (compute-offsets types)]
+        [offsets (compute-offsets types alignment)]
         [len     (length types)])
     (make-ctype stype
       (lambda (vals)
@@ -1251,12 +1254,13 @@
                 (define _TYPE-pointer/null _TYPE/null)
                 (let*-values ([(stype ...)  (values slot-type ...)]
                               [(types)      (list stype ...)]
-                              [(offsets)    (compute-offsets types)]
+                              [(alignment-v) alignment]
+                              [(offsets)    (compute-offsets types alignment-v)]
                               [(offset ...) (apply values offsets)])
                   (define all-tags (cons TYPE-tag super-tags))
                   (define _TYPE*
                     ;; c->scheme adjusts all tags
-                    (let* ([cst (make-cstruct-type types #f alignment)]
+                    (let* ([cst (make-cstruct-type types #f alignment-v)]
                            [t (_cpointer TYPE-tag cst)]
                            [c->s (ctype-c->scheme t)])
                       (make-ctype cst (ctype-scheme->c t)
diff --git a/collects/tests/racket/foreign-test.rktl b/collects/tests/racket/foreign-test.rktl
index e113381bed..cdbdce41b3 100644
--- a/collects/tests/racket/foreign-test.rktl
+++ b/collects/tests/racket/foreign-test.rktl
@@ -222,6 +222,18 @@
   (test #t ptr-equal? #f (ptr-add (ptr-add #f 8) -8))
   )
 
+;; Test cstruct alignment
+(let ()
+  (define-cstruct _stuff ([a _int16]
+                          [b _int32]
+                          [c _int16])
+    #:alignment 2)
+  (define v (make-stuff 1 2 3))
+  (test 8 ctype-sizeof _stuff)
+  (test 3 stuff-c v)
+  (test 1 ptr-ref v _int16 0)
+  (test 3 ptr-ref v _int16 3))
+
 (delete-test-files)
 
 (report-errs)