First-class primitives, type aliasing, and better cross-compilation.main

I haven't actually tested cross-compilation, but we should be making
fewer assumptions about the target ABI now.

1 files changed, 483 insertions, 262 deletions

diff --git a/bstruct.scm b/bstruct.scm
index 9377a62..eb6f209 100644
--- a/bstruct.scm
+++ b/bstruct.scm
@@ -55,7 +55,29 @@
   #:use-module (system base target)
   #:use-module ((system foreign) #:prefix ffi:)
   #:use-module (system syntax)
-  #:export (bstruct?
+  #:export (uint8
+            int8
+            uint16
+            int16
+            uint32
+            int32
+            uint64
+            int64
+            float
+            double
+            int
+            unsigned-int
+            long
+            unsigned-long
+            short
+            unsigned-short
+            size_t
+            ssize_t
+            ptrdiff_t
+            intptr_t
+            uintptr_t
+
+            bstruct?
             bstruct-=?
             bstruct-type
             bstruct-length
@@ -73,7 +95,28 @@
             bstruct-pack!
             bstruct-copy
             bstruct-copy!
-            define-bstruct))
+            define-bstruct)
+  #:replace (uint8
+             int8
+             uint16
+             int16
+             uint32
+             int32
+             uint64
+             int64
+             float
+             double
+             int
+             unsigned-int
+             long
+             unsigned-long
+             short
+             unsigned-short
+             size_t
+             ssize_t
+             ptrdiff_t
+             intptr_t
+             uintptr_t))
 
 (define-record-type <scalar>
   (make-scalar size align native? type)
@@ -350,21 +393,21 @@
         (($ <scalar> _ _ native? type)
          (let ((e (if native? (target-endianness) (non-target-endianness))))
            (match type
-             ('u8 (bytevector-u8-ref bv offset))
-             ('s8 (bytevector-s8-ref bv offset))
-             ('u16 (bytevector-u16-ref bv offset e))
-             ('s16 (bytevector-s16-ref bv offset e))
-             ('u32 (bytevector-u32-ref bv offset e))
-             ('s32 (bytevector-s32-ref bv offset e))
-             ('u64 (bytevector-u64-ref bv offset e))
-             ('s64 (bytevector-s64-ref bv offset e))
-             ('f32 (bytevector-ieee-single-ref bv offset e))
-             ('f64 (bytevector-ieee-double-ref bv offset e))
-             ('uint (bytevector-uint-ref bv offset e (ffi:sizeof ffi:unsigned-int)))
+             ('uint8 (bytevector-u8-ref bv offset))
+             ('int8 (bytevector-s8-ref bv offset))
+             ('uint16 (bytevector-u16-ref bv offset e))
+             ('int16 (bytevector-s16-ref bv offset e))
+             ('uint32 (bytevector-u32-ref bv offset e))
+             ('int32 (bytevector-s32-ref bv offset e))
+             ('uint64 (bytevector-u64-ref bv offset e))
+             ('int64 (bytevector-s64-ref bv offset e))
+             ('float (bytevector-ieee-single-ref bv offset e))
+             ('double (bytevector-ieee-double-ref bv offset e))
+             ('unsigned-int (bytevector-uint-ref bv offset e (ffi:sizeof ffi:unsigned-int)))
              ('int (bytevector-sint-ref bv offset e (ffi:sizeof ffi:int)))
-             ('ulong (bytevector-uint-ref bv offset e (ffi:sizeof ffi:unsigned-long)))
+             ('unsigned-long (bytevector-uint-ref bv offset e (ffi:sizeof ffi:unsigned-long)))
              ('long (bytevector-sint-ref bv offset e (ffi:sizeof ffi:long)))
-             ('ushort (bytevector-uint-ref bv offset e (ffi:sizeof ffi:unsigned-short)))
+             ('unsigned-short (bytevector-uint-ref bv offset e (ffi:sizeof ffi:unsigned-short)))
              ('short (bytevector-sint-ref bv offset e (ffi:sizeof ffi:short)))
              ('size_t (bytevector-uint-ref bv offset e (ffi:sizeof ffi:size_t)))
              ('ssize_t (bytevector-sint-ref bv offset e (ffi:sizeof ffi:ssize_t)))
@@ -404,32 +447,32 @@
          `(* ,(bytevector-uint-ref bv offset (native-endianness)
                                    (ffi:sizeof '*))))))))
 
-;; Macro helpers that use metadata attached to bstruct syntax
+;; Macro helpers that query properties attached to syntax
 ;; transformers.
-(define (bstruct-descriptor-identifier? id)
+(define (identifier-properties id)
   (and (identifier? id)
        (let-values (((kind val) (syntax-local-binding id)))
          (and (eq? kind 'macro)
-              (procedure-property val 'bstruct?)))))
-
-(define (opaque-bstruct-descriptor-identifier? id)
+              (procedure-properties val)))))
+(define (identifier-property-ref id key)
   (and (identifier? id)
        (let-values (((kind val) (syntax-local-binding id)))
          (and (eq? kind 'macro)
-              (procedure-property val 'bstruct?)
-              (procedure-property val 'bstruct-opaque?)))))
-
+              (procedure-property val key)))))
+(define (bstruct-descriptor-identifier? id)
+  (identifier-property-ref id 'bstruct?))
+(define (opaque-bstruct-descriptor-identifier? id)
+  (and (bstruct-descriptor-identifier? id)
+       (identifier-property-ref id 'bstruct-opaque?)))
+(define (primitive-bstruct-descriptor-identifier? id)
+  (identifier-property-ref id 'bstruct-primitive?))
 (define (non-opaque-bstruct-descriptor-identifier? id)
-  (not (opaque-bstruct-descriptor-identifier? id)))
-
-(define (bstruct-descriptor-identifier-size id)
-  (let-values (((_ transformer) (syntax-local-binding id)))
-    (procedure-property transformer 'bstruct-size)))
-
-(define (bstruct-descriptor-identifier-align id)
-  (let-values (((_ transformer) (syntax-local-binding id)))
-    (procedure-property transformer 'bstruct-align)))
+  (and (bstruct-descriptor-identifier? id)
+       (not (opaque-bstruct-descriptor-identifier? id))))
+(define (bstruct-descriptor-identifier-primitive-type id)
+  (identifier-property-ref id 'bstruct-primitive-type))
 
+;; Helpers for syntax-case guard clauses.
 (define (identifier-eq? stx sym)
   (and (identifier? stx) (eq? (syntax->datum stx) sym)))
 (define-syntax-rule (symbolic-match? id)
@@ -437,20 +480,20 @@
 (define (identifier-memq? stx syms)
   (and (identifier? stx) (memq (syntax->datum stx) syms)))
 
-;; A predicate that can answer the questions:
+;; A predicate that can answer either of these questions:
 ;; 1) Is this *any kind* of bstruct?
 ;; 2) Is this *a specific kind* of bstruct?
 (define-syntax bstruct?
   (lambda (stx)
     (syntax-case stx ()
-      (x
-       (identifier? #'x)
+      (id
+       (identifier? #'id)
        #'(case-lambda
            ((obj) (%bstruct? obj))
            ((<type> obj)
-            (match obj
-              (($ <type>) #t)
-              (_ #f)))))
+            (and (bstruct? obj)
+                 (bstruct-descriptor? <type>)
+                 (eq? (struct-vtable obj) <type>)))))
       ((_ obj)
        #'(%bstruct? obj))
       ((_ <type> obj)
@@ -459,6 +502,20 @@
            (($ <type>) #t)
            (_ #f))))))
 
+(define-syntax bstruct-sizeof
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type>)
+       (non-opaque-bstruct-descriptor-identifier? #'<type>)
+       #'(<type> sizeof)))))
+
+(define-syntax bstruct-alignof
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type>)
+       (non-opaque-bstruct-descriptor-identifier? #'<type>)
+       #'(<type> alignof)))))
+
 (define-syntax bstruct-=?
   (lambda (stx)
     (syntax-case stx ()
@@ -519,7 +576,7 @@
     (syntax-case stx ()
       ((_ <type> bv offset n)
        (non-opaque-bstruct-descriptor-identifier? #'<type>)
-       #'(make-bstruct <type> bv offset n))
+       #'(make-bstruct (<type> descriptor) bv offset n))
       ((_ <type> bv offset)
        #'(bstruct-wrap <type> bv offset 1)))))
 
@@ -533,21 +590,6 @@
            (($ <type> bv offset n)
             (values bv offset n)))))))
 
-;; Size/align queries.
-(define-syntax bstruct-sizeof
-  (lambda (stx)
-    (syntax-case stx ()
-      ((_ <type>)
-       (non-opaque-bstruct-descriptor-identifier? #'<type>)
-       (bstruct-descriptor-identifier-size #'<type>)))))
-
-(define-syntax bstruct-alignof
-  (lambda (stx)
-    (syntax-case stx ()
-      ((_ <type>)
-       (non-opaque-bstruct-descriptor-identifier? #'<type>)
-       (bstruct-descriptor-identifier-align #'<type>)))))
-
 ;; 'bstruct-pack!' and 'bstruct-unpack' allow for directly
 ;; interpreting bytevector contents as structured data.
 (define-syntax bstruct-pack!
@@ -641,6 +683,7 @@
         (bytevector-copy! src-bv src-offset
                           dst-bv dst-offset
                           (* (bstruct-sizeof <type>) src-n)))))))
+
 (define-syntax-rule (bstruct-copy <type> src)
   (match src
     (($ <type> _ _ (? u64? n))
@@ -648,6 +691,259 @@
        (bstruct-copy! <type> src dst)
        dst))))
 
+;; Primitives are wrapper macros around Guile's foreign types that
+;; attach additional metadata needed by the rest of the system.
+(define-syntax define-bstruct-primitive
+  (lambda (stx)
+    (define native-endianness (target-endianness))
+    (define non-native-endianness
+      (if (eq? (target-endianness) (endianness little))
+          (endianness big)
+          (endianness little)))
+    ;; Primitive types are divided into two categories: machine
+    ;; indepenent and machine dependent.  The machine independent
+    ;; types (int32, float, etc.) have a known size and alignment on
+    ;; all platforms.  The machine dependent types have a size and
+    ;; alignment that can vary depending on the ABI of the system that
+    ;; is compiling the code.  When the host and target are the same,
+    ;; sizeof/alignof calls happen at compile-time and the resulting
+    ;; code is more optimal.  For cross-builds, the size/alignment of
+    ;; primitives isn't known at compile time so those calculations
+    ;; are deferred until runtime.
+    (define (%sizeof type)
+      (define (compile-time-size type)
+        (if (equal? %host-type (target-type))
+            (ffi:sizeof type)
+            #'(ffi:sizeof type)))
+      (match type
+        ((or 'uint8 'int8) 1)
+        ((or 'uint16 'int16) 2)
+        ((or 'uint32 'int32 'float) 4)
+        ((or 'uint64 'int64 'double) 8)
+        ('unsigned-int (compile-time-size ffi:unsigned-int))
+        ('int (compile-time-size ffi:int))
+        ('unsigned-long (compile-time-size ffi:unsigned-long))
+        ('long (compile-time-size ffi:long))
+        ('unsigned-short (compile-time-size ffi:unsigned-short))
+        ('short (compile-time-size ffi:short))
+        ('size_t (compile-time-size ffi:size_t))
+        ('ssize_t (compile-time-size ffi:ssize_t))
+        ('ptrdiff_t (compile-time-size ffi:ptrdiff_t))
+        ('intptr_t (compile-time-size ffi:intptr_t))
+        ('uintptr_t (compile-time-size ffi:uintptr_t))
+        ('* (compile-time-size '*))
+        (_ (syntax-violation '%sizeof "invalid primitive type" stx))))
+    (define (%alignof type)
+      (define (compile-time-align type)
+        (if (equal? %host-type (target-type))
+            (ffi:alignof type)
+            #'(ffi:alignof type)))
+      (match type
+        ((or 'uint8 'int8) 1)
+        ((or 'uint16 'int16) 2)
+        ((or 'uint32 'int32 'float) 4)
+        ((or 'uint64 'int64 'double) 8)
+        ('unsigned-int (compile-time-align ffi:unsigned-int))
+        ('int (compile-time-align ffi:int))
+        ('unsigned-long (compile-time-align ffi:unsigned-long))
+        ('long (compile-time-align ffi:long))
+        ('unsigned-short (compile-time-align ffi:unsigned-short))
+        ('short (compile-time-align ffi:short))
+        ('size_t (compile-time-align ffi:size_t))
+        ('ssize_t (compile-time-align ffi:ssize_t))
+        ('ptrdiff_t (compile-time-align ffi:ptrdiff_t))
+        ('intptr_t (compile-time-align ffi:intptr_t))
+        ('uintptr_t (compile-time-align ffi:uintptr_t))
+        ('* (compile-time-align '*))
+        (_ (syntax-violation '%alignof "invalid primitive type" stx))))
+    (define (getter type endianness)
+      (define native? (eq? endianness native-endianness))
+      (with-syntax ((e (datum->syntax #f endianness)))
+        (match type
+          ('uint8 #'bytevector-u8-ref)
+          ('int8 #'bytevector-s8-ref)
+          ('uint16
+           (if native?
+               #'bytevector-u16-native-ref
+               #'(lambda (bv i) (bytevector-u16-ref bv i 'e))))
+          ('int16
+           (if native?
+               #'bytevector-s16-native-ref
+               #'(lambda (bv i) (bytevector-s16-ref bv i 'e))))
+          ('uint32
+           (if native?
+               #'bytevector-u32-native-ref
+               #'(lambda (bv i) (bytevector-u32-ref bv i 'e))))
+          ('int32
+           (if native?
+               #'bytevector-s32-native-ref
+               #'(lambda (bv i) (bytevector-s32-ref bv i 'e))))
+          ('uint64
+           (if native?
+               #'bytevector-u64-native-ref
+               #'(lambda (bv i) (bytevector-u64-ref bv i 'e))))
+          ('int64
+           (if native?
+               #'bytevector-s64-native-ref
+               #'(lambda (bv i) (bytevector-s64-ref bv i 'e))))
+          ('float
+           (if native?
+               #'bytevector-ieee-single-native-ref
+               #'(lambda (bv i) (bytevector-ieee-single-ref bv i 'e))))
+          ('double
+           (if native?
+               #'bytevector-ieee-double-native-ref
+               #'(lambda (bv i) (bytevector-ieee-double-ref bv i 'e))))
+          ((or 'unsigned-int 'unsigned-long 'unsigned-short 'size_t 'uintptr_t '*)
+           (with-syntax ((size (%sizeof type)))
+             #'(match size
+                 (1 bytevector-u8-ref)
+                 (2 bytevector-u16-native-ref)
+                 (4 bytevector-u32-native-ref)
+                 (8 bytevector-u64-native-ref)
+                 (n (lambda (bv i)
+                      (bytevector-uint-ref bv i 'e size))))))
+          ((or 'int 'long 'short 'ssize_t 'ptrdiff_t 'intptr_t)
+           (with-syntax ((size (%sizeof type)))
+             #'(match size
+                 (1 bytevector-s8-ref)
+                 (2 bytevector-s16-native-ref)
+                 (4 bytevector-s32-native-ref)
+                 (8 bytevector-s64-native-ref)
+                 (n (lambda (bv i)
+                      (bytevector-sint-ref bv i 'e size))))))
+          (_ (syntax-violation '%alignof "invalid primitive type" stx)))))
+    (define (setter type endianness)
+      (define native? (eq? endianness native-endianness))
+      (with-syntax ((e (datum->syntax #f endianness)))
+        (match type
+          ('uint8 #'bytevector-u8-set!)
+          ('int8 #'bytevector-s8-set!)
+          ('uint16
+           (if native?
+               #'bytevector-u16-native-set!
+               #'(lambda (bv i) (bytevector-u16-set! bv i 'e))))
+          ('int16
+           (if native?
+               #'bytevector-s16-native-set!
+               #'(lambda (bv i) (bytevector-s16-set! bv i 'e))))
+          ('uint32
+           (if native?
+               #'bytevector-u32-native-set!
+               #'(lambda (bv i) (bytevector-u32-set! bv i 'e))))
+          ('int32
+           (if native?
+               #'bytevector-s32-native-set!
+               #'(lambda (bv i) (bytevector-s32-set! bv i 'e))))
+          ('uint64
+           (if native?
+               #'bytevector-u64-native-set!
+               #'(lambda (bv i) (bytevector-u64-set! bv i 'e))))
+          ('int64
+           (if native?
+               #'bytevector-s64-native-set!
+               #'(lambda (bv i) (bytevector-s64-set! bv i 'e))))
+          ('float
+           (if native?
+               #'bytevector-ieee-single-native-set!
+               #'(lambda (bv i) (bytevector-ieee-single-set! bv i 'e))))
+          ('double
+           (if native?
+               #'bytevector-ieee-double-native-set!
+               #'(lambda (bv i x) (bytevector-ieee-double-set! bv i 'e))))
+          ((or 'unsigned-int 'unsigned-long 'unsigned-short 'size_t 'uintptr_t '*)
+           (with-syntax ((size (%sizeof type)))
+             #'(match size
+                 (1 bytevector-u8-set!)
+                 (2 bytevector-u16-native-set!)
+                 (4 bytevector-u32-native-set!)
+                 (8 bytevector-u64-native-set!)
+                 (n (lambda (bv i x)
+                      (bytevector-uint-set! bv i x 'e size))))))
+          ((or 'int 'long 'short 'ssize_t 'ptrdiff_t 'intptr_t)
+           (with-syntax ((size (%sizeof type)))
+             #'(match size
+                 (1 bytevector-s8-set!)
+                 (2 bytevector-s16-native-set!)
+                 (4 bytevector-s32-native-set!)
+                 (8 bytevector-s64-native-set!)
+                 (n (lambda (bv i x)
+                      (bytevector-sint-set! bv i x 'e size))))))
+          (_ (syntax-violation '%alignof "invalid primitive type" stx)))))
+    (define (generate-descriptor-id id)
+      (datum->syntax id (symbol-append (string->symbol "% bstruct-descriptor-")
+                                       (syntax->datum id))))
+    (syntax-case stx ()
+      ((_ id type ffi-id)
+       (with-syntax ((desc-id (generate-descriptor-id #'id))
+                     (size (%sizeof (syntax->datum #'type)))
+                     (align (%alignof (syntax->datum #'type)))
+                     (native-getter (getter (syntax->datum #'type)
+                                            (target-endianness)))
+                     (non-native-getter (getter (syntax->datum #'type)
+                                                non-native-endianness))
+                     (native-setter (setter (syntax->datum #'type)
+                                            (target-endianness)))
+                     (non-native-setter (setter (syntax->datum #'type)
+                                                non-native-endianness)))
+         #'(begin
+             (define desc-id
+               (make-bstruct-descriptor 'id (make-scalar size align #t 'type)))
+             (define-syntax id
+               (lambda (stx)
+                 #((bstruct? . #t)
+                   (bstruct-primitive? . #t)
+                   (bstruct-primitive-type . type))
+                 (syntax-case stx ()
+                   ;; Identifier syntax to provide the illusion that
+                   ;; this macro is just an FFI primitive.
+                   (self
+                    (identifier? #'self)
+                    #'ffi-id)
+                   ((_ descriptor)
+                    (symbolic-match? descriptor)
+                    #'desc-id)
+                   ((_ sizeof)
+                    (symbolic-match? sizeof)
+                    #'size)
+                   ((_ alignof)
+                    (symbolic-match? alignof)
+                    #'align)
+                   ((_ getter native?)
+                    (symbolic-match? getter)
+                    (if (syntax->datum #'native?)
+                        #'native-getter
+                        #'non-native-getter))
+                   ((_ setter native?)
+                    (symbolic-match? setter)
+                    (if (syntax->datum #'native?)
+                        #'native-setter
+                        #'non-native-setter))))))))
+      ((_ id ffi-id)
+       #'(define-bstruct-primitive id id ffi-id)))))
+(define-bstruct-primitive uint8 ffi:uint8)
+(define-bstruct-primitive int8 ffi:int8)
+(define-bstruct-primitive uint16 ffi:uint16)
+(define-bstruct-primitive int16 ffi:int16)
+(define-bstruct-primitive uint32 ffi:uint32)
+(define-bstruct-primitive int32 ffi:int32)
+(define-bstruct-primitive uint64 ffi:uint64)
+(define-bstruct-primitive int64 ffi:int64)
+(define-bstruct-primitive float ffi:float)
+(define-bstruct-primitive double ffi:double)
+(define-bstruct-primitive int ffi:int)
+(define-bstruct-primitive unsigned-int ffi:unsigned-int)
+(define-bstruct-primitive long ffi:long)
+(define-bstruct-primitive unsigned-long ffi:unsigned-long)
+(define-bstruct-primitive short ffi:short)
+(define-bstruct-primitive unsigned-short ffi:unsigned-short)
+(define-bstruct-primitive size_t ffi:size_t)
+(define-bstruct-primitive ssize_t ffi:ssize_t)
+(define-bstruct-primitive ptrdiff_t ffi:ptrdiff_t)
+(define-bstruct-primitive intptr_t ffi:intptr_t)
+(define-bstruct-primitive uintptr_t ffi:uintptr_t)
+(define-bstruct-primitive %pointer * '*)
+
 (define-syntax define-bstruct-descriptor
   (lambda (stx)
     (define (build-bit-field stx)
@@ -669,7 +965,8 @@
          desc)
         ((scalar size align native? type)
          (symbolic-match? scalar)
-         #'(make-scalar size align native? 'type))
+         (let ((type (bstruct-descriptor-identifier-primitive-type #'type)))
+           #`(make-scalar size align native? '#,(datum->syntax #f type))))
         ((bits size align native? (field ...))
          (symbolic-match? bits)
          (with-syntax (((field ...) (map build-bit-field #'(field ...))))
@@ -699,6 +996,10 @@
       ((_ id name (opaque))
        (symbolic-match? opaque)
        #'(define id #f))
+      ;; Bare identifiers are aliases.
+      ((_ id name orig)
+       (bstruct-descriptor-identifier? #'orig)
+       #'(define id orig))
       ((_ id name layout . kwargs)
        (with-syntax ((type (build-type #'layout)))
          #`(define id (make-bstruct-descriptor 'name type . kwargs)))))))
@@ -707,54 +1008,54 @@
   (syntax-case type ()
     ((scalar size _ _ _)
      (symbolic-match? scalar)
-     (syntax->datum #'size))
+     #'size)
     ((bits size _ _ _)
      (symbolic-match? bits)
-     (syntax->datum #'size))
+     #'size)
     ((struct size _ _)
      (symbolic-match? struct)
-     (syntax->datum #'size))
+     #'size)
     ((union size _ _)
      (symbolic-match? union)
-     (syntax->datum #'size))
+     #'size)
     ((array size _ _ _)
      (symbolic-match? array)
-     (syntax->datum #'size))
+     #'size)
     ((pointer size _ _)
      (symbolic-match? pointer)
-     (syntax->datum #'size))
+     #'size)
     ((opaque)
      (symbolic-match? opaque)
-     0)
-    (_
-     (bstruct-descriptor-identifier? type)
-     (bstruct-descriptor-identifier-size type))))
+     #f)
+    (id
+     (bstruct-descriptor-identifier? #'id)
+     #'(id sizeof))))
 (define (alignof/syntax type)
   (syntax-case type ()
     ((scalar _ align _ _)
      (symbolic-match? scalar)
-     (syntax->datum #'align))
+     #'align)
     ((bits _ align _ _)
      (symbolic-match? bits)
-     (syntax->datum #'align))
+     #'align)
     ((struct _ align _)
      (symbolic-match? struct)
-     (syntax->datum #'align))
+     #'align)
     ((union _ align _)
      (symbolic-match? union)
-     (syntax->datum #'align))
+     #'align)
     ((array _ align _ _)
      (symbolic-match? array)
-     (syntax->datum #'align))
+     #'align)
     ((pointer _ align _)
      (symbolic-match? pointer)
-     (syntax->datum #'align))
+     #'align)
     ((opaque)
      (symbolic-match? opaque)
-     0)
-    (_
-     (bstruct-descriptor-identifier? type)
-     (bstruct-descriptor-identifier-align type))))
+     #f)
+    (id
+     (bstruct-descriptor-identifier? #'id)
+     #'(id alignof))))
 (define (expand-accessor proc who stx id op type)
   (syntax-case stx ()
     (() (proc id 0))                    ; self reference
@@ -900,62 +1201,6 @@
                (sub-offset
                 #'(sub-offset bv (+ i offset))))))
          'bstruct->pointer elems id 'offset type)))
-    ;; Primitive getter/setter helpers
-(define (ref/endianness proc endianness)
-  #`(lambda (bv i)
-      (#,proc bv i #,endianness)))
-(define (uint-ref size endianness)
-  #`(lambda (bv i)
-      (bytevector-uint-ref bv i '#,(datum->syntax #f endianness) #,size)))
-(define (sint-ref size endianness)
-  #`(lambda (bv i)
-      (bytevector-sint-ref bv i '#,(datum->syntax #f endianness) #,size)))
-;; Scalar types are divided into two categories: machine
-;; indepenent and machine dependent.  The machine independent
-;; types (i32, f32, etc.) have a known size and alignment on all
-;; platforms.  The machine dependent types have a size and
-;; alignment that can vary depending on the ABI of the system that
-;; is compiling the code.
-(define (abi-ref type e)            ; e for endianness
-  (match type
-    ('uint (uint-ref (sizeof* 'uint) e))
-    ('int (sint-ref (sizeof* 'int) e))
-    ('ulong (uint-ref (sizeof* 'ulong) e))
-    ('long (sint-ref (sizeof* 'long) e))
-    ('ushort (uint-ref (sizeof* 'ushort) e))
-    ('short (sint-ref (sizeof* 'short) e))
-    ('size_t (uint-ref (sizeof* 'size_t) e))
-    ('ssize_t (sint-ref (sizeof* 'ssize_t) e))
-    ('ptrdiff_t (sint-ref (sizeof* 'ptrdiff_t) e))
-    ('intptr_t (sint-ref (sizeof* 'intptr_t) e))
-    ('uintptr_t (uint-ref (sizeof* 'uintptr_t) e))))
-(define (primitive-getter native? type)
-  (if native?
-      (match type
-        ('u8 #'bytevector-u8-ref)
-        ('s8 #'bytevector-s8-ref)
-        ('u16 #'bytevector-u16-native-ref)
-        ('s16 #'bytevector-s16-native-ref)
-        ('u32 #'bytevector-u32-native-ref)
-        ('s32 #'bytevector-s32-native-ref)
-        ('u64 #'bytevector-u64-native-ref)
-        ('s64 #'bytevector-s64-native-ref)
-        ('f32 #'bytevector-ieee-single-native-ref)
-        ('f64 #'bytevector-ieee-double-native-ref)
-        (_ (abi-ref type (target-endianness))))
-      (let ((e (non-target-endianness)))
-        (match type
-          ('u8 #'bytevector-u8-ref)
-          ('s8 #'bytevector-s8-ref)
-          ('u16 (ref/endianness #'bytevector-u16-ref e))
-          ('s16 (ref/endianness #'bytevector-s16-ref e))
-          ('u32 (ref/endianness #'bytevector-u32-ref e))
-          ('s32 (ref/endianness #'bytevector-s32-ref e))
-          ('u64 (ref/endianness #'bytevector-u64-ref e))
-          ('s64 (ref/endianness #'bytevector-s64-ref e))
-          ('f32 (ref/endianness #'bytevector-ieee-single-ref e))
-          ('f64 (ref/endianness #'bytevector-ieee-double-ref e))
-          (_ (abi-ref type e))))))
 (define (expand-getter elems id type)
   #`(lambda (bv i)
       #,(expand-accessor
@@ -973,24 +1218,21 @@
                                         #,(target-word-size))))
                ((scalar size align native? type)
                 (symbolic-match? scalar)
-                (with-syntax ((getter (primitive-getter (syntax->datum #'native?)
-                                                        (syntax->datum #'type))))
-                  #'(getter bv (+ i offset))))
+                #'((type getter native?) bv (+ i offset)))
                ((bit-field size start len signed? native?)
                 (symbolic-match? bit-field)
-                (let ((type (if (syntax->datum #'signed?)
-                                (match (syntax->datum #'size)
-                                  (1 's8)
-                                  (2 's16)
-                                  (4 's32)
-                                  (8 's64))
-                                (match (syntax->datum #'size)
-                                  (1 'u8)
-                                  (2 'u16)
-                                  (4 'u32)
-                                  (8 'u64)))))
-                  (with-syntax ((getter (primitive-getter (syntax->datum #'native?)
-                                                          type)))
+                (with-syntax ((type (if (syntax->datum #'signed?)
+                                        (match (syntax->datum #'size)
+                                          (1 #'int8)
+                                          (2 #'int16)
+                                          (4 #'int32)
+                                          (8 #'int64))
+                                        (match (syntax->datum #'size)
+                                          (1 #'uint8)
+                                          (2 #'uint16)
+                                          (4 #'uint32)
+                                          (8 #'uint64)))))
+                  (with-syntax ((getter #'(type getter native?)))
                     #'(let ((x (ash (logand (getter bv (+ i offset))
                                             (ash (1- (ash 1 len)) start))
                                     (- start))))
@@ -1000,55 +1242,6 @@
                (sub-get
                 #'(sub-get bv (+ i offset))))))
          'bstruct-unpack elems id 'getter type)))
-(define (set!/endianness proc endianness)
-  #`(lambda (bv i x)
-      (#,proc bv i x #,endianness)))
-(define (uint-set! size endianness)
-  #`(lambda (bv i x)
-      (bytevector-uint-set! bv i x '#,(datum->syntax #f endianness) #,size)))
-(define (sint-set! size endianness)
-  #`(lambda (bv i x)
-      (bytevector-sint-set! bv i x '#,(datum->syntax #f endianness) #,size)))
-(define (abi-set! type e)
-  (match type
-    ('uint (uint-set! (sizeof* 'uint) e))
-    ('int (sint-set! (sizeof* 'int) e))
-    ('ulong (uint-set! (sizeof* 'ulong) e))
-    ('long (sint-set! (sizeof* 'long) e))
-    ('ushort (uint-set! (sizeof* 'ushort) e))
-    ('short (sint-set! (sizeof* 'short) e))
-    ('size_t (uint-set! (sizeof* 'size_t) e))
-    ('ssize_t (sint-set! (sizeof* 'ssize_t) e))
-    ('ptrdiff_t (sint-set! (sizeof* 'ptrdiff_t) e))
-    ('intptr_t (sint-set! (sizeof* 'intptr_t) e))
-    ('uintptr_t (uint-set! (sizeof* 'uintptr_t) e))))
-(define (primitive-setter native? type)
-  (if native?
-      (match type
-        ('u8 #'bytevector-u8-set!)
-        ('s8 #'bytevector-s8-set!)
-        ('u16 #'bytevector-u16-native-set!)
-        ('s16 #'bytevector-s16-native-set!)
-        ('u32 #'bytevector-u32-native-set!)
-        ('s32 #'bytevector-s32-native-set!)
-        ('u64 #'bytevector-u64-native-set!)
-        ('s64 #'bytevector-s64-native-set!)
-        ('f32 #'bytevector-ieee-single-native-set!)
-        ('f64 #'bytevector-ieee-double-native-set!)
-        (_ (abi-set! type (target-endianness))))
-      (let ((e (non-target-endianness)))
-        (match type
-          ('u8 #'bytevector-u8-set!)
-          ('s8 #'bytevector-s8-set!)
-          ('u16 (set!/endianness #'bytevector-u16-set! e))
-          ('s16 (set!/endianness #'bytevector-s16-set! e))
-          ('u32 (set!/endianness #'bytevector-u32-set! e))
-          ('s32 (set!/endianness #'bytevector-s32-set! e))
-          ('u64 (set!/endianness #'bytevector-u64-set! e))
-          ('s64 (set!/endianness #'bytevector-s64-set! e))
-          ('f32 (set!/endianness #'bytevector-ieee-single-set! e))
-          ('f64 (set!/endianness #'bytevector-ieee-double-set! e))
-          (_ (abi-set! type e))))))
 (define (expand-setter elems id type size)
   #`(lambda (bv i x)
       #,(expand-accessor
@@ -1057,10 +1250,9 @@
              (syntax-case type ()
                (id
                 (bstruct-descriptor-identifier? #'id)
-                #`(match x
+                #'(match x
                     (($ id src j)
-                     (bytevector-copy! src j bv (+ i offset)
-                                       #,(bstruct-descriptor-identifier-size type)))))
+                     (bytevector-copy! src j bv (+ i offset) (id sizeof)))))
                ((pointer _ _ _)
                 (symbolic-match? pointer)
                 #`(bytevector-sint-set! bv (+ i offset)
@@ -1069,25 +1261,22 @@
                                         #,(target-word-size)))
                ((scalar size align native? type)
                 (symbolic-match? scalar)
-                (with-syntax ((setter (primitive-setter (syntax->datum #'native?)
-                                                        (syntax->datum #'type))))
-                  #'(setter bv (+ i offset) x)))
+                #'((type setter native?) bv (+ i offset) x))
                ((bit-field size start len signed? native?)
                 (symbolic-match? bit-field)
-                (let ((type (if (syntax->datum #'signed?)
-                                (match (syntax->datum #'size)
-                                  (1 's8)
-                                  (2 's16)
-                                  (4 's32)
-                                  (8 's64))
-                                (match (syntax->datum #'size)
-                                  (1 'u8)
-                                  (2 'u16)
-                                  (4 'u32)
-                                  (8 'u64))))
-                      (native? (syntax->datum #'native?)))
-                  (with-syntax ((getter (primitive-getter native? type))
-                                (setter (primitive-setter native? type)))
+                (with-syntax ((type (if (syntax->datum #'signed?)
+                                        (match (syntax->datum #'size)
+                                          (1 #'int8)
+                                          (2 #'int16)
+                                          (4 #'int32)
+                                          (8 #'int64))
+                                        (match (syntax->datum #'size)
+                                          (1 #'uint8)
+                                          (2 #'uint16)
+                                          (4 #'uint32)
+                                          (8 #'uint64)))))
+                  (with-syntax ((getter #'(type getter native?))
+                                (setter #'(type setter native?)))
                     ;; The mask keeps the bits that are *not* part of
                     ;; the bit field for the existing value.
                     #'(let* ((mask (lognot (ash (1- (ash 1 len)) start)))
@@ -1112,7 +1301,8 @@
 (define-syntax define-bstruct-macro
   (lambda (stx)
     (syntax-case stx ()
-      ((_ id type-id (opaque))
+      ;; Opaque types have very limited capabilities.
+      ((_ id type-id size align (opaque))
        (symbolic-match? opaque)
        #'(define-syntax id
            (lambda (stx)
@@ -1124,19 +1314,45 @@
                (self
                 (identifier? #'self)
                 #'type-id)))))
+      ;; Type aliases.
+      ((_ id type-id size align orig)
+       (bstruct-descriptor-identifier? #'orig)
+       #`(define-syntax id
+           (lambda (stx)
+             ;; Copy all properties of the original.
+             #(#,@(map (match-lambda
+                         ((k . v)
+                          (cons (datum->syntax #f k)
+                                (datum->syntax #f v))))
+                       (identifier-properties #'orig)))
+             (syntax-case stx ()
+               (self
+                (identifier? #'self)
+                #'type-id)
+               ;; Forward to original macro.
+               ((_ . args)
+                #'(orig . args))))))
+      ;; Compound types.
       ((_ id type-id size align desc . kwargs)
        #'(define-syntax id
            (lambda (stx)
              #((bstruct? . #t)
-               (bstruct-opaque? . #f)
-               (bstruct-size . size)
-               (bstruct-align . align))
+               (bstruct-opaque? . #f))
              (let ((type #'desc))
                (syntax-case stx ()
                  (self
                   (identifier? #'self)
                   #'type-id)
                  ;; Private interface for code generation.
+                 ((_ descriptor)
+                  (symbolic-match? descriptor)
+                  #'type-id)
+                 ((_ sizeof)
+                  (symbolic-match? sizeof)
+                  #'size)
+                 ((_ alignof)
+                  (symbolic-match? alignof)
+                  #'align)
                  ((_ offset . elems)
                   (symbolic-match? offset)
                   (expand-offset #'elems #'id type))
@@ -1147,6 +1363,11 @@
                   (symbolic-match? setter)
                   (expand-setter #'elems #'id type size))))))))))
 
+;; Guile doesn't apply peval to 'max', so let's fix that so struct
+;; size calculations can be optimized to a constant.
+(define-syntax-rule (max a b)
+  (if (< a b) b a))
+
 (define-syntax define-bstruct*
   (lambda (stx)
     ;; Types can be recursive by referencing a type within the same
@@ -1154,12 +1375,6 @@
     ;; type accessor forms that need to be patched with a cyclical
     ;; reference *after* all the types are defined.
     (define recursive-pointers '())
-    (define primitives
-      '(u8 s8 u16 s16 u32 s32 u64 s64 f32 f64
-           int uint long ulong short ushort
-           size_t ssize_t ptrdiff_t intptr_t uintptr_t))
-    (define bit-field-primitives
-      (remove (lambda (t) (memq t '(f32 f64))) primitives))
     (define (target-endianness? e)
       (eq? e (target-endianness)))
     (define (resolve-endianness e)
@@ -1169,7 +1384,7 @@
         (_ e)))
     (define (compute-layout expr accessor group-ids packed? endianness)
       (syntax-case expr ()
-        ;; Modifiers
+        ;; Modifiers:
         ((packed expr)
          (symbolic-match? packed)
          (compute-layout #'expr accessor group-ids #t endianness))
@@ -1181,20 +1396,19 @@
               (identifier-memq? #'e '(native non-native big little)))
          (compute-layout #'expr accessor group-ids packed?
                          (resolve-endianness (syntax->datum #'e))))
-        ;; Previously defined types
+        ;; Types:
+        (prim
+         (primitive-bstruct-descriptor-identifier? #'prim)
+         #`(scalar (prim sizeof)
+                   (prim alignof)
+                   #,(target-endianness? endianness)
+                   prim))
         (type-id
-         (bstruct-descriptor-identifier? #'type-id)
+         (non-opaque-bstruct-descriptor-identifier? #'type-id)
          #'type-id)
         ((opaque)
          (symbolic-match? opaque)
          expr)
-        (primitive
-         (identifier-memq? #'primitive primitives)
-         (let ((type (syntax->datum #'primitive)))
-           #`(scalar #,(sizeof* type)
-                     #,(alignof* type)
-                     #,(target-endianness? endianness)
-                     primitive)))
         ((bits field ...)
          (symbolic-match? bits)
          (let lp ((field-stx #'(field ...)) (fields '()) (bits 0))
@@ -1236,28 +1450,28 @@
              (()
               ;; Round up to a multiple of align to get final
               ;; size.
-              (let ((size (* (ceiling (/ offset align)) align)))
-                #`(struct #,size #,align #,(reverse fields))))
+              #`(struct (let ((a #,align)) (* (ceiling (/ #,offset a)) a))
+                        #,align #,(reverse fields)))
              (((name expr) . rest)
               (identifier? #'name)
               (let* ((type (compute-layout #'expr
                                            #`(struct-field-ref #,accessor 'name)
                                            group-ids packed? endianness))
+                     (field-size (sizeof/syntax type))
                      (field-align (alignof/syntax type))
                      (padding (if packed?
                                   0
-                                  (modulo (- field-align
-                                             (modulo offset field-align))
-                                          field-align)))
-                     (offset (+ offset padding))
-                     (align (max align field-align)))
+                                  #`(let ((a #,field-align))
+                                      (modulo (- a (modulo #,offset a)) a))))
+                     (offset #`(+ #,offset #,padding))
+                     (align #`(max #,align #,field-align)))
                 (lp #'rest
                     (syntax-case #'name ()
                       (underscore
                        (identifier-eq? #'underscore '_)
                        fields)
                       (_ (cons #`(name #,offset #,type) fields)))
-                    (+ offset (sizeof/syntax type))
+                    #`(+ #,offset #,field-size)
                     align))))))
         ((union field ...)
          (and (symbolic-match? union)
@@ -1269,7 +1483,9 @@
              (((underscore expr) . rest-exprs)
               (identifier-eq? #'underscore '_)
               (let ((type (compute-layout #'expr #f group-ids packed? endianness)))
-                (loop #'rest-exprs fields (max size (sizeof/syntax type)) align)))
+                (loop #'rest-exprs fields
+                      #`(max #,size #,(sizeof/syntax type))
+                      align)))
              (((name expr) . rest)
               (identifier? #'name)
               (let ((type (compute-layout #'expr
@@ -1277,8 +1493,8 @@
                                           group-ids packed? endianness)))
                 (loop #'rest
                       (cons #`(name #,type) fields)
-                      (max size (sizeof/syntax type))
-                      (max align (alignof/syntax type))))))))
+                      #`(max #,size #,(sizeof/syntax type))
+                      #`(max #,align #,(alignof/syntax type))))))))
         ((array length expr)
          (and (symbolic-match? array)
               (exact-integer? (syntax->datum #'length))
@@ -1286,23 +1502,23 @@
          (let ((length (syntax->datum #'length))
                (type (compute-layout #'expr #`(array-type #,accessor)
                                      group-ids packed? endianness)))
-           #`(array #,(* (sizeof/syntax type) length)
+           #`(array (* #,(sizeof/syntax type) #,length)
                     #,(alignof/syntax type)
                     #,length #,type)))
         ((ptr expr)
          (identifier-eq? #'ptr '*)
-         ;; TODO: pointer size depends on the target.
-         (let ((size (ffi:sizeof '*))
-               (align (ffi:alignof '*)))
+         (let* ((size #'(%pointer sizeof))
+                (align #'(%pointer alignof)))
            (let loop ((expr #'expr))
              (syntax-case expr ()
                (void
                 (symbolic-match? void)
                 #`(pointer #,size #,align void))
                ;; Primitive pointer
-               (prim
-                (identifier-memq? #'prim primitives)
-                (let ((type (compute-layout #'prim #f group-ids packed? endianness)))
+               (primitive
+                (primitive-bstruct-descriptor-identifier? #'primitive)
+                (let ((type (compute-layout #'primitive #f group-ids
+                                            packed? endianness)))
                   #`(pointer #,size #,align #,type)))
                ;; Pointer to a pointer
                ((ptr expr)
@@ -1320,9 +1536,16 @@
                 (bstruct-descriptor-identifier? #'type-id)
                 #`(pointer #,size #,align type-id))))))))
     (define (compute-layout* expr id group-ids)
-      (compute-layout expr #`(bstruct-descriptor-type #,id)
-                      group-ids #f (target-endianness)))
-    (define (type-descriptor-id id)
+      (syntax-case expr ()
+        ;; Bare primitives are simple aliases, not scalars with an
+        ;; assigned size/align/endianness.
+        (primitive
+         (primitive-bstruct-descriptor-identifier? #'primitive)
+         expr)
+        (_
+         (compute-layout expr #`(bstruct-descriptor-type #,id)
+                         group-ids #f (target-endianness)))))
+    (define (generate-descriptor-id id)
       (datum->syntax id (symbol-append (string->symbol "% bstruct-descriptor-")
                                        (syntax->datum id))))
     (syntax-case stx ()
@@ -1332,12 +1555,10 @@
                              (compute-layout* expr id* #'(id ...)))
                            #'(id ...)
                            #'(expr ...)))
-                     ((type-id ...) (map type-descriptor-id #'(id ...)))
+                     ((type-id ...) (map generate-descriptor-id #'(id ...)))
                      (((recur-accessor recur-id) ...) recursive-pointers))
-         (with-syntax ((((size align) ...)
-                        (map (lambda (type)
-                               (list (sizeof/syntax type) (alignof/syntax type)))
-                             #'(type ...))))
+         (with-syntax (((size ...) (map sizeof/syntax #'(type ...)))
+                       ((align ...) (map alignof/syntax #'(type ...))))
            #'(begin
                ;; First, define the type descriptors.
                (define-bstruct-descriptor type-id id type . kwargs) ...