Add bytestruct module.

4 files changed, 1505 insertions, 0 deletions

diff --git a/.dir-locals.el b/.dir-locals.el
index 8f59de9..41a954b 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -5,6 +5,7 @@
    (eval . (put 'test-group 'scheme-indent-function 1))
    (eval . (put 'sdl2:call-with-surface 'scheme-indent-function 1))
    (eval . (put 'call-with-loaded-image 'scheme-indent-function 3))
+   (eval . (put 'with-ellipsis 'scheme-indent-function 1))
    (eval . (put 'with-blend-mode 'scheme-indent-function 1))
    (eval . (put 'with-polygon-mode 'scheme-indent-function 1))
    (eval . (put 'with-cull-face-mode 'scheme-indent-function 1))
diff --git a/Makefile.am b/Makefile.am
index 420b46e..b1cc139 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -48,6 +48,7 @@ SOURCES = 					\
   chickadee/data/heap.scm			\
   chickadee/data/array-list.scm			\
   chickadee/data/queue.scm			\
+  chickadee/data/bytestruct.scm			\
   chickadee/data/quadtree.scm			\
   chickadee/data/grid.scm			\
   chickadee/data/path-finding.scm		\
@@ -102,6 +103,7 @@ SOURCES = 					\
   chickadee/cli/bundle.scm
 
 TESTS =						\
+  tests/bytestruct.scm				\
   tests/base64.scm				\
   tests/vector.scm				\
   tests/rect.scm				\
