;;; guile-bstruct -- Binary structures for Guile
;;; Copyright © 2024 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;
;; A bstruct is a data type that encapsulates a bytevector and an
;; offset which interprets that bytevector based on a given layout.
;; Bstructs are useful for manipulating C structs when using the FFI,
;; or interpreting/manipulating packed binary data such as GPU vertex
;; buffers, or for data types that benefit from unboxed math
;; optimizations such as vectors and matrices.
;;
;; Inspired by guile-opengl's define-packed-struct and based on
;; "Ftypes: Structured foreign types" by Andy Keep and R. Kent Dybvig.
;;
;;     http://scheme2011.ucombinator.org/papers/Keep2011.pdf
;;
;; Features:
;;
;; - Efficiency through macro magic.  Procedural macros generate tasty
;; code for the compiler to munch on and emit efficient bytecode.
;; Runtime checks are reduced to the bare minimum.
;;
;; - Raw bytevector access mode.  Easily read/write structured data
;; from/to raw bytevectors without going through an intermediary
;; struct.  Very useful for batch processing in situations when the
;; overhead of creating wrapper structs would hinder throughput.
;;
;; - Cache friendly.  In performance sensitive code, many bstructs can
;; be stored in contiguous memory by pre-allocating a large bytevector
;; for the underlying storage.  Individual bstruct handles simply
;; point at different offsets.
;;
;;; Code:

(define-module (bstruct)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (system base target)
  #:use-module ((system foreign) #:prefix ffi:)
  #:use-module (system syntax)
  #: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
            bstruct->sexp
            bstruct->pointer
            pointer->bstruct
            bstruct-wrap
            bstruct-unwrap
            bstruct-alloc
            bstruct-sizeof
            bstruct-alignof
            bstruct-ref
            bstruct-set!
            bstruct-unpack
            bstruct-pack!
            bstruct-copy
            bstruct-copy!
            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)
  scalar?
  (size scalar-size)
  (align scalar-align)
  (native? scalar-native?)              ; native endianness?
  (type scalar-type))

(define-record-type <bit-field>
  (make-bit-field name offset length signed?)
  bit-field?
  (name bit-field-name)
  (offset bit-field-offset)
  (length bit-field-length)
  (signed? bit-field-signed?))

(define-record-type <bits>
  (make-bits size align native? fields)
  bits?
  (size bits-size)
  (align bits-align)
  (native? bits-native?)
  (fields bits-fields))

(define-record-type <struct-field>
  (make-struct-field name offset type)
  struct-field?
  (name struct-field-name)
  (offset struct-field-offset)
  (type struct-field-type))

(define-record-type <struct>
  (make-struct size align fields)
  %struct?
  (size struct-size)
  (align struct-align)
  (fields struct-fields))

(define-record-type <union-field>
  (make-union-field name type)
  union-field?
  (name union-field-name)
  (type union-field-type))

(define-record-type <union>
  (make-union size align fields)
  union?
  (size union-size)
  (align union-align)
  (fields union-fields))

(define-record-type <array>
  (make-array size align length type)
  array?
  (size array-size)
  (align array-align)
  (length array-length)
  (type array-type))

(define-record-type <pointer>
  (make-pointer size align type)
  pointer?
  (size pointer-size)
  (align pointer-align)
  ;; Mutable for setting up recursive types.
  (type pointer-type set-pointer-type!))

(define (struct-field-ref struct name)
  (and=> (find (match-lambda
                 (($ <struct-field> name*)
                  (eq? name name*)))
               (struct-fields struct))
         struct-field-type))

(define (union-field-ref struct name)
  (and=> (find (match-lambda
                 (($ <union-field> name*)
                  (eq? name name*)))
               (union-fields struct))
         union-field-type))

(define (bstruct-type? obj)
  (or (scalar? obj)
      (bits? obj)
      (%struct? obj)
      (union? obj)
      (array? obj)
      (pointer? obj)))

(define (sizeof type)
  (match type
    ((or ($ <scalar> size)
         ($ <bits> size)
         ($ <struct> size)
         ($ <union> size)
         ($ <array> size)
         ($ <pointer> size))
     size)))

(define (alignof type)
  (match type
    ((or ($ <scalar> _ align)
         ($ <bits> _ align)
         ($ <struct> _ align)
         ($ <union> _ align)
         ($ <array> _ align)
         ($ <pointer> _ align))
     align)))

