summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.dir-locals.el3
-rw-r--r--.gitignore11
-rw-r--r--Makefile.am50
-rwxr-xr-xbootstrap3
-rw-r--r--bstruct.scm1217
-rw-r--r--configure.ac13
-rw-r--r--guix.scm58
-rw-r--r--pre-inst-env.in25
-rw-r--r--tests/test-bstruct.scm278
-rw-r--r--tests/utils.scm24
10 files changed, 1682 insertions, 0 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
new file mode 100644
index 0000000..cfcf9b1
--- /dev/null
+++ b/.dir-locals.el
@@ -0,0 +1,3 @@
+((scheme-mode
+ .
+ ((eval . (put 'test-suite 'scheme-indent-function 1)))))
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..d7cd29b
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,11 @@
+*.go
+*.log
+*.trs
+/Makefile
+/Makefile.in
+/aclocal.m4
+/autom4te.cache/
+/build-aux/
+/config.status
+/configure
+/pre-inst-env
diff --git a/Makefile.am b/Makefile.am
new file mode 100644
index 0000000..4ad6e06
--- /dev/null
+++ b/Makefile.am
@@ -0,0 +1,50 @@
+# 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.
+
+GOBJECTS = $(SOURCES:%.scm=%.go)
+
+nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES)
+nobase_go_DATA = $(GOBJECTS)
+
+# Make sure source files are installed first, so that the mtime of
+# installed compiled files is greater than that of installed source
+# files. See
+# <http://lists.gnu.org/archive/html/guile-devel/2010-07/msg00125.html>
+# for details.
+guile_install_go_files = install-nobase_goDATA
+$(guile_install_go_files): install-nobase_modDATA
+
+CLEANFILES = $(GOBJECTS)
+EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)
+GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat
+SUFFIXES = .scm .go
+.scm.go:
+ $(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_WARNINGS) -o "$@" "$<"
+
+moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION)
+godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache
+
+SOURCES = bstruct.scm
+
+TESTS = tests/test-bstruct.scm
+
+TEST_EXTENSIONS = .scm
+SCM_LOG_COMPILER = $(top_builddir)/pre-inst-env $(GUILE)
+AM_SCM_LOG_FLAGS = --no-auto-compile -L "$(top_srcdir)"
+
+EXTRA_DIST += \
+ COPYING \
+ guix.scm \
+ tests/utils.scm
diff --git a/bootstrap b/bootstrap
new file mode 100755
index 0000000..e756b42
--- /dev/null
+++ b/bootstrap
@@ -0,0 +1,3 @@
+#! /bin/sh
+
+autoreconf -vif
diff --git a/bstruct.scm b/bstruct.scm
new file mode 100644
index 0000000..400d8db
--- /dev/null
+++ b/bstruct.scm
@@ -0,0 +1,1217 @@
+;;; 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 (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))
+
+(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!))
+
+(define-record-type <opaque>
+ (make-opaque)
+ opaque?)
+
+;; 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 (bstruct-type? obj)
+ (or (scalar? obj)
+ (%struct? obj)
+ (union? obj)
+ (array? obj)
+ (pointer? obj)
+ (opaque? obj)))
+
+(define (sizeof type)
+ (match type
+ ((or ($ <scalar> size)
+ ($ <struct> size)
+ ($ <union> size)
+ ($ <array> size)
+ ($ <pointer> size))
+ size)
+ (($ <opaque>)
+ (raise-exception
+ (make-exception (make-exception-with-message
+ "cannot get size of opaque type")
+ (make-exception-with-origin 'sizeof)
+ (make-exception-with-irritants (list type)))))))
+
+(define (alignof type)
+ (match type
+ ((or ($ <scalar> _ alignment)
+ ($ <struct> _ alignment)
+ ($ <union> _ alignment)
+ ($ <array> _ alignment)
+ ($ <pointer> _ alignment))
+ alignment)
+ (($ <opaque>)
+ (raise-exception
+ (make-exception (make-exception-with-message
+ "cannot get alignment of opaque type")
+ (make-exception-with-origin 'sizeof)
+ (make-exception-with-irritants (list type)))))))
+
+(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>"
+ (object-address 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.
+;;
+;; TODO: We could use Guile's bytevector slices here, however they
+;; were only introduced in 3.0.9 so we can't rely on them.
+(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
+ ('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>)
+ `(* ,(bytevector-uint-ref bv offset (native-endianness)
+ (ffi:sizeof '*))))))))
+
+;; Macro helpers that use metadata attached to bstruct syntax
+;; transformers.
+(define (bstruct-descriptor-identifier? id)
+ (and (identifier? id)
+ (let-values (((kind val) (syntax-local-binding id)))
+ (and (eq? kind 'macro)
+ (procedure-property val 'bstruct?)))))
+
+(define (non-opaque-bstruct-descriptor-identifier? id)
+ (and (identifier? id)
+ (let-values (((kind val) (syntax-local-binding id)))
+ (and (eq? kind 'macro)
+ (procedure-property val 'bstruct?)
+ (not (procedure-property val 'bstruct-opaque?))))))
+
+(define (bstruct-descriptor-identifier-size id)
+ (let-values (((_ transformer) (syntax-local-binding id)))
+ (procedure-property transformer 'bstruct-size)))
+
+(define (bstruct-descriptor-identifier-alignment id)
+ (let-values (((_ transformer) (syntax-local-binding id)))
+ (procedure-property transformer 'bstruct-alignment)))
+
+;; A predicate that can answer the questions:
+;; 1) Is this *any kind* of bstruct?
+;; 2) Is this *a specific kind* of bstruct?
+(define-syntax bstruct?
+ (lambda (stx)
+ (syntax-case stx ()
+ (x
+ (identifier? #'x)
+ #'(case-lambda
+ ((obj) (%bstruct? obj))
+ ((<type> obj)
+ (match obj
+ (($ <type>) #t)
+ (_ #f)))))
+ ((_ obj)
+ #'(%bstruct? obj))
+ ((_ <type> obj)
+ (bstruct-descriptor-identifier? #'<type>)
+ #'(match obj
+ (($ <type>) #t)
+ (_ #f))))))
+
+(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> 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)))))))
+
+;; Size/align queries.
+(define-syntax bstruct-sizeof
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ <type>)
+ (non-opaque-bstruct-descriptor-identifier? #'<type>)
+ (bstruct-descriptor-identifier-size #'<type>)))))
+
+(define-syntax bstruct-alignof
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ <type>)
+ (non-opaque-bstruct-descriptor-identifier? #'<type>)
+ (bstruct-descriptor-identifier-alignment #'<type>)))))
+
+;; '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 ...)
+ (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))))
+
+(define (identifier-eq? stx sym)
+ (and (identifier? stx) (eq? (syntax->datum stx) sym)))
+
+;; The big gnarly procedural macro! Buckle up!
+(define-syntax define-bstruct
+ (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-bstruct 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)
+ (('opaque) 0)
+ ((? bstruct-descriptor-identifier?)
+ (bstruct-descriptor-identifier-size type))))
+ (define (alignof type)
+ (match type
+ ((or ('scalar _ align _ _)
+ ('struct _ align _)
+ ('union _ align _)
+ ('array _ align _ _)
+ ('pointer _ align _))
+ align)
+ (('opaque) 0)
+ ((? bstruct-descriptor-identifier?)
+ (bstruct-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
+ (bstruct-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 ()
+ (()
+ ;; Round up to a multiple of alignment to get final
+ ;; size.
+ (let ((size (* (ceiling (/ offset alignment)) alignment)))
+ `(struct ,size ,alignment ,(reverse fields))))
+ ;; An underscore indicates a pseudo-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
+ (bstruct-descriptor-identifier? #'type-id)
+ `(pointer ,size ,align ,#'type-id))))))
+ ;; Opaque types
+ (opaque
+ (identifier-eq? #'opaque 'opaque)
+ '(opaque))))
+ (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)))
+ (('opaque)
+ #'(make-opaque))))
+ (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
+ ((? bstruct-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 (u64? i) 'bstruct-accessor)
+ (assert (< -1 i #,length)
+ 'bstruct-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)))))
+ (('opaque)
+ #'(error "cannot access opaque type")))))))
+ (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-bstruct' can use if/when a bstruct type
+ ;; is referenced within another type definition.
+ #((bstruct? . #t)
+ (bstruct-opaque? . #,(eq? type '(opaque)))
+ (bstruct-size . #,(sizeof type))
+ (bstruct-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?)
+ (? bstruct-descriptor-identifier?))
+ #`(make-bstruct #,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))))
+ ((? bstruct-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 ...)))
+ (with-syntax (((type-id ...)
+ (map (lambda (stx)
+ ;; This ID is non-hygienic and also *not*
+ ;; gensym'd so it's the same name every
+ ;; time for predictable compilation,
+ ;; especially in the presence of 'make
+ ;; -j' parallelism.
+ ;;
+ ;; Is there a better way to do this?
+ ;; Probably.
+ (let ((type-id (symbol-append '%%bstruct-record-type-
+ (syntax->datum stx))))
+ (datum->syntax #f type-id)))
+ #'(id ...))))
+ (let* ((ids #'(id ...))
+ (type-ids #'(type-id ...))
+ (kwargs #'(kwargs ...))
+ (types (map (lambda (id expr)
+ (compute-type expr
+ #`(bstruct-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-bstruct-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-bstruct (id expr . kwargs))))))
diff --git a/configure.ac b/configure.ac
new file mode 100644
index 0000000..e88bf5d
--- /dev/null
+++ b/configure.ac
@@ -0,0 +1,13 @@
+AC_INIT(guile-bstruct, 0.1.0)
+AC_CONFIG_AUX_DIR([build-aux])
+AM_INIT_AUTOMAKE([color-tests -Wall -Wno-portability foreign])
+AM_SILENT_RULES([yes])
+
+AC_PATH_PROG([GUILE], [guile])
+AC_CONFIG_FILES([Makefile])
+AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
+
+GUILE_PKG([3.0])
+GUILE_PROGS
+
+AC_OUTPUT
diff --git a/guix.scm b/guix.scm
new file mode 100644
index 0000000..76e9e0e
--- /dev/null
+++ b/guix.scm
@@ -0,0 +1,58 @@
+;;; 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:
+;;
+;; Development environment for GNU Guix.
+;;
+;; To setup the development environment, run the following:
+;;
+;; guix shell
+;; ./bootstrap
+;; ./configure
+;;
+;; To build the package, run:
+;;
+;; guix build -f guix.scm
+;;
+;;; Code:
+
+(use-modules (guix packages)
+ ((guix licenses) #:prefix license:)
+ (guix download)
+ (guix git)
+ (guix git-download)
+ (guix build-system gnu)
+ (guix utils)
+ (gnu packages)
+ (gnu packages autotools)
+ (gnu packages pkg-config)
+ (gnu packages texinfo)
+ (gnu packages guile))
+
+(package
+ (name "guile-bstruct")
+ (version "0.1.0-git")
+ (source (git-checkout (url (dirname (current-filename)))))
+ (build-system gnu-build-system)
+ (arguments
+ '(#:make-flags '("GUILE_AUTO_COMPILE=0")))
+ (native-inputs (list autoconf automake pkg-config texinfo))
+ (inputs (list guile-3.0-latest))
+ (synopsis "Efficient binary structures for Guile")
+ (description "Guile-bstruct provides an efficient implementation of low-level binary
+structures for Guile Scheme.")
+ (home-page "https://dthompson.us/projects/guile-bstruct.html")
+ (license license:asl2.0))
diff --git a/pre-inst-env.in b/pre-inst-env.in
new file mode 100644
index 0000000..99c23de
--- /dev/null
+++ b/pre-inst-env.in
@@ -0,0 +1,25 @@
+#!/bin/sh
+
+# 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.
+
+abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`"
+abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`"
+
+GUILE_LOAD_COMPILED_PATH="$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH"
+GUILE_LOAD_PATH="$abs_top_builddir:$abs_top_srcdir${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH"
+export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH
+
+exec "$@"
diff --git a/tests/test-bstruct.scm b/tests/test-bstruct.scm
new file mode 100644
index 0000000..1bd54fb
--- /dev/null
+++ b/tests/test-bstruct.scm
@@ -0,0 +1,278 @@
+;;; 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.
+
+(define-module (tests test-bstruct)
+ #:use-module (bstruct)
+ #:use-module (srfi srfi-64)
+ #:use-module (system foreign)
+ #:use-module (tests utils))
+
+;; For testing basic structs.
+(define-bstruct <vec2>
+ (struct (x f32) (y f32)))
+
+(define-bstruct <vertex>
+ (struct (xy <vec2>) (uv <vec2>)))
+
+;; For testing arrays.
+(define-bstruct <matrix4>
+ (array 16 f32))
+
+;; For testing variable length arrays.
+(define-bstruct <floats>
+ (struct (items (* f32))))
+
+;; For testing unions.
+(define-bstruct <mouse-move-event>
+ (struct (type u8) (x s32) (y s32)))
+
+(define-bstruct <mouse-button-event>
+ (struct (type u8) (button u8) (state u8) (x s32) (y s32)))
+
+(define-bstruct <event>
+ (union (type u8)
+ (mouse-move <mouse-move-event>)
+ (mouse-button <mouse-button-event>)))
+
+;; For testing recursive types.
+(define-bstruct <node>
+ (struct (item int) (next (* <node>))))
+
+;; For testing proper sizing.
+(define-bstruct <right-sized>
+ (struct
+ (a u64)
+ (b u32)
+ (c u64)
+ (d u32)))
+
+(test-suite "bstruct"
+ (test-group "bstruct?"
+ (test-assert (bstruct? (bstruct-alloc <vec2>)))
+ (test-assert (not (bstruct? 'vec2)))
+ (test-assert (bstruct? <vec2> (bstruct-alloc <vec2>)))
+ (test-assert (not (bstruct? <vec2> (bstruct-alloc <vertex>)))))
+
+ (test-group "bstruct-=?"
+ (test-assert (bstruct-=? <vec2>
+ (bstruct-alloc <vec2> (x 42) (y 69))
+ (bstruct-alloc <vec2> (x 42) (y 69))))
+ (test-assert (not (bstruct-=? <vec2>
+ (bstruct-alloc <vec2> (x 42) (y 69))
+ (bstruct-alloc <vec2> (x 77) (y 89))))))
+
+ (test-group "bstruct->sexp"
+ (test-equal '(struct (x 42.0) (y 69.0))
+ (bstruct->sexp (bstruct-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))))
+ (bstruct->sexp (bstruct-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))))
+ (bstruct->sexp (bstruct-alloc <event> (type 1))))
+ (test-equal '(struct (item 42) (next (* 0)))
+ (bstruct->sexp (bstruct-alloc <node> (item 42)))))
+
+ (test-group "bstruct->pointer"
+ (test-equal #vu8(0 0 40 66 0 0 138 66)
+ (let ((v (bstruct-alloc <vec2> (x 42) (y 69))))
+ (pointer->bytevector (bstruct->pointer <vec2> v)
+ (bstruct-sizeof <vec2>))))
+ (let ((bv (f32vector 42 69)))
+ (test-equal (bytevector->pointer bv 4)
+ (bstruct->pointer <vec2> (bstruct-wrap <vec2> bv 0) y))))
+
+ (test-group "pointer->bstruct"
+ (test-equal 69.0
+ (let ((v (bstruct-alloc <vec2> (x 42) (y 69))))
+ (bstruct-ref <vec2>
+ (pointer->bstruct <vec2>
+ (bstruct->pointer <vec2> v))
+ y))))
+
+ (test-group "bstruct-wrap"
+ (test-equal 69.0
+ (bstruct-ref <vec2> (bstruct-wrap <vec2> (f32vector 13 42 69) 4) y)))
+
+ (test-group "bstruct-unwrap"
+ (test-equal '(#vu8(0 0 40 66 0 0 138 66) 0 1)
+ (call-with-values
+ (lambda ()
+ (bstruct-unwrap <vec2>
+ (bstruct-alloc <vec2> (x 42) (y 69))))
+ list)))
+
+ (test-group "bstruct-alignof"
+ (test-equal (alignof (list float float))
+ (bstruct-alignof <vec2>))
+ (test-equal (alignof (list (list float float) (list float float)))
+ (bstruct-alignof <vertex>))
+ (test-equal (alignof (make-list 16 float))
+ (bstruct-alignof <matrix4>))
+ (test-equal (alignof (list uint8 int32 int32))
+ (bstruct-alignof <mouse-move-event>))
+ (test-equal (alignof (list uint8 uint8 uint8 int32 int32))
+ (bstruct-alignof <mouse-button-event>))
+ (test-equal (max (alignof (list uint8))
+ (alignof (list uint8 int32 int32))
+ (alignof (list uint8 uint8 uint8 int32 int32)))
+ (bstruct-alignof <event>)))
+
+ (test-group "bstruct-sizeof"
+ (test-equal (sizeof (list float float))
+ (bstruct-sizeof <vec2>))
+ (test-equal (sizeof (list (list float float) (list float float)))
+ (bstruct-sizeof <vertex>))
+ (test-equal (sizeof (make-list 16 float))
+ (bstruct-sizeof <matrix4>))
+ (test-equal (sizeof (list uint8 int32 int32))
+ (bstruct-sizeof <mouse-move-event>))
+ (test-equal (sizeof (list uint8 uint8 uint8 int32 int32))
+ (bstruct-sizeof <mouse-button-event>))
+ (test-equal (max (sizeof (list uint8))
+ (sizeof (list uint8 int32 int32))
+ (sizeof (list uint8 uint8 uint8 int32 int32)))
+ (bstruct-sizeof <event>))
+ (test-equal (sizeof (list uint64 uint32 uint64 uint32))
+ (bstruct-sizeof <right-sized>)))
+
+ (test-group "bstruct-ref"
+ (test-equal 69.0
+ (bstruct-ref <vec2> (bstruct-alloc <vec2> (x 42) (y 69)) y))
+ (test-equal 42.0
+ (bstruct-ref <vertex> (bstruct-alloc <vertex> ((uv x) 42)) (uv x)))
+ (test-equal 4.0
+ (let ((bv (f32vector 1 2 3 4)))
+ (bstruct-ref <floats>
+ (bstruct-alloc <floats>
+ (items (bytevector->pointer bv)))
+ (items (* 3)))))
+ (test-equal %null-pointer
+ (bstruct-ref <node> (bstruct-alloc <node>) next)))
+
+ (test-group "bstruct-set!"
+ (test-equal 42.0
+ (let ((v (bstruct-alloc <vec2>)))
+ (bstruct-set! <vec2> v (y 42))
+ (bstruct-ref <vec2> v y)))
+ (test-equal 42.0
+ (let ((a (bstruct-alloc <matrix4>)))
+ (bstruct-set! <matrix4> a (7 42))
+ (bstruct-ref <matrix4> a 7)))
+ (test-equal 42.0
+ (let* ((bv (f32vector 0 0 0 0))
+ (f (bstruct-alloc <floats>)))
+ (bstruct-set! <floats> f (items (bytevector->pointer bv)))
+ (bstruct-set! <floats> f ((items (* 3)) 42))
+ (bstruct-ref <floats> f (items (* 3)))))
+ (test-equal 42
+ (let ((e (bstruct-alloc <event>)))
+ (bstruct-set! <event> e ((mouse-move y) 42))
+ (bstruct-ref <event> e (mouse-move y))))
+ (test-equal 69
+ (let* ((a (bstruct-alloc <node> (item 42)))
+ (b (bstruct-alloc <node> (item 69))))
+ (bstruct-set! <node> a (next (bstruct->pointer <node> b)))
+ (bstruct-ref <node> a (next * item)))))
+
+ (test-group "bstruct-pack!"
+ (test-equal (f32vector 42 69)
+ (let ((bv (f32vector 0 0)))
+ (bstruct-pack! <vec2> bv 0 (x 42) (y 69))
+ bv))
+ (test-equal (f32vector 1 2 3 4)
+ (let ((bv (f32vector 0 0 0 0)))
+ (bstruct-pack! <vertex> bv 0
+ (xy (bstruct-alloc <vec2> (x 1) (y 2)))
+ ((uv x) 3)
+ ((uv y) 4))
+ 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)))
+ (bstruct-pack! <matrix4> bv 0 (0 1) (5 1) (10 1) (15 1))
+ bv))
+ (test-equal (u8vector 1 2 0 0 3 0 0 0 4 0 0 0)
+ (let ((bv (make-u8vector (bstruct-sizeof <event>) 0)))
+ (bstruct-pack! <event> bv 0
+ ((mouse-button type) 1)
+ ((mouse-button button) 2)
+ ((mouse-button state) 0)
+ ((mouse-button x) 3)
+ ((mouse-button y) 4))
+ bv)))
+
+ (test-group "bstruct-unpack"
+ (test-equal '(42.0 69.0)
+ (let ((bv (f32vector 42 69)))
+ (call-with-values (lambda () (bstruct-unpack <vec2> bv 0 x y))
+ list)))
+ (test-equal (list 1.0 2.0 3.0 4.0)
+ (let ((bv (f32vector 1 2 3 4)))
+ (call-with-values (lambda ()
+ (bstruct-unpack <vertex> bv 0
+ (xy x) (xy y)
+ (uv x) (uv y)))
+ 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 ()
+ (bstruct-unpack <matrix4> bv 0 0 5 10 15))
+ 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 ()
+ (bstruct-unpack <event> bv 0
+ (mouse-button type)
+ (mouse-button button)
+ (mouse-button state)
+ (mouse-button x)
+ (mouse-button y)))
+ list))))
+
+ (test-group "bstruct-copy"
+ (test-equal '(42.0 69.0)
+ (let* ((v (bstruct-alloc <vec2> (x 42) (y 69)))
+ (v* (bstruct-copy <vec2> v)))
+ (list (bstruct-ref <vec2> v* x)
+ (bstruct-ref <vec2> v* y)))))
+
+ (test-group "bstruct-copy!"
+ (test-equal '(42.0 69.0)
+ (let* ((v (bstruct-alloc <vec2> (x 42) (y 69)))
+ (v* (bstruct-alloc <vec2>)))
+ (bstruct-copy! <vec2> v v*)
+ (list (bstruct-ref <vec2> v* x)
+ (bstruct-ref <vec2> v* y))))))
diff --git a/tests/utils.scm b/tests/utils.scm
new file mode 100644
index 0000000..1b0d4cd
--- /dev/null
+++ b/tests/utils.scm
@@ -0,0 +1,24 @@
+;;; 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.
+
+(define-module (tests utils)
+ #:use-module (srfi srfi-64)
+ #:export (test-suite))
+
+(define-syntax-rule (test-suite name body ...)
+ (begin
+ (test-begin name)
+ body ...
+ (exit (zero? (test-runner-fail-count (test-end))))))
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-21 09:03:58 +0000