diff --git a/chickadee/data/bytestruct.scm b/chickadee/data/bytestruct.scm
new file mode 100644
index 0000000..cf60e69
--- /dev/null
+++ b/chickadee/data/bytestruct.scm
@@ -0,0 +1,1226 @@
+;;; Chickadee Game Toolkit
+;;; 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 bytestruct is a data type that encapsulates a bytevector and an
+;; offset which interprets that bytevector based on a given layout.
+;; Bytestructs are useful for foreign data when using the C FFI, GPU
+;; buffer data, and 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 gnaw 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 filling up GPU buffers when the overhead
+;; of creating wrapper structs would kill performance.
+;;
+;; - Arena allocator friendly.  In performance sensitive code, many
+;; bytestructs can be stored in contiguous memory by sharing a large
+;; bytevector for the underlying storage.  Individual bytestruct
+;; handles simply point at different offsets.
+;;
+;; Why not just use guile-bytestructures?  Well, since the performance
+;; of bytestructs is critical to the overall performance of Chickadee,
+;; it's important that Chickadee has full control over the
+;; implementation so it can be easily tweaked as necessary without
+;; involving an upstream.  Also, guile-bytestructures doesn't cover
+;; the raw bytevector packing/unpacking case.  Lastly, now that
+;; Chickadee is ASL 2.0 licensed, the GPLv3 license is not a desirable
+;; property in a dependency.  We're also trying to keep Chickadee's
+;; dependency graph as small as possible.
+;;
+;;; Code:
+
+(define-module (chickadee data bytestruct)
+  #: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 (bytestruct?
+            bytestruct=?
+            bytestruct-type
+            bytestruct->sexp
+            bytestruct->pointer
+            pointer->bytestruct
+            bytestruct-wrap
+            bytestruct-unwrap
+            bytestruct-alloc
+            bytestruct-sizeof
+            bytestruct-alignof
+            bytestruct-ref
+            bytestruct-&ref
+            bytestruct-set!
+            bytestruct-unpack
+            bytestruct-pack!
+            bytestruct-copy
+            bytestruct-copy!
+
+            define-bytestruct
+            define-bytestruct-predicate
+            define-bytestruct-getter
+            define-bytestruct-setter
+            define-bytestruct-accessor
+            define-byterecord-type))
+
+(define-record-type <scalar>
+  (make-scalar size alignment native? type)
+  scalar?
+  (size scalar-size)
+  (alignment scalar-alignment)
+  (native? scalar-native?) ; native endianness?
+  (type scalar-type))
+
+(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 alignment fields)
+  %struct?
+  (size struct-size)
+  (alignment struct-alignment)
+  (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 alignment fields)
+  union?
+  (size union-size)
+  (alignment union-alignment)
+  (fields union-fields))
+
+(define-record-type <array>
+  (make-array size alignment length type)
+  array?
+  (size array-size)
+  (alignment array-alignment)
+  (length array-length)
+  (type array-type))
+
+(define-record-type <pointer>
+  (make-pointer size alignment type)
+  pointer?
+  (size pointer-size)
+  (alignment pointer-alignment)
+  ;; Mutable for recursive types.
+  (type pointer-type set-pointer-type!))
+
+;; TODO: functions
+;; TODO: bitfields
+
+(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 (bytestruct-type? obj)
+  (or (scalar? obj)
+      (%struct? obj)
+      (union? obj)
+      (array? obj)
+      (pointer? obj)))
+
+(define (sizeof type)
+  (match type
+    ((or ($ <scalar> size)
+         ($ <struct> size)
+         ($ <union> size)
+         ($ <array> size)
+         ($ <pointer> size))
+     size)))
+
+(define (alignof type)
+  (match type
+    ((or ($ <scalar> _ alignment)
+         ($ <struct> _ alignment)
+         ($ <union> _ alignment)
+         ($ <array> _ alignment)
+         ($ <pointer> _ alignment))
+     alignment)))
+
+(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))))))
+
+;; Bytestructs form a shallow vtable hierarchy.
+(define <bytestruct-descriptor>
+  (make-vtable (string-append standard-vtable-fields "pwpw")
+               (lambda (desc port)
+                 (format port "#<bytestruct-descriptor ~a>"
+                         (object-address desc)))))
+
+(define (bytestruct-descriptor-name descriptor)
+  (struct-ref descriptor vtable-offset-user))
+
+(define (bytestruct-descriptor-type descriptor)
+  (struct-ref descriptor (+ vtable-offset-user 1)))
+
+(define (bytestruct-descriptor-sizeof descriptor)
+  (sizeof (bytestruct-descriptor-type descriptor)))
+
+(define (print-bytestruct bs port)
+  (format port "#<~a ~a>"
+          (bytestruct-descriptor-name (struct-vtable bs))
+          (bytestruct->sexp bs)))
+
+(define* (make-bytestruct-descriptor name type #:key (printer print-bytestruct))
+  (assert (bytestruct-type? type) 'make-bytestruct-descriptor)
+  (make-struct/no-tail <bytestruct-descriptor>
+                       (make-struct-layout "pwpw")
+                       printer name type))
+
+(define (bytestruct-descriptor? obj)
+  (and (struct? obj) (eq? (struct-vtable obj) <bytestruct-descriptor>)))
+
+(define (%bytestruct? obj)
+  (and (struct? obj) (bytestruct-descriptor? (struct-vtable obj))))
+
+(define (bytestruct-bytevector bs)
+  (assert (%bytestruct? bs) 'bytestruct-bytevector)
+  (struct-ref bs 0))
+
+(define (bytestruct-offset bs)
+  (assert (%bytestruct? bs) 'bytestruct-bytevector)
+  (struct-ref bs 1))
+
+(define (bytestruct-type bs)
+  (assert (%bytestruct? bs) 'bytestruct-bytevector)
+  (bytestruct-descriptor-type (struct-vtable bs)))
+
+;; Bytestructs are composed of a type descriptor, a bytevector that
+;; provides storage, and an offset pointing to the start of the struct
+;; data within that bytevector.
+(define (%make-bytestruct descriptor bv offset)
+  (make-struct/no-tail descriptor bv offset))
+
+(define (make-bytestruct descriptor bv offset)
+  (assert (bytestruct-descriptor? descriptor) 'make-bytestruct)
+  (assert (bytevector? bv) 'make-bytestruct)
+  (assert (exact-integer? offset) 'make-bytestruct)
+  (assert (>= offset 0) 'make-bytestruct)
+  (assert (<= (+ offset (bytestruct-descriptor-sizeof descriptor))
+              (bytevector-length bv))
+          'make-bytestruct)
+  (%make-bytestruct descriptor bv offset))
+
+;; 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 bytestructs in s-expression form when working
+;; at the REPL.
+(define (bytestruct->sexp bs)
+  (let ((bv (bytestruct-bytevector bs)))
+    (let loop ((type (bytestruct-type bs)) (offset (bytestruct-offset bs)))
+      (match type
+        ((? bytestruct-descriptor? desc)
+         (loop (bytestruct-descriptor-type desc) offset))
+        (($ <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)))
+             ('int (bytevector-sint-ref bv offset e (ffi:sizeof ffi:int)))
+             ('ulong (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)))
+             ('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))))))
+        (($ <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> _ _ type)
+         (match (bytevector-uint-ref bv offset (native-endianness)
+                                     (ffi:sizeof '*))
+           (0 'null)
+           ;; TODO: Dereference pointer.  Needs cycle detection.
+           (address `(* ,address))))))))
+
+;; Macro helpers that use metadata attached to bytestruct syntax
+;; transformers.
+(define (bytestruct-descriptor-identifier? id)
+  (and (identifier? id)
+       (let-values (((kind val) (syntax-local-binding id)))
+         (and (eq? kind 'macro)
+              (procedure-property val 'bytestruct?)))))
+
+(define (bytestruct-descriptor-identifier-size id)
+  (let-values (((_ transformer) (syntax-local-binding id)))
+    (procedure-property transformer 'bytestruct-size)))
+
+(define (bytestruct-descriptor-identifier-alignment id)
+  (let-values (((_ transformer) (syntax-local-binding id)))
+    (procedure-property transformer 'bytestruct-alignment)))
+
+(define-syntax bytestruct?
+  (lambda (stx)
+    (syntax-case stx ()
+      (x
+       (identifier? #'x)
+       #'(case-lambda
+           ((obj) (%bytestruct? obj))
+           ((<type> obj)
+            (match obj
+              (($ <type>) #t)
+              (_ #f)))))
+      ((_ obj)
+       #'(%bytestruct? obj))
+      ((_ <type> obj)
+       (bytestruct-descriptor-identifier? #'<type>)
+       #'(match obj
+           (($ <type>) #t)
+           (_ #f))))))
+
+(define-syntax bytestruct=?
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type> a b)
+       (bytestruct-descriptor-identifier? #'<type>)
+       #'(match a
+           (($ <type> bv-a offset-a)
+            (match b
+              (($ <type> bv-b offset-b)
+               (let ((n (bytestruct-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))))))))))))
+
+(define-syntax bytestruct->pointer
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type> bs)
+       (bytestruct-descriptor-identifier? #'<type>)
+       #'(match bs
+           (($ <type> bv offset)
+            (ffi:bytevector->pointer bv offset)))))))
+
+(define-syntax pointer->bytestruct
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type> ptr)
+       (bytestruct-descriptor-identifier? #'<type>)
+       #'(let ((size (bytestruct-sizeof <type>)))
+           (make-bytestruct <type> (ffi:pointer->bytevector ptr size) 0))))))
+
+;; Wrap a bytevector in a bytestruct.
+(define-syntax bytestruct-wrap
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type> bv offset)
+       (bytestruct-descriptor-identifier? #'<type>)
+       #'(make-bytestruct <type> bv offset)))))
+
+;; Unwrap a bytestruct to a bytevector + offset.
+(define-syntax bytestruct-unwrap
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type> bs)
+       (bytestruct-descriptor-identifier? #'<type>)
+       #`(match bs
+           (($ <type> bv offset)
+            (values bv offset)))))))
+
+;; Size/align queries.
+(define-syntax bytestruct-sizeof
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type>)
+       (bytestruct-descriptor-identifier? #'<type>)
+       (bytestruct-descriptor-identifier-size #'<type>)))))
+
+(define-syntax bytestruct-alignof
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type>)
+       (bytestruct-descriptor-identifier? #'<type>)
+       (bytestruct-descriptor-identifier-alignment #'<type>)))))
+
+;; 'bytestruct-pack!' and 'bytestruct-unpack' allow for directly
+;; interpreting bytevector contents as structured data.
+(define-syntax bytestruct-unpack
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type> (elem ...) bv i)
+       (bytestruct-descriptor-identifier? #'<type>)
+       #`(values
+          #,@(map (lambda (elem)
+                    (syntax-case elem ()
+                      ((e ...)
+                       #'((<type> getter e ...) bv i))))
+                  #'(elem ...)))))))
+
+(define-syntax bytestruct-pack!
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type> ((elem val) ...) bv i)
+       (bytestruct-descriptor-identifier? #'<type>)
+       #`(begin
+           #,@(map (lambda (elem val)
+                     (syntax-case elem ()
+                       ((e ...)
+                        #`((<type> setter e ...) bv i #,val))))
+                   #'(elem ...)
+                   #'(val ...)))))))
+
+;; Allocate a fresh bytestruct that wraps a fresh bytevector big
+;; enough to store the entire structure.
+(define-syntax bytestruct-alloc
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type> (elem val) ...)
+       (bytestruct-descriptor-identifier? #'<type>)
+       (let ((size (bytestruct-descriptor-identifier-size #'<type>)))
+         #`(let ((bv (make-bytevector #,size 0)))
+             (bytestruct-pack! <type> ((elem val) ...) bv 0)
+             (bytestruct-wrap <type> bv 0)))))))
+
+;; Return the value of an element.
+(define-syntax bytestruct-ref
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type> (elem ...) bs)
+       (bytestruct-descriptor-identifier? #'<type>)
+       #`(match bs
+           ;; Using 'exact-integer?' here assists the type inference
+           ;; pass and allows for unboxed addition of offsets.
+           (($ <type> bv (? exact-integer? offset))
+            (bytestruct-unpack <type> ((elem ...)) bv offset)))))))
+
+;; Create a pointer to some element within a bytestruct.
+(define-syntax bytestruct-&ref
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type> (elem ...) bs)
+       (bytestruct-descriptor-identifier? #'<type>)
+       #'(match bs
+           (($ <type> bv (? exact-integer? offset))
+            (call-with-values (lambda () ((<type> offset elem ...) bv offset))
+              (lambda (bv offset)
+                (ffi:bytevector->pointer bv offset)))))))))
+
+;; Set the value of an element.
+(define-syntax bytestruct-set!
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type> elem bs x)
+       (bytestruct-descriptor-identifier? #'<type>)
+       #'(match bs
+           (($ <type> bv (? exact-integer? offset))
+            (bytestruct-pack! <type> ((elem x)) bv offset)))))))
+
+(define-syntax bytestruct-copy!
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type> src dst)
+       (bytestruct-descriptor-identifier? #'<type>)
+       #'(match src
+           (($ <type> src-bv (? exact-integer? src-offset))
+            (match dst
+              (($ <type> dst-bv (? exact-integer? dst-offset))
+               (bytevector-copy! src-bv src-offset
+                                 dst-bv dst-offset
+                                 (bytestruct-sizeof <type>))))))))))
+
+(define-syntax bytestruct-copy
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ <type> src)
+       (bytestruct-descriptor-identifier? #'<type>)
+       #'(let ((dst (bytestruct-alloc <type>)))
+           (bytestruct-copy! <type> src dst)
+           dst)))))
+
+(define (identifier-eq? stx sym)
+  (and (identifier? stx) (eq? (syntax->datum stx) sym)))
+
+;; The big gnarly procedural macro!
+(define-syntax define-bytestruct
+  (lambda (stx)
+    (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 (target-endianness? e)
+      (eq? e (target-endianness)))
+    (define (resolve-endianness e)
+      (match e
+        ('native (target-endianness))
+        ('non-native (non-target-endianness))
+        (_ e)))
+    (define (identifier-memq? stx syms)
+      (and (identifier? stx) (memq (syntax->datum stx) syms)))
+    ;; Primitive getter/setter helpers
+    (define (ref/endianness proc endianness)
+      #`(lambda (bv i)
+          (#,proc bv i #,endianness)))
+    (define (set!/endianness proc endianness)
+      #`(lambda (bv i x)
+          (#,proc bv i x #,endianness)))
+    (define (uint-ref size endianness)
+      #`(lambda (bv i)
+          (bytevector-uint-ref bv i '#,(datum->syntax #f endianness) #,size)))
+    (define (uint-set! size endianness)
+      #`(lambda (bv i x)
+          (bytevector-uint-set! bv i x '#,(datum->syntax #f endianness) #,size)))
+    (define (sint-ref size endianness)
+      #`(lambda (bv i)
+          (bytevector-sint-ref bv i '#,(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)))
+    ;; 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 (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-getter size 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 (primitive-setter size 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))))))
+    ;; Types can be recursive by referencing a type name within the
+    ;; same type group in a pointer expression.
+    ;;
+    ;; For example:
+    ;;
+    ;; (define-bytestruct linked-list
+    ;;   (struct (item int) (next (* linked-list))))
+    ;;
+    ;; To make this work, we keep a side table mapping type names to
+    ;; pointer type accessor forms that need to be patched with a
+    ;; cyclical reference *after* all the types are defined.
+    (define recursive-pointers (make-hash-table))
+    (define (sizeof type)
+      (match type
+        ((or ('scalar size _ _ _)
+             ('struct size _ _)
+             ('union size _ _)
+             ('array size _ _ _)
+             ('pointer size _ _))
+         size)
+        ((? bytestruct-descriptor-identifier?)
+         (bytestruct-descriptor-identifier-size type))))
+    (define (alignof type)
+      (match type
+        ((or ('scalar _ align _ _)
+             ('struct _ align _)
+             ('union _ align _)
+             ('array _ align _ _)
+             ('pointer _ align _))
+         align)
+        ((? bytestruct-descriptor-identifier?)
+         (bytestruct-descriptor-identifier-alignment type))))
+    (define (compute-type expr accessor type-ids packed? endianness)
+      (syntax-case expr ()
+        ;; Modifiers
+        ((packed expr)
+         (identifier-eq? #'packed 'packed)
+         (compute-type #'expr accessor type-ids #t endianness))
+        ((unpacked expr)
+         (identifier-eq? #'unpacked 'unpacked)
+         (compute-type #'expr accessor type-ids #f endianness))
+        ((endian e expr)
+         (and (identifier-eq? #'endian 'endian)
+              (identifier-memq? #'e '(native non-native big little)))
+         (compute-type #'expr accessor type-ids packed?
+                       (resolve-endianness (syntax->datum #'e))))
+        ;; Previously defined types.  'packed?' and 'endianness' do
+        ;; not apply here.
+        (type-id
+         (bytestruct-descriptor-identifier? #'type-id)
+         #'type-id)
+        ;; Primitive scalars
+        (primitive
+         (identifier-memq? #'primitive primitives)
+         (let ((type (syntax->datum #'primitive)))
+           `(scalar ,(sizeof* type)
+                    ,(alignof* type)
+                    ,(target-endianness? endianness)
+                    ,type)))
+        ;; Structs
+        ((struct (field-name field-expr) ...)
+         (and (identifier-eq? #'struct 'struct)
+              (every identifier? #'(field-name ...)))
+         (let loop ((field-exprs #'((field-name field-expr) ...))
+                    (fields '()) (offset 0) (alignment 0))
+           (syntax-case field-exprs ()
+             (()
+              `(struct ,offset ,alignment ,(reverse fields)))
+             ;; An underscore indicates a pseuo-field that is just for
+             ;; padding.  It is not included in the struct field list and
+             ;; just adds to the offset.
+             (((underscore expr) . rest-exprs)
+              (identifier-eq? #'underscore '_)
+              (let ((type (compute-type #'expr #f type-ids packed? endianness)))
+                (loop #'rest-exprs fields (+ offset (sizeof type)) alignment)))
+             (((name expr) . rest-exprs)
+              (let* ((type (compute-type #'expr
+                                         #`(struct-field-ref #,accessor 'name)
+                                         type-ids packed? endianness))
+                     (field-alignment (alignof type))
+                     (padding (if packed?
+                                  0
+                                  (modulo (- field-alignment
+                                             (modulo offset field-alignment))
+                                          field-alignment)))
+                     (offset (+ offset padding))
+                     (alignment (max alignment field-alignment)))
+                (loop #'rest-exprs
+                      (cons (list (syntax->datum #'name) offset type) fields)
+                      (+ offset (sizeof type))
+                      alignment))))))
+        ;; Unions
+        ((union (field-name field-expr) ...)
+         (and (identifier-eq? #'union 'union)
+              (every identifier? #'(field-name ...)))
+         (let loop ((field-exprs #'((field-name field-expr) ...))
+                    (fields '()) (size 0) (alignment 0))
+           (syntax-case field-exprs ()
+             (()
+              `(union ,size ,alignment ,(reverse fields)))
+             (((underscore expr) . rest-exprs)
+              (identifier-eq? #'underscore '_)
+              (let ((type (compute-type #'expr #f type-ids packed? endianness)))
+                (loop #'rest-exprs fields (max size (sizeof type)) alignment)))
+             (((name expr) . rest-exprs)
+              (let ((type (compute-type #'expr
+                                        #`(struct-field-ref #,accessor 'name)
+                                        type-ids packed? endianness)))
+                (loop #'rest-exprs
+                      (cons (list (syntax->datum #'name) type) fields)
+                      (max size (sizeof type))
+                      (max alignment (alignof type))))))))
+        ;; Arrays
+        ((array length expr)
+         (and (identifier-eq? #'array 'array)
+              (exact-integer? (syntax->datum #'length)))
+         (let ((length (syntax->datum #'length))
+               (type (compute-type #'expr #`(array-type #,accessor)
+                                   type-ids packed? endianness)))
+           `(array ,(* (sizeof type) length) ,(alignof type) ,length ,type)))
+        ;; Pointers
+        ((pointer expr)
+         (identifier-eq? #'pointer '*)
+         (let ((size (ffi:sizeof '*))
+               (align (ffi:alignof '*)))
+           (let loop ((expr #'expr))
+             (syntax-case expr ()
+               ;; Void pointer
+               (void
+                (identifier-eq? #'void 'void)
+                `(pointer ,size ,align void))
+               ;; Primitive pointer
+               (prim
+                (identifier-memq? #'prim primitives)
+                `(pointer ,size ,align
+                          ,(compute-type #'prim #f type-ids packed? endianness)))
+               ;; Pointer to a pointer
+               ((pointer expr)
+                (identifier-eq? #'pointer '*)
+                `(pointer ,size ,align ,(loop #'expr)))
+               ;; Recursive reference to a type within this type group.
+               (type-id
+                (any (lambda (id) (bound-identifier=? #'type-id id)) type-ids)
+                (let ((pointer `(pointer ,size ,align (recur ,#'type-id))))
+                  ;; Make a note that the recursive reference needs to be
+                  ;; made via mutation after all types in the group are
+                  ;; defined.
+                  (hashq-set! recursive-pointers
+                              (syntax->datum #'type-id)
+                              (cons accessor
+                                    (hashq-ref recursive-pointers
+                                               (syntax->datum #'type-id)
+                                               '())))
+                  pointer))
+               ;; Reference to a type outside of this type group.
+               (type-id
+                (bytestruct-descriptor-identifier? #'type-id)
+                `(pointer ,size ,align ,#'type-id))))))))
+    (define (type->syntax type)
+      (match type
+        ((? identifier? type)
+         type)
+        (('scalar size alignment native? type)
+         #`(make-scalar #,size #,alignment #,native? '#,(datum->syntax #f type)))
+        (('struct size alignment fields)
+         (let ((fields* (map (match-lambda
+                               ((name offset type)
+                                #`(make-struct-field '#,(datum->syntax #f name)
+                                                     #,offset
+                                                     #,(type->syntax type))))
+                             fields)))
+           #`(make-struct #,size #,alignment (list #,@fields*))))
+        (('union size alignment fields)
+         (let ((fields* (map (match-lambda
+                               ((name type)
+                                #`(make-union-field '#,(datum->syntax #f name)
+                                                    #,(type->syntax type))))
+                             fields)))
+           #`(make-union #,size #,alignment (list #,@fields*))))
+        (('array size alignment length type)
+         #`(make-array #,size #,alignment #,length #,(type->syntax type)))
+        (('pointer size alignment ('recur type))
+         #`(make-pointer #,size #,alignment #f))
+        (('pointer size alignment 'void)
+         #`(make-pointer #,size #,alignment #f))
+        (('pointer size alignment type)
+         #`(make-pointer #,size #,alignment #,(type->syntax type)))))
+    (define (expand-accessor proc stx id op type group)
+      #`(syntax-case #,stx ()
+          (() #'#,(proc id 0)) ; self reference
+          ((elem :::)
+           #,(let loop ((stx #'#'(elem :::)) (type type) (offset 0))
+               (match type
+                 ((? bytestruct-descriptor-identifier? type)
+                  ;; Recursively invoke macro for referenced type to produce
+                  ;; the accessor.
+                  #`(syntax-case #,stx ()
+                      ((elem :::)
+                       #'#,(proc #`(#,type #,(datum->syntax #f op) elem :::)
+                                 offset))))
+                 (('scalar _ _ _ _)
+                  #`(syntax-case #,stx ()
+                      (() #'#,(proc type offset))))
+                 (('struct _ _ fields)
+                  #`(syntax-case #,stx ()
+                      ((e elem :::)
+                       (match (syntax->datum #'e)
+                         #,@(map (match-lambda
+                                   ((name offset* type)
+                                    #`('#,(datum->syntax #f name)
+                                       #,(loop #'#'(elem :::) type
+                                               #`(+ #,offset #,offset*)))))
+                                 fields)
+                         (_ #'(error "no such struct field" 'e))))))
+                 (('union _ _ fields)
+                  #`(syntax-case #,stx ()
+                      ((e elem :::)
+                       (match (syntax->datum #'e)
+                         #,@(map (match-lambda
+                                   ((name type)
+                                    #`('#,(datum->syntax #f name)
+                                       #,(loop #'#'(elem :::) type offset))))
+                                 fields)
+                         (_ #'(error "no such union field" 'e))))))
+                 (('array _ _ length type)
+                  ;; Need to generate a unique name here to capture
+                  ;; the 'e' containing the array index expression as
+                  ;; 'e' could get shadowed later.
+                  (with-syntax (((i) (generate-temporaries '(i))))
+                    #`(syntax-case #,stx ()
+                        ((e elem :::)
+                         (with-syntax ((i #'e))
+                           #,(loop #'#'(elem :::)
+                                   type
+                                   #`(+ #,offset
+                                        (* (let ()
+                                             ;; if 'i' is a constant then
+                                             ;; these checks will be elided
+                                             ;; by the compiler.
+                                             (assert (exact-integer? i)
+                                                     'bytestruct-accessor)
+                                             (assert (< -1 i #,length)
+                                                     'bytestruct-accessor)
+                                             i)
+                                           #,(sizeof type)))))))))
+                 ;; Void pointers can only be referenced, not
+                 ;; dereferenced.
+                 (('pointer _ _ 'void)
+                  #`(syntax-case #,stx ()
+                      (() #'#,(proc type offset))))
+                 (('pointer _ _ type*)
+                  (call-with-values (lambda ()
+                                      (match type*
+                                        (('recur type*)
+                                         (values type* #t))
+                                        (type*
+                                         (values type* #f))))
+                    (lambda (type* recur?)
+                      #`(let ()
+                          (define (expand-pointer-accessor stx)
+                            (syntax-case stx ()
+                              ;; Pointer reference
+                              (() #'#,(proc type offset))
+                              ;; Pointer dereference.  Sigh, it's
+                              ;; complicated...
+                              (((* index) elem :::)
+                               (identifier-eq? #'* '*)
+                               (let ((offset #,offset)
+                                     (e '#,(datum->syntax #f (target-endianness)))
+                                     (ptr-size #,(target-word-size))
+                                     ;; For recursive types, we don't
+                                     ;; yet have a defined macro to
+                                     ;; query for the size, so we have
+                                     ;; to look it up in the group
+                                     ;; alist.
+                                     (size #,(sizeof (if recur?
+                                                         (assoc-ref group type*)
+                                                         type*)))
+                                     (body #,(match type*
+                                               ((? syntax?)
+                                                #`#'#,(proc #`(#,type*
+                                                               #,(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* ((e '#,(datum->syntax #f e))
+                                          (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 :::)
+                               (identifier-eq? #'* '*)
+                               (expand-pointer-accessor #'((* 0) elem :::)))))
+                          (expand-pointer-accessor #,stx))))))))))
+    (define (macro-for-type id type-id type group)
+      (define (self-identifier? other)
+        (eq? id other))
+      (let ((self-size (sizeof type)))
+        #`(define-syntax #,id
+            (with-ellipsis :::
+              (lambda (stx)
+                ;; Since syntax transformers are procedures, we can
+                ;; stash useful information in procedure properties that
+                ;; 'define-bytestruct' can use if/when a bytestruct type
+                ;; is referenced within another type definition.
+                #((bytestruct? . #t)
+                  (bytestruct-size . #,(sizeof type))
+                  (bytestruct-alignment . #,(alignof type)))
+                (syntax-case stx ()
+                  ;; Identifier syntax to provide the illusion that this
+                  ;; macro is just an ordinary variable.
+                  (self
+                   (identifier? #'self)
+                   #'#,type-id)
+                  ;; Private interface for code generation.
+                  ((_ offset elem :::)
+                   (identifier-eq? #'offset 'offset)
+                   #`(lambda (bv i)
+                       #,#,(expand-accessor
+                            (lambda (type offset)
+                              (match type
+                                ((and sub-offset ((? syntax?) ...))
+                                 #`(#,sub-offset bv (+ i #,offset)))
+                                (_ #`(values bv #,offset))))
+                            #'#'(elem :::) id 'offset type group)))
+                  ((_ getter elem :::)
+                   (identifier-eq? #'getter 'getter)
+                   #`(lambda (bv i)
+                       #,#,(expand-accessor
+                            (lambda (type offset)
+                              (match type
+                                ((or (? self-identifier?)
+                                     (? bytestruct-descriptor-identifier?))
+                                 #`(make-bytestruct #,type bv (+ i #,offset)))
+                                ((and sub-get ((? syntax?) ...))
+                                 #`(#,sub-get bv (+ i #,offset)))
+                                (('pointer _ _ 'void)
+                                 #`(ffi:make-pointer
+                                    (bytevector-sint-ref bv (+ i #,offset)
+                                                         '#,(datum->syntax
+                                                             #f (target-endianness))
+                                                         #,(target-word-size))))
+                                (('pointer size _ (or ('recur type) type))
+                                 #`(ffi:make-pointer
+                                    (bytevector-sint-ref bv (+ i #,offset)
+                                                         '#,(datum->syntax
+                                                             #f (target-endianness))
+                                                         #,(target-word-size))))
+                                (('scalar size align native? type)
+                                 #`(#,(primitive-getter size native? type)
+                                    bv (+ i #,offset)))))
+                            #'#'(elem :::) id 'getter type group)))
+                  ((_ setter elem :::)
+                   (identifier-eq? #'setter 'setter)
+                   #`(lambda (bv i x)
+                       #,#,(expand-accessor
+                            (lambda (type offset)
+                              (match type
+                                ((? self-identifier?)
+                                 #`(match x
+                                     (($ #,type src j)
+                                      (bytevector-copy! src j bv
+                                                        (+ i #,offset)
+                                                        #,self-size))))
+                                ((? bytestruct-descriptor-identifier?)
+                                 #`(match x
+                                     (($ #,type src j)
+                                      (bytevector-copy! src j bv
+                                                        (+ i #,offset)
+                                                        #,(sizeof type)))))
+                                ((and sub-set! ((? syntax?) ...))
+                                 #`(#,sub-set! bv (+ i #,offset) x))
+                                (('pointer size _ 'void)
+                                 #`(bytevector-sint-set! bv (+ i #,offset)
+                                                         (ffi:pointer-address x)
+                                                         '#(datum->syntax
+                                                            #f (target-endianness))
+                                                         #,(target-word-size)))
+                                (('pointer size _ (or ('recur type) type))
+                                 #`(bytevector-sint-set! bv (+ i #,offset)
+                                                         (ffi:pointer-address x)
+                                                         '#(datum->syntax
+                                                            #f (target-endianness))
+                                                         #,(target-word-size)))
+                                (('scalar size align native? type)
+                                 (let ((setter (primitive-setter size native? type)))
+                                   #`(#,setter bv (+ i #,offset) x)))))
+                            #'#'(elem :::) id 'setter type group)))))))))
+    (syntax-case stx ()
+      ;; Type group definition.  Types defined in the same group can
+      ;; contain recursive pointer references to each other.
+      ((_ (id expr . kwargs) ...)
+       (not (null? #'((id expr) ...)))
+       (with-syntax (((type-id ...) (generate-temporaries #'(id ...))))
+         (let* ((ids #'(id ...))
+                (type-ids #'(type-id ...))
+                (kwargs #'(kwargs ...))
+                (types (map (lambda (id expr)
+                              (compute-type expr
+                                            #`(bytestruct-descriptor-type #,id)
+                                            ids #f (target-endianness)))
+                            #'(id ...)
+                            #'(expr ...)))
+                (group (map cons #'(id ...) types)))
+           #`(begin
+               ;; First, define the descriptors using gensym'd names.
+               #,@(map (lambda (id temp-id kwargs type)
+                         #`(define #,temp-id
+                             (make-bytestruct-descriptor '#,id
+                                                         #,(type->syntax type)
+                                                         #,@kwargs)))
+                       ids type-ids kwargs types)
+               ;; Then tie the knot for recursive pointer types.
+               #,@(append-map (lambda (id)
+                                (map (lambda (accessor)
+                                       #`(set-pointer-type! #,accessor #,id))
+                                     (hashq-ref recursive-pointers
+                                                (syntax->datum id) '())))
+                              ids)
+               ;; Finally, define macros using the true names that
+               ;; wrap the gensym'd variables.
+               #,@(map (lambda (id type-id type)
+                         (macro-for-type id type-id type group))
+                       ids type-ids types)))))
+      ;; A single type definition is a type group of one.
+      ((_ id expr . kwargs)
+       #'(define-bytestruct (id expr . kwargs))))))
+
+(define-syntax-rule (define-bytestruct-constructor name <type> elem ...)
+  (define-inlinable (name )))
+
+(define-syntax-rule (define-bytestruct-predicate name <type>)
+  (define-inlinable (name obj)
+    (bytestruct? <type> obj)))
+
+(define-syntax-rule (define-bytestruct-getter name <type> elem)
+  (define-inlinable (name bs)
+    (bytestruct-ref <type> elem bs)))
+
+(define-syntax-rule (define-bytestruct-setter name <type> elem)
+  (define-inlinable (name bs x)
+    (bytestruct-set! <type> elem bs x)))
+
+(define-syntax define-bytestruct-accessor
+  (syntax-rules ()
+    ((_ (getter setter) <type> elem)
+     (begin
+       (define-bytestruct-getter getter <type> elem)
+       (define-bytestruct-setter setter <type> elem)))
+    ((_ (getter) <type> elem)
+     (define-bytestruct-getter getter <type> elem))))
+
+(define-syntax define-byterecord-type
+  (lambda (stx)
+    ;; Fields come first, then keyword arguments.
+    (define (parse-fields+kwargs stx proc)
+      (let loop ((stx stx) (fields '()))
+        (syntax-case stx ()
+          (((name type getter) . rest)
+           (and (identifier? #'name)
+                (identifier? #'getter))
+           (loop #'rest (cons #'(name type getter) fields)))
+          (((name type getter setter) . rest)
+           (and (identifier? #'name)
+                (identifier? #'getter)
+                (identifier? #'setter))
+           (loop #'rest (cons #'(name type getter setter) fields)))
+          (kwargs
+           (proc (reverse fields) #'kwargs)))))
+    (define (valid-args? args fields)
+      ;; Args shouldn't repeat and should be valid field names.
+      (and (equal? args (delete-duplicates args))
+           (every (lambda (arg) (memq arg fields)) args)))
+    (syntax-case stx ()
+      ((_ <name>
+          (constructor arg ...)
+          predicate
+          fields+kwargs ...)
+       (and (identifier? #'<name>)
+            (identifier? #'constructor)
+            (every identifier? #'(arg ...))
+            (identifier? #'predicate))
+       (parse-fields+kwargs
+        #'(fields+kwargs ...)
+        (lambda (fields kwargs)
+          (syntax-case fields ()
+            (((field-name field-type field-getter . field-setter) ...)
+             (valid-args? (syntax->datum #'(arg ...))
+                          (syntax->datum #'(field-name ...)))
+             #`(begin
+                 (define-bytestruct <name>
+                   (struct (field-name field-type) ...)
+                   #:printer (lambda (obj port)
+                               (display "#<" port)
+                               (display '<name> port)
+                               (let ((val (bytestruct-ref <name> (field-name) obj)))
+                                 (display " " port)
+                                 (display 'field-name)
+                                 (display ": " port)
+                                 (display val port))
+                               ...
+                               (display ">" port))
+                   #,@kwargs)
+                 (define-inlinable (constructor arg ...)
+                   (bytestruct-alloc <name> ((arg) arg) ...))
+                 (define-bytestruct-predicate predicate <name>)
+                 (define-bytestruct-accessor (field-getter . field-setter)
+                   <name> (field-name))
+                 ...)))))))))
diff --git a/tests/bytestruct.scm b/tests/bytestruct.scm
new file mode 100644
index 0000000..093acdb
--- /dev/null
+++ b/tests/bytestruct.scm
@@ -0,0 +1,276 @@
+;;; Chickadee Game Toolkit
+;;; 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.
+
+(define-module (tests bytestruct)
+  #:use-module (chickadee data bytestruct)
+  #:use-module (srfi srfi-64)
+  #:use-module (system foreign)
+  #:use-module (tests utils))
+
+;; For testing basic structs.
+(define-bytestruct <vec2>
+  (struct (x f32) (y f32)))
+
+(define-bytestruct <vertex>
+  (struct (xy <vec2>) (uv <vec2>)))
+
+;; For testing arrays.
+(define-bytestruct <matrix4>
+  (array 16 f32))
+
+;; For testing variable length arrays.
+(define-bytestruct <floats>
+  (struct (items (* f32))))
+
+;; For testing unions.
+(define-bytestruct <mouse-move-event>
+  (struct (type u8) (x s32) (y s32)))
+
+(define-bytestruct <mouse-button-event>
+  (struct (type u8) (button u8) (state u8) (x s32) (y s32)))
+
+(define-bytestruct <event>
+  (union (type u8)
+         (mouse-move <mouse-move-event>)
+         (mouse-button <mouse-button-event>)))
+
+;; For testing recursive types.
+(define-bytestruct <node>
+  (struct (item int) (next (* <node>))))
+
+(with-tests "bytestruct"
+  (test-group "bytestruct?"
+    (test-assert (bytestruct? (bytestruct-alloc <vec2>)))
+    (test-assert (not (bytestruct? 'vec2)))
+    (test-assert (bytestruct? <vec2> (bytestruct-alloc <vec2>)))
+    (test-assert (not (bytestruct? <vec2> (bytestruct-alloc <vertex>)))))
+
+  (test-group "bytestruct=?"
+    (test-assert (bytestruct=? <vec2>
+                               (bytestruct-alloc <vec2> ((x) 42) ((y) 69))
+                               (bytestruct-alloc <vec2> ((x) 42) ((y) 69))))
+    (test-assert (not (bytestruct=? <vec2>
+                                    (bytestruct-alloc <vec2> ((x) 42) ((y) 69))
+                                    (bytestruct-alloc <vec2> ((x) 77) ((y) 89))))))
+
+  (test-group "bytestruct->sexp"
+    (test-equal '(struct (x 42.0) (y 69.0))
+      (bytestruct->sexp (bytestruct-alloc <vec2> ((x) 42) ((y) 69))))
+    (test-equal '(struct (xy (struct (x 42.0) (y 69.0)))
+                         (uv (struct (x 77.0) (y 89.0))))
+      (bytestruct->sexp (bytestruct-alloc <vertex>
+                                          ((xy x) 42) ((xy y) 69)
+                                          ((uv x) 77) ((uv y) 89))))
+    (test-equal '(union
+                  (type 1)
+                  (mouse-move (struct
+                               (type 1)
+                               (x 0)
+                               (y 0)))
+                  (mouse-button (struct
+                                 (type 1)
+                                 (button 0)
+                                 (state 0)
+                                 (x 0)
+                                 (y 0))))
+      (bytestruct->sexp (bytestruct-alloc <event> ((type) 1))))
+    (test-equal '(struct (item 42) (next null))
+      (bytestruct->sexp (bytestruct-alloc <node> ((item) 42)))))
+
+  (test-group "bytestruct->pointer"
+    (test-equal #vu8(0 0 40 66 0 0 138 66)
+                (let ((v (bytestruct-alloc <vec2> ((x) 42) ((y) 69))))
+                  (pointer->bytevector (bytestruct->pointer <vec2> v)
+                                       (bytestruct-sizeof <vec2>)))))
+
+  (test-group "pointer->bytestruct"
+    (test-equal 69.0
+      (let ((v (bytestruct-alloc <vec2> ((x) 42) ((y) 69))))
+        (bytestruct-ref <vec2> (y)
+                        (pointer->bytestruct <vec2>
+                                             (bytestruct->pointer <vec2> v))))))
+
+  (test-group "bytestruct-wrap"
+    (test-equal 69.0
+      (bytestruct-ref <vec2> (y) (bytestruct-wrap <vec2> (f32vector 13 42 69) 4))))
+
+  (test-group "bytestruct-unwrap"
+    (test-equal '(#vu8(0 0 40 66 0 0 138 66) 0)
+      (call-with-values (lambda ()
+                          (bytestruct-unwrap <vec2>
+                                             (bytestruct-alloc <vec2>
+                                                               ((x) 42)
+                                                               ((y) 69))))
+        list)))
+
+  (test-group "bytestruct-alignof"
+    (test-equal (alignof (list float float))
+      (bytestruct-alignof <vec2>))
+    (test-equal (alignof (list (list float float) (list float float)))
+      (bytestruct-alignof <vertex>))
+    (test-equal (alignof (make-list 16 float))
+      (bytestruct-alignof <matrix4>))
+    (test-equal (alignof (list uint8 int32 int32))
+      (bytestruct-alignof <mouse-move-event>))
+    (test-equal (alignof (list uint8 uint8 uint8 int32 int32))
+      (bytestruct-alignof <mouse-button-event>))
+    (test-equal (max (alignof (list uint8))
+                     (alignof (list uint8 int32 int32))
+                     (alignof (list uint8 uint8 uint8 int32 int32)))
+      (bytestruct-alignof <event>)))
+
+  (test-group "bytestruct-sizeof"
+    (test-equal (sizeof (list float float))
+      (bytestruct-sizeof <vec2>))
+    (test-equal (sizeof (list (list float float) (list float float)))
+      (bytestruct-sizeof <vertex>))
+    (test-equal (sizeof (make-list 16 float))
+      (bytestruct-sizeof <matrix4>))
+    (test-equal (sizeof (list uint8 int32 int32))
+      (bytestruct-sizeof <mouse-move-event>))
+    (test-equal (sizeof (list uint8 uint8 uint8 int32 int32))
+      (bytestruct-sizeof <mouse-button-event>))
+    (test-equal (max (sizeof (list uint8))
+                     (sizeof (list uint8 int32 int32))
+                     (sizeof (list uint8 uint8 uint8 int32 int32)))
+      (bytestruct-sizeof <event>)))
+
+  (test-group "bytestruct-ref"
+    (test-equal 69.0
+      (bytestruct-ref <vec2> (y) (bytestruct-alloc <vec2> ((x) 42) ((y) 69))))
+    (test-equal 42.0
+      (bytestruct-ref <vertex> (uv x) (bytestruct-alloc <vertex> ((uv x) 42))))
+    (test-equal 4.0
+      (let ((bv (f32vector 1 2 3 4)))
+        (bytestruct-ref <floats> (items (* 3))
+                        (bytestruct-alloc <floats>
+                                          ((items) (bytevector->pointer bv))))))
+    (test-equal %null-pointer
+      (bytestruct-ref <node> (next) (bytestruct-alloc <node>))))
+
+  (test-group "bytestruct-&ref"
+    (let ((bv (f32vector 42 69)))
+      (test-equal (bytevector->pointer bv 4)
+        (bytestruct-&ref <vec2> (y) (bytestruct-wrap <vec2> bv 0)))))
+
+  (test-group "bytestruct-set!"
+    (test-equal 42.0
+      (let ((v (bytestruct-alloc <vec2>)))
+        (bytestruct-set! <vec2> (y) v 42)
+        (bytestruct-ref <vec2> (y) v)))
+    (test-equal 42.0
+      (let ((a (bytestruct-alloc <matrix4>)))
+        (bytestruct-set! <matrix4> (7) a 42)
+        (bytestruct-ref <matrix4> (7) a)))
+    (test-equal 42.0
+      (let* ((bv (f32vector 0 0 0 0))
+             (f (bytestruct-alloc <floats>)))
+        (bytestruct-set! <floats> (items) f (bytevector->pointer bv))
+        (bytestruct-set! <floats> (items (* 3)) f 42)
+        (bytestruct-ref <floats> (items (* 3)) f)))
+    (test-equal 42
+      (let ((e (bytestruct-alloc <event>)))
+        (bytestruct-set! <event> (mouse-move y) e 42)
+        (bytestruct-ref <event> (mouse-move y) e)))
+    (test-equal 69
+      (let* ((a (bytestruct-alloc <node> ((item) 42)))
+             (b (bytestruct-alloc <node> ((item) 69))))
+        (bytestruct-set! <node> (next) a (bytestruct->pointer <node> b))
+        (bytestruct-ref <node> (next * item) a))))
+
+  (test-group "bytestruct-pack!"
+    (test-equal (f32vector 42 69)
+      (let ((bv (f32vector 0 0)))
+        (bytestruct-pack! <vec2> (((x) 42) ((y) 69)) bv 0)
+        bv))
+    (test-equal (f32vector 1 2 3 4)
+      (let ((bv (f32vector 0 0 0 0)))
+        (bytestruct-pack! <vertex>
+                          (((xy) (bytestruct-alloc <vec2> ((x) 1) ((y) 2)))
+                           ((uv x) 3)
+                           ((uv y) 4))
+                          bv 0)
+        bv))
+    (test-equal (f32vector 1 0 0 0
+                           0 1 0 0
+                           0 0 1 0
+                           0 0 0 1)
+      (let ((bv (f32vector 0 0 0 0
+                           0 0 0 0
+                           0 0 0 0
+                           0 0 0 0)))
+        (bytestruct-pack! <matrix4>
+                          (((0) 1) ((5) 1) ((10) 1) ((15) 1))
+                          bv 0)
+        bv))
+    (test-equal (u8vector 1 2 0 0 3 0 0 0 4 0 0 0)
+      (let ((bv (make-u8vector (bytestruct-sizeof <event>) 0)))
+        (bytestruct-pack! <event>
+                          (((mouse-button type) 1)
+                           ((mouse-button button) 2)
+                           ((mouse-button state) 0)
+                           ((mouse-button x) 3)
+                           ((mouse-button y) 4))
+                          bv 0)
+        bv)))
+
+  (test-group "bytestruct-unpack"
+    (test-equal '(42.0 69.0)
+      (let ((bv (f32vector 42 69)))
+        (call-with-values (lambda () (bytestruct-unpack <vec2> ((x) (y)) bv 0))
+          list)))
+    (test-equal (list 1.0 2.0 3.0 4.0)
+      (let ((bv (f32vector 1 2 3 4)))
+        (call-with-values (lambda ()
+                            (bytestruct-unpack <vertex>
+                                               ((xy x) (xy y) (uv x) (uv y))
+                                               bv 0))
+          list)))
+    (test-equal '(1.0 1.0 1.0 1.0)
+      (let ((bv (f32vector 1 0 0 0
+                           0 1 0 0
+                           0 0 1 0
+                           0 0 0 1)))
+        (call-with-values (lambda ()
+                            (bytestruct-unpack <matrix4>
+                                               ((0) (5) (10) (15))
+                                               bv 0))
+          list)))
+    (test-equal '(1 2 0 3 4)
+      (let ((bv (u8vector 1 2 0 0 3 0 0 0 4 0 0 0)))
+        (call-with-values (lambda ()
+                            (bytestruct-unpack <event>
+                                               ((mouse-button type)
+                                                (mouse-button button)
+                                                (mouse-button state)
+                                                (mouse-button x)
+                                                (mouse-button y))
+                                               bv 0))
+          list))))
+
+  (test-group "bytestruct-copy"
+    (test-equal '(42.0 69.0)
+      (let* ((v (bytestruct-alloc <vec2> ((x) 42) ((y) 69)))
+             (v* (bytestruct-copy <vec2> v)))
+        (list (bytestruct-ref <vec2> (x) v*)
+              (bytestruct-ref <vec2> (y) v*)))))
+
+  (test-group "bytestruct-copy!"
+    (test-equal '(42.0 69.0)
+      (let* ((v (bytestruct-alloc <vec2> ((x) 42) ((y) 69)))
+             (v* (bytestruct-alloc <vec2>)))
+        (bytestruct-copy! <vec2> v v*)
+        (list (bytestruct-ref <vec2> (x) v*)
+              (bytestruct-ref <vec2> (y) v*))))))