(define-syntax-rule (assert expr who)
  (unless expr
    (raise-exception
     (make-exception (make-assertion-failure)
                     (make-exception-with-origin who)
                     (make-exception-with-irritants '(expr))))))

(define-syntax-rule (check-size i n who)
  (assert (and (>= i 0) (< i n)) who))

(define-inlinable (u64? x)
  (and (exact-integer? x) (<= 0 x (ash 1 64))))

;; Bstructs form a shallow vtable hierarchy.
(define <bstruct-descriptor>
  (make-vtable (string-append standard-vtable-fields "pwpw")
               (lambda (desc port)
                 (format port "#<bstruct-descriptor ~a>"
                         (bstruct-descriptor-name desc)))))

(define (bstruct-descriptor-name descriptor)
  (struct-ref descriptor vtable-offset-user))

(define (bstruct-descriptor-type descriptor)
  (struct-ref descriptor (+ vtable-offset-user 1)))

(define (bstruct-descriptor-sizeof descriptor)
  (sizeof (bstruct-descriptor-type descriptor)))

(define (print-bstruct bs port)
  (format port "#<~a ~a>"
          (bstruct-descriptor-name (struct-vtable bs))
          (bstruct->sexp bs)))

(define* (make-bstruct-descriptor name type #:key (printer print-bstruct))
  (assert (bstruct-type? type) 'make-bstruct-descriptor)
  (make-struct/no-tail <bstruct-descriptor>
                       (make-struct-layout "pwpwpw")
                       printer name type))

(define (bstruct-descriptor? obj)
  (and (struct? obj) (eq? (struct-vtable obj) <bstruct-descriptor>)))

(define (%bstruct? obj)
  (and (struct? obj) (bstruct-descriptor? (struct-vtable obj))))

(define (bstruct-bytevector bs)
  (assert (%bstruct? bs) 'bstruct-bytevector)
  (struct-ref bs 0))

(define (bstruct-offset bs)
  (assert (%bstruct? bs) 'bstruct-bytevector)
  (struct-ref bs 1))

(define (bstruct-length bs)
  (assert (%bstruct? bs) 'bstruct-bytevector)
  (struct-ref bs 2))

(define (bstruct-type bs)
  (assert (%bstruct? bs) 'bstruct-bytevector)
  (bstruct-descriptor-type (struct-vtable bs)))

;; Bstructs are composed of a type descriptor, a bytevector that
;; provides storage, an offset pointing to the start of the struct
;; data within that bytevector, and the number of contiguous structs
;; within.
(define (%make-bstruct descriptor bv offset n)
  (make-struct/no-tail descriptor bv offset n))

(define (make-bstruct descriptor bv offset n)
  (assert (bstruct-descriptor? descriptor) 'make-bstruct)
  (assert (bytevector? bv) 'make-bstruct)
  (assert (exact-integer? offset) 'make-bstruct)
  (assert (>= offset 0) 'make-bstruct)
  (assert (<= (+ offset (* (bstruct-descriptor-sizeof descriptor) n))
              (bytevector-length bv))
          'make-bstruct)
  (%make-bstruct descriptor bv offset n))

;; Platform ABI details
(define (non-target-endianness)
  (if (eq? (target-endianness) (endianness little))
      (endianness big)
      (endianness little)))

(define (sizeof* type)
  (match type
    ((or 'u8 's8) 1)
    ((or 'u16 's16) 2)
    ((or 'u32 's32 'f32) 4)
    ((or 'u64 's64 'f64) 8)
    (_
     (if (string=? %host-type (target-type))
         (match type
           ('uint (ffi:sizeof ffi:unsigned-int))
           ('int (ffi:sizeof ffi:int))
           ('ulong (ffi:sizeof ffi:unsigned-long))
           ('long (ffi:sizeof ffi:long))
           ('ushort (ffi:sizeof ffi:unsigned-short))
           ('short (ffi:sizeof ffi:short))
           ('size_t (ffi:sizeof ffi:size_t))
           ('ssize_t (ffi:sizeof ffi:ssize_t))
           ('ptrdiff_t (ffi:sizeof ffi:ptrdiff_t))
           ('intptr_t (ffi:sizeof ffi:intptr_t))
           ('uintptr_t (ffi:sizeof ffi:uintptr_t)))
         ;; FIXME: Fill in with proper ABI details.  We will lazily
         ;; evaluate this work when we hit a problem in a cross build.
         (match type
           ('uint 4)
           ('int 4)
           ('ulong 8)
           ('long 8)
           ('ushort 2)
           ('short 2)
           ('size_t (target-word-size))
           ('ssize_t (target-word-size))
           ('ptrdiff_t (target-word-size))
           ('intptr_t (target-word-size))
           ('uintptr_t (target-word-size)))))))

(define (alignof* type)
  (match type
    ((or 'u8 's8) 1)
    ((or 'u16 's16) 2)
    ((or 'u32 's32 'f32) 4)
    ((or 'u64 's64 'f64) 8)
    (_
     (if (string=? %host-type (target-type))
         (match type
           ('uint (ffi:sizeof ffi:unsigned-int))
           ('int (ffi:sizeof ffi:int))
           ('ulong (ffi:sizeof ffi:unsigned-long))
           ('long (ffi:sizeof ffi:long))
           ('ushort (ffi:sizeof ffi:unsigned-short))
           ('short (ffi:sizeof ffi:short))
           ('size_t (ffi:sizeof ffi:size_t))
           ('ssize_t (ffi:sizeof ffi:ssize_t))
           ('ptrdiff_t (ffi:sizeof ffi:ptrdiff_t))
           ('intptr_t (ffi:sizeof ffi:intptr_t))
           ('uintptr_t (ffi:sizeof ffi:uintptr_t))
           ('* (ffi:sizeof '*)))
         (match type
           ('uint 4)
           ('int 4)
           ('ulong 8)
           ('long 8)
           ('ushort 2)
           ('short 2)
           ('size_t (target-word-size))
           ('ssize_t (target-word-size))
           ('ptrdiff_t (target-word-size))
           ('intptr_t (target-word-size))
           ('uintptr_t (target-word-size))
           ('* (target-word-size)))))))

;; It is useful to see bstructs in s-expression form when working
;; at the REPL.
(define (bstruct->sexp bs)
  (let ((bv (bstruct-bytevector bs)))
    (let loop ((type (bstruct-type bs)) (offset (bstruct-offset bs)))
      (match type
        ((? bstruct-descriptor? desc)
         (loop (bstruct-descriptor-type desc) offset))
        (($ <scalar> _ _ native? type)
         (let ((e (if native? (target-endianness) (non-target-endianness))))
           (match type
             ('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)))
             ('unsigned-long (bytevector-uint-ref bv offset e (ffi:sizeof ffi:unsigned-long)))
             ('long (bytevector-sint-ref bv offset e (ffi:sizeof ffi:long)))
             ('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)))
             ('ptrdiff_t (bytevector-sint-ref bv offset e (ffi:sizeof ffi:ptrdiff_t)))
             ('intptr_t (bytevector-sint-ref bv offset e (ffi:sizeof ffi:intptr_t)))
             ('uintptr_t (bytevector-uint-ref bv offset e (ffi:sizeof ffi:uintptr_t))))))
        (($ <bits> size _ native? fields)
         (let ((e (if native? (target-endianness) (non-target-endianness))))
           `(bits
             ,@(map (match-lambda
                      (($ <bit-field> name start len signed?)
                       (list name
                             (let ((x (ash (logand (bytevector-uint-ref bv offset
                                                                        e size)
                                                   (ash (1- (ash 1 len)) start))
                                           (- start))))
                               (if signed?
                                   (centered-remainder x (ash 1 len))
                                   x)))))
                    fields))))
        (($ <struct> _ _ fields)
         `(struct ,@(map (match-lambda
                           (($ <struct-field> name offset* type)
                            (list name (loop type (+ offset offset*)))))
                         fields)))
        (($ <union> _ _ fields)
         `(union ,@(map (match-lambda
                          (($ <union-field> name type)
                           (list name (loop type offset))))
                        fields)))
        (($ <array> _ _ length type)
         (let ((size (sizeof type)))
           `(array ,@(map (lambda (i)
                            (loop type (+ offset (* i size))))
                          (iota length)))))
        (($ <pointer>)
         `(* ,(bytevector-uint-ref bv offset (native-endianness)
                                   (ffi:sizeof '*))))))))

;; Macro helpers that query properties attached to syntax
;; transformers.
(define (identifier-properties id)
  (and (identifier? id)
       (let-values (((kind val) (syntax-local-binding id)))
         (and (eq? kind 'macro)
              (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 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)
  (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)
  (identifier-eq? #'id 'id))
(define (identifier-memq? stx syms)
  (and (identifier? stx) (memq (syntax->datum stx) syms)))

;; 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 ()
      (id
       (identifier? #'id)
       #'(case-lambda
           ((obj) (%bstruct? obj))
           ((<type> obj)
            (and (bstruct? obj)
                 (bstruct-descriptor? <type>)
                 (eq? (struct-vtable obj) <type>)))))
      ((_ obj)
       #'(%bstruct? obj))
      ((_ <type> obj)
       (bstruct-descriptor-identifier? #'<type>)
       #'(match obj
           (($ <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 ()
      ((_ <type> a b)
       (bstruct-descriptor-identifier? #'<type>)
       #'(match a
           (($ <type> bv-a offset-a)
            (match b
              (($ <type> bv-b offset-b)
               (let ((n (bstruct-sizeof <type>)))
                 (let loop ((i 0))
                   (cond
                    ((= i n) #t)
                    ((= (bytevector-u8-ref bv-a (+ offset-a i))
                        (bytevector-u8-ref bv-b (+ offset-b i)))
                     (loop (+ i 1)))
                    (else #f))))))))))))

;; Create a pointer to the bstruct or some element within the bstruct.
(define-syntax bstruct->pointer
  (lambda (stx)
    (syntax-case stx ()
      ((_ (<type> i) bs)
       (bstruct-descriptor-identifier? #'<type>)
       #'(match bs
           (($ <type> bv (? u64? offset))
            (ffi:bytevector->pointer bv offset))))
      ((_ (<type> i) bs (elem ...))
       (bstruct-descriptor-identifier? #'<type>)
       #'(match bs
           (($ <type> bv (? u64? offset) (? u64? n))
            (check-size i n 'bstruct->pointer)
            (let ((offset (+ offset (* (bstruct-sizeof <type>) i))))
              (call-with-values (lambda () ((<type> offset elem ...) bv offset))
                ffi:bytevector->pointer)))))
      ((_ (<type> i) bs elem)
       #'(bstruct->pointer (<type> i) bs (elem)))
      ((_ <type> bs)
       #'(bstruct->pointer (<type> 0) bs))
      ((_ <type> bs (elem ...))
       #'(bstruct->pointer (<type> 0) bs (elem ...)))
      ((_ <type> bs elem)
       #'(bstruct->pointer (<type> 0) bs (elem))))))

(define-syntax pointer->bstruct
  (lambda (stx)
    (syntax-case stx ()
      ((_ <type> ptr n)
       (non-opaque-bstruct-descriptor-identifier? #'<type>)
       #'(let ((size (* (bstruct-sizeof <type>) n)))
           (make-bstruct <type> (ffi:pointer->bytevector ptr size) 0 n)))
      ((_ <type> ptr)
       #'(pointer->bstruct <type> ptr 1)))))

;; Wrap a bytevector in a bstruct.
(define-syntax bstruct-wrap
  (lambda (stx)
    (syntax-case stx ()
      ((_ <type> bv offset n)
       (non-opaque-bstruct-descriptor-identifier? #'<type>)
       #'(make-bstruct (<type> descriptor) bv offset n))
      ((_ <type> bv offset)
       #'(bstruct-wrap <type> bv offset 1)))))

;; Unwrap a bstruct to a bytevector + offset + count.
(define-syntax bstruct-unwrap
  (lambda (stx)
    (syntax-case stx ()
      ((_ <type> bs)
       (bstruct-descriptor-identifier? #'<type>)
       #`(match bs
           (($ <type> bv offset n)
            (values bv offset n)))))))

;; 'bstruct-pack!' and 'bstruct-unpack' allow for directly
;; interpreting bytevector contents as structured data.
(define-syntax bstruct-pack!
  (lambda (stx)
    (define (flatten-elems stx)
      (append-map (lambda (stx)
                    (syntax-case stx ()
                      ((-> root-elem sub-elems ...)
                       (and (symbolic-match? ->)
                            (identifier? #'root-elem))
                       (map (lambda (stx)
                              (syntax-case stx ()
                                (((sub-elem ...) val)
                                 #'((root-elem sub-elem ...) val))))
                            (flatten-elems #'(sub-elems ...))))
                      (((elem ...) val)
                       #'(((elem ...) val)))
                      ((elem val)
                       #'(((elem) val)))))
                  stx))
    (syntax-case stx ()
      ((_ <type> bv i elem ...)
       (non-opaque-bstruct-descriptor-identifier? #'<type>)
       (with-syntax (((((elem ...) val) ...)
                      (flatten-elems #'(elem ...))))
         #'(begin
             ((<type> setter elem ...) bv i val)
             ...))))))

(define-syntax bstruct-unpack
  (lambda (stx)
    (syntax-case stx ()
      ((_ <type> bv i elem ...)
       (non-opaque-bstruct-descriptor-identifier? #'<type>)
       #`(values
          #,@(map (lambda (elem)
                    (syntax-case elem ()
                      ((e ...)
                       #'((<type> getter e ...) bv i))
                      (e
                       #'((<type> getter e) bv i))))
                  #'(elem ...)))))))

;; Allocate a fresh bstruct that wraps a fresh bytevector big
;; enough to store the entire structure.
(define-syntax bstruct-alloc
  (syntax-rules ()
    ((_ (<type> n) (i elem ...) ...)
     (let* ((size (bstruct-sizeof <type>))
            (len (* size n))
            (bv (make-bytevector len 0)))
       (bstruct-pack! <type> bv (* size i) elem ...)
       ...
       (bstruct-wrap <type> bv 0)))
    ((_ <type> elem ...)
     (bstruct-alloc (<type> 1) (0 elem ...)))))

;; Return the value of some elements.
(define-syntax bstruct-ref
  (syntax-rules ()
    ((_ (<type> i) bs elem ...)         ; array
     (match bs
       (($ <type> bv (? u64? offset) (? u64? n))
        (assert (u64? i) 'bstruct-ref)
        (check-size i n 'bstruct-ref)
        (let ((offset (+ offset (* (bstruct-sizeof <type>) i))))
          (bstruct-unpack <type> bv offset elem ...)))))
    ((_ <type> bs elem ...)
     (bstruct-ref (<type> 0) bs elem ...))))

;; Set the value of some elements.
(define-syntax bstruct-set!
  (syntax-rules ()
    ((_ (<type> i) bs elem ...)         ; array
     (match bs
       (($ <type> bv (? u64? offset) (? u64? n))
        (assert (u64? i) 'bstruct-set!)
        (check-size i n 'bstruct-set!)
        (let ((offset (+ offset (* (bstruct-sizeof <type>) i))))
          (bstruct-pack! <type> bv offset elem ...)))))
    ((_ <type> bs elem ...)
     (bstruct-set! (<type> 0) bs elem ...))))

;; Imperative/functional struct copying.
(define-syntax-rule (bstruct-copy! <type> src dst)
  (match src
    (($ <type> src-bv (? u64? src-offset) (? u64? src-n))
     (match dst
       (($ <type> dst-bv (? u64? dst-offset) (? u64? dst-n))
        (check-size src-n (1+ dst-n) 'bstruct-copy!)
        (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))
     (let ((dst (bstruct-alloc (<type> n))))
       (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)
      (syntax-case stx ()
        ((name offset len signed?)
         #`(make-bit-field 'name offset len signed?))))
    (define (build-struct-field stx)
      (syntax-case stx ()
        ((name offset type)
         #`(make-struct-field 'name offset #,(build-type #'type)))))
    (define (build-union-field stx)
      (syntax-case stx ()
        ((name type)
         #`(make-union-field 'name #,(build-type #'type)))))
    (define (build-type desc)
      (syntax-case desc ()
        (id
         (identifier? #'id)
         desc)
        ((scalar size align native? type)
         (symbolic-match? scalar)
         (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 ...))))
           #'(make-bits size align native? (list field ...))))
        ((struct size align (field ...))
         (symbolic-match? struct)
         (with-syntax (((field ...) (map build-struct-field #'(field ...))))
           #'(make-struct size align (list field ...))))
        ((union size align (field ...))
         (symbolic-match? union)
         (with-syntax (((field ...) (map build-union-field #'(field ...))))
           #'(make-union size align (list field ...))))
        ((array size align length desc)
         (symbolic-match? array)
         #`(make-array size align length #,(build-type #'desc)))
        ((pointer size align (recur _))
         (and (symbolic-match? pointer) (symbolic-match? recur))
         #'(make-pointer size align #f))
        ((pointer size align void)
         (and (symbolic-match? pointer) (symbolic-match? void))
         #'(make-pointer size align #f))
        ((pointer size align desc)
         (symbolic-match? pointer)
         #`(make-pointer size align #,(build-type #'desc)))))
    (syntax-case stx ()
      ;; Opaque types have no descriptor.
      ((_ 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)))))))

(define (sizeof/syntax type)
  (syntax-case type ()
    ((scalar size _ _ _)
     (symbolic-match? scalar)
     #'size)
    ((bits size _ _ _)
     (symbolic-match? bits)
     #'size)
    ((struct size _ _)
     (symbolic-match? struct)
     #'size)
    ((union size _ _)
     (symbolic-match? union)
     #'size)
    ((array size _ _ _)
     (symbolic-match? array)
     #'size)
    ((pointer size _ _)
     (symbolic-match? pointer)
     #'size)
    ((opaque)
     (symbolic-match? opaque)
     #f)
    (id
     (bstruct-descriptor-identifier? #'id)
     #'(id sizeof))))
(define (alignof/syntax type)
  (syntax-case type ()
    ((scalar _ align _ _)
     (symbolic-match? scalar)
     #'align)
    ((bits _ align _ _)
     (symbolic-match? bits)
     #'align)
    ((struct _ align _)
     (symbolic-match? struct)
     #'align)
    ((union _ align _)
     (symbolic-match? union)
     #'align)
    ((array _ align _ _)
     (symbolic-match? array)
     #'align)
    ((pointer _ align _)
     (symbolic-match? pointer)
     #'align)
    ((opaque)
     (symbolic-match? opaque)
     #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
    ((elem ...)
     (let loop ((stx #'(elem ...)) (type type) (offset 0))
       (syntax-case type ()
         (id
          (bstruct-descriptor-identifier? #'id)
          ;; Recursively invoke macro for referenced type to produce
          ;; the accessor.
          (syntax-case stx ()
            ((elem ...)
             (proc #`(id #,(datum->syntax #f op) elem ...)
                   offset))))
         ((scalar _ _ _ _)
          (symbolic-match? scalar)
          (syntax-case stx ()
            (() (proc type offset))))
         ((bits size _ native? (field ...))
          (symbolic-match? bits)
          (syntax-case stx ()
            ((e)
             (identifier? #'e)
             (let ((name (syntax->datum #'e)))
               (let field-lp ((fields #'(field ...)))
                 (syntax-case fields ()
                   (() (syntax-violation who "no such bit field" #'e))
                   (((name* offset* len signed?) . rest)
                    (if (identifier-eq? #'name* name)
                        (proc #`(bit-field size offset* len signed? native?) offset)
                        (field-lp #'rest)))))))))
         ((struct _ _ (field ...))
          (symbolic-match? struct)
          (syntax-case stx ()
            ((e elem ...)
             (identifier? #'e)
             (let ((name (syntax->datum #'e)))
               (let field-lp ((fields #'(field ...)))
                 (syntax-case fields ()
                   (() (syntax-violation who "no such struct field" #'e))
                   (((name* offset* type*) . rest)
                    (if (identifier-eq? #'name* name)
                        (loop #'(elem ...) #'type* #`(+ #,offset offset*))
                        (field-lp #'rest)))))))))
         ((union _ _ (field ...))
          (symbolic-match? union)
          (syntax-case stx ()
            ((e elem ...)
             (identifier? #'e)
             (let ((name (syntax->datum #'e)))
               (let field-lp ((fields #'(field ...)))
                 (syntax-case fields ()
                   (() (syntax-violation who "no such union field" #'e))
                   (((name* type) . rest)
                    (if (identifier-eq? #'name* name)
                        (loop #'(elem ...) #'type offset)
                        (field-lp #'rest)))))))))
         ((array _ _ length type)
          (symbolic-match? array)
          (syntax-case stx ()
            ((i elem ...)
             (loop #'(elem ...) #'type
                   #`(+ #,offset
                        (* (let ()
                             ;; if 'i' is a constant then
                             ;; these checks will be elided
                             ;; by the compiler.
                             (assert (u64? i) 'bstruct-accessor)
                             (assert (< -1 i length) 'bstruct-accessor)
                             i)
                           #,(sizeof/syntax #'type)))))))
         ;; Void/opaque pointers cannot be dereferenced.
         ((pointer _ _ void)
          (and (symbolic-match? pointer)
               (symbolic-match? void))
          (syntax-case stx ()
            (() (proc type offset))))
         ((pointer _ _ opaque)
          (and (symbolic-match? pointer)
               (opaque-bstruct-descriptor-identifier? #'opaque))
          (syntax-case stx ()
            (() (proc type offset))))
         ((pointer _ _ type*)
          (symbolic-match? pointer)
          (let ((type* (syntax-case #'type* ()
                         ((recur type*)
                          (symbolic-match? recur)
                          #'type*)
                         (_ #'type*))))
            (define (expand-pointer-accessor stx)
              (syntax-case stx ()
                (() (proc type offset))
                ;; Pointer dereference.
                (((* index) elem ...)
                 (symbolic-match? *)
                 (with-syntax ((e (datum->syntax #f (target-endianness)))
                               (ptr-size (target-word-size))
                               (size (sizeof/syntax type*))
                               (body (syntax-case type* ()
                                       (id
                                        (identifier? #'id)
                                        (proc #`(id #,(datum->syntax #f op)
                                                    elem ...)
                                              0))
                                       (_ (loop #'(elem ...) type* 0)))))
                   ;; 'bv' and 'i' are the lexical variables
                   ;; containing the bytevector and offset for
                   ;; getting/setting.  Every time we encounter a
                   ;; pointer dereference we need to shadow the old
                   ;; variables with new ones.
                   #`(let* ((base (bytevector-sint-ref bv (+ i #,offset)
                                                       'e ptr-size))
                            (address (+ base (* size index)))
                            (ptr (ffi:make-pointer address))
                            (bv (ffi:pointer->bytevector ptr size))
                            (i 0))
                       body)))
                ;; Pointer dereference with implied index of 0.
                ((* elem ...)
                 (symbolic-match? *)
                 (expand-pointer-accessor #'((* 0) elem ...)))))
            (expand-pointer-accessor stx))))))))
(define (expand-offset elems id type)
  #`(lambda (bv i)
      #,(expand-accessor
         (lambda (type offset)
           (with-syntax ((offset offset))
             (syntax-case type ()
               (id*
                (bstruct-descriptor-identifier? #'id*)
                #'(values bv offset))
               ((pointer _ _ _)
                (symbolic-match? pointer)
                #'(values bv offset))
               ((scalar size align native? type)
                (symbolic-match? scalar)
                #'(values bv offset))
               ((bit-field size start len signed? native?)
                (symbolic-match? bit-field)
                (syntax-violation 'bstruct->pointer
                                  "cannot take address of bit field"
                                  elems))
               (sub-offset
                #'(sub-offset bv (+ i offset))))))
         'bstruct->pointer elems id 'offset type)))
(define (expand-getter elems id type)
  #`(lambda (bv i)
      #,(expand-accessor
         (lambda (type offset)
           (with-syntax ((offset offset))
             (syntax-case type ()
               (id*
                (bstruct-descriptor-identifier? #'id*)
                #'(make-bstruct id* bv (+ i offset)))
               ((pointer _ _ _)
                (symbolic-match? pointer)
                #`(ffi:make-pointer
                   (bytevector-sint-ref bv (+ i offset)
                                        '#,(datum->syntax #f (target-endianness))
                                        #,(target-word-size))))
               ((scalar size align native? type)
                (symbolic-match? scalar)
                #'((type getter native?) bv (+ i offset)))
               ((bit-field size start len signed? native?)
                (symbolic-match? bit-field)
                (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))))
                        (if signed?
                            (centered-remainder x (ash 1 len))
                            x)))))
               (sub-get
                #'(sub-get bv (+ i offset))))))
         'bstruct-unpack elems id 'getter type)))
(define (expand-setter elems id type size)
  #`(lambda (bv i x)
      #,(expand-accessor
         (lambda (type offset)
           (with-syntax ((offset offset))
             (syntax-case type ()
               (id
                (bstruct-descriptor-identifier? #'id)
                #'(match x
                    (($ id src j)
                     (bytevector-copy! src j bv (+ i offset) (id sizeof)))))
               ((pointer _ _ _)
                (symbolic-match? pointer)
                #`(bytevector-sint-set! bv (+ i offset)
                                        (ffi:pointer-address x)
                                        '#,(datum->syntax #f (target-endianness))
                                        #,(target-word-size)))
               ((scalar size align native? type)
                (symbolic-match? scalar)
                #'((type setter native?) bv (+ i offset) x))
               ((bit-field size start len signed? native?)
                (symbolic-match? bit-field)
                (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)))
                             (rest (logand (getter bv (+ i offset)) mask)))
                        (define (fail)
                          (error "bit field value out of range" x))
                        (if signed?
                            (if (<= (ash -1 (1- len)) x (1- (ash 1 (1- len))))
                                ;; Convert to unsigned representation.
                                (let ((u (logand (1- (ash 1 len)) x)))
                                  (setter bv (+ i offset)
                                          (logior rest (ash u start))))
                                (fail))
                            (if (<= 0 x (1- (ash 1 len)))
                                (setter bv (+ i offset)
                                        (logior rest (ash x start)))
                                (fail)))))))
               (sub-set!
                #'(sub-set! bv (+ i offset) x)))))
         'bstruct-pack! elems id 'setter type)))

(define-syntax define-bstruct-macro
  (lambda (stx)
    (syntax-case stx ()
      ;; Opaque types have very limited capabilities.
      ((_ id type-id size align (opaque))
       (symbolic-match? opaque)
       #'(define-syntax id
           (lambda (stx)
             #((bstruct? . #t)
               (bstruct-opaque? . #t))
             (syntax-case stx ()
               ;; Identifier syntax to provide the illusion that
               ;; this macro is just a record type descriptor.
               (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))
             (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))
                 ((_ getter . elems)
                  (symbolic-match? getter)
                  (expand-getter #'elems #'id type))
                 ((_ setter . elems)
                  (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
    ;; type group, possibly itself.  So, we maintain a list of pointer
    ;; type accessor forms that need to be patched with a cyclical
    ;; reference *after* all the types are defined.
    (define recursive-pointers '())
    (define (target-endianness? e)
      (eq? e (target-endianness)))
    (define (resolve-endianness e)
      (match e
        ('native (target-endianness))
        ('non-native (non-target-endianness))
        (_ e)))
    (define (compute-layout expr accessor group-ids packed? endianness)
      (syntax-case expr ()
        ;; Modifiers:
        ((packed expr)
         (symbolic-match? packed)
         (compute-layout #'expr accessor group-ids #t endianness))
        ((unpacked expr)
         (symbolic-match? unpacked)
         (compute-layout #'expr accessor group-ids #f endianness))
        ((endian e expr)
         (and (symbolic-match? endian)
              (identifier-memq? #'e '(native non-native big little)))
         (compute-layout #'expr accessor group-ids packed?
                         (resolve-endianness (syntax->datum #'e))))
        ;; Types:
        (prim
         (primitive-bstruct-descriptor-identifier? #'prim)
         #`(scalar (prim sizeof)
                   (prim alignof)
                   #,(target-endianness? endianness)
                   prim))
        (type-id
         (non-opaque-bstruct-descriptor-identifier? #'type-id)
         #'type-id)
        ((opaque)
         (symbolic-match? opaque)
         expr)
        ((bits field ...)
         (symbolic-match? bits)
         (let lp ((field-stx #'(field ...)) (fields '()) (bits 0))
           (syntax-case field-stx ()
             (()
              (let ()
                (define (finish size)
                  #`(bits #,size #,size
                          #,(target-endianness? endianness)
                          #,(reverse fields)))
                (cond
                 ((<= bits 8)  (finish 1))
                 ((<= bits 16) (finish 2))
                 ((<= bits 32) (finish 4))
                 ((<= bits 64) (finish 8))
                 (else
                  (syntax-violation 'define-bstruct
                                    "bit fields exceed maximum of 64 bits"
                                    stx)))))
             (((underscore len) . rest)
              (and (identifier-eq? #'underscore '_)
                   (exact-integer? (syntax->datum #'len))
                   (positive? (syntax->datum #'len)))
              (lp #'rest fields (+ bits (syntax->datum #'len))))
             (((name len sign) . rest)
              (and (identifier? #'name)
                   (identifier-memq?  #'sign '(u s))
                   (exact-integer? (syntax->datum #'len))
                   (positive? (syntax->datum #'len)))
              (let ((signed? (identifier-eq? #'sign 's)))
                (lp #'rest
                    (cons #`(name #,bits len #,signed?) fields)
                    (+ bits (syntax->datum #'len))))))))
        ((struct field ...)
         (and (symbolic-match? struct)
              (not (null? #'(field ...))))
         (let lp ((stx #'(field ...)) (fields '()) (offset 0) (align 0))
           (syntax-case stx ()
             (()
              ;; Round up to a multiple of align to get final
              ;; size.
              #`(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
                                  #`(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 #,field-size)
                    align))))))
        ((union field ...)
         (and (symbolic-match? union)
              (not (null? #'(field ...))))
         (let loop ((stx #'(field ...)) (fields '()) (size 0) (align 0))
           (syntax-case stx ()
             (()
              #`(union #,size #,align #,(reverse fields)))
             (((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)))
             (((name expr) . rest)
              (identifier? #'name)
              (let ((type (compute-layout #'expr
                                          #`(struct-field-ref #,accessor 'name)
                                          group-ids packed? endianness)))
                (loop #'rest
                      (cons #`(name #,type) fields)
                      #`(max #,size #,(sizeof/syntax type))
                      #`(max #,align #,(alignof/syntax type))))))))
        ((array length expr)
         (and (symbolic-match? array)
              (exact-integer? (syntax->datum #'length))
              (positive? (syntax->datum #'length)))
         (let ((length (syntax->datum #'length))
               (type (compute-layout #'expr #`(array-type #,accessor)
                                     group-ids packed? endianness)))
           #`(array (* #,(sizeof/syntax type) #,length)
                    #,(alignof/syntax type)
                    #,length #,type)))
        ((ptr expr)
         (identifier-eq? #'ptr '*)
         (let* ((size #'(%pointer sizeof))
                (align #'(%pointer alignof)))
           (let loop ((expr #'expr))
             (syntax-case expr ()
               (void
                (symbolic-match? void)
                #`(pointer #,size #,align void))
               ;; Primitive pointer
               (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)
                (identifier-eq? #'ptr '*)
                #`(pointer #,size #,align #,(loop #'expr)))
               ;; Recursive reference to a type within this type group.
               (type-id
                (any (lambda (id) (bound-identifier=? #'type-id id)) group-ids)
                (begin
                  (set! recursive-pointers
                        (cons (list accessor #'type-id) recursive-pointers))
                  #`(pointer #,size #,align (recur type-id))))
               ;; Reference to a type outside of this type group.
               (type-id
                (bstruct-descriptor-identifier? #'type-id)
                #`(pointer #,size #,align type-id))))))))
    (define (compute-layout* expr id group-ids)
      (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 ()
      ((_ (id expr . kwargs) ...)
       (with-syntax (((type ...)
                      (map (lambda (id* expr)
                             (compute-layout* expr id* #'(id ...)))
                           #'(id ...)
                           #'(expr ...)))
                     ((type-id ...) (map generate-descriptor-id #'(id ...)))
                     (((recur-accessor recur-id) ...) recursive-pointers))
         (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) ...
               ;; Then tie the knots for recursive pointer types.
               (set-pointer-type! recur-accessor recur-id) ...
               ;; Finally, define the wrapper macros.
               (define-bstruct-macro id type-id size align type . kwargs) ...)))))))

(define-syntax define-bstruct
  (lambda (stx)
    (define (distinct? lst)
      (let lp ((remaining lst) (seen '()))
        (match remaining
          (() #t)
          ((x . rest)
           (if (memq x seen)
               #f
               (lp rest (cons x seen)))))))
    (syntax-case stx ()
      ;; Type group definition.  Types defined in the same group can
      ;; contain recursive pointer references to each other.
      ((_ (id . args) ...)
       (and (not (null? #'(id ...)))
            (every identifier? #'(id ...))
            ;; Duplicate ids not allowed in a type group.
            (distinct? (syntax->datum #'(id ...))))
       ;; Handle the special case of opaque types having empty
       ;; specifications.
       (with-syntax ((((expr . kwargs) ...)
                      (map (lambda (stx)
                             (syntax-case stx ()
                               (() #'((opaque)))
                               (_ stx)))
                           #'(args ...))))
         #'(define-bstruct* (id expr . kwargs) ...)))
      ;; A single type definition is a type group of one.
      ((_ id . args)
       (identifier? #'id)
       #'(define-bstruct (id . args))))))