From 3d7648b95385221741155b976477336acde6127f Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sun, 28 Jan 2024 13:25:22 -0500 Subject: Add bytestruct module. --- .dir-locals.el | 1 + Makefile.am | 2 + chickadee/data/bytestruct.scm | 1226 +++++++++++++++++++++++++++++++++++++++++ tests/bytestruct.scm | 276 ++++++++++ 4 files changed, 1505 insertions(+) create mode 100644 chickadee/data/bytestruct.scm create mode 100644 tests/bytestruct.scm 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 +;;; +;;; 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 + (make-scalar size alignment native? type) + scalar? + (size scalar-size) + (alignment scalar-alignment) + (native? scalar-native?) ; native endianness? + (type scalar-type)) + +(define-record-type + (make-struct-field name offset type) + struct-field? + (name struct-field-name) + (offset struct-field-offset) + (type struct-field-type)) + +(define-record-type + (make-struct size alignment fields) + %struct? + (size struct-size) + (alignment struct-alignment) + (fields struct-fields)) + +(define-record-type + (make-union-field name type) + union-field? + (name union-field-name) + (type union-field-type)) + +(define-record-type + (make-union size alignment fields) + union? + (size union-size) + (alignment union-alignment) + (fields union-fields)) + +(define-record-type + (make-array size alignment length type) + array? + (size array-size) + (alignment array-alignment) + (length array-length) + (type array-type)) + +(define-record-type + (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 + (($ name*) + (eq? name name*))) + (struct-fields struct)) + struct-field-type)) + +(define (union-field-ref struct name) + (and=> (find (match-lambda + (($ 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 ($ size) + ($ size) + ($ size) + ($ size) + ($ size)) + size))) + +(define (alignof type) + (match type + ((or ($ _ alignment) + ($ _ alignment) + ($ _ alignment) + ($ _ alignment) + ($ _ 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 + (make-vtable (string-append standard-vtable-fields "pwpw") + (lambda (desc port) + (format port "#" + (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 + (make-struct-layout "pwpw") + printer name type)) + +(define (bytestruct-descriptor? obj) + (and (struct? obj) (eq? (struct-vtable obj) ))) + +(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)) + (($ _ _ 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)))))) + (($ _ _ fields) + `(struct ,@(map (match-lambda + (($ name offset* type) + (list name (loop type (+ offset offset*))))) + fields))) + (($ _ _ fields) + `(union ,@(map (match-lambda + (($ name type) + (list name (loop type offset)))) + fields))) + (($ _ _ length type) + (let ((size (sizeof type))) + `(array ,@(map (lambda (i) + (loop type (+ offset (* i size)))) + (iota length))))) + (($ _ _ 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)) + (( obj) + (match obj + (($ ) #t) + (_ #f))))) + ((_ obj) + #'(%bytestruct? obj)) + ((_ obj) + (bytestruct-descriptor-identifier? #') + #'(match obj + (($ ) #t) + (_ #f)))))) + +(define-syntax bytestruct=? + (lambda (stx) + (syntax-case stx () + ((_ a b) + (bytestruct-descriptor-identifier? #') + #'(match a + (($ bv-a offset-a) + (match b + (($ bv-b offset-b) + (let ((n (bytestruct-sizeof ))) + (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 () + ((_ bs) + (bytestruct-descriptor-identifier? #') + #'(match bs + (($ bv offset) + (ffi:bytevector->pointer bv offset))))))) + +(define-syntax pointer->bytestruct + (lambda (stx) + (syntax-case stx () + ((_ ptr) + (bytestruct-descriptor-identifier? #') + #'(let ((size (bytestruct-sizeof ))) + (make-bytestruct (ffi:pointer->bytevector ptr size) 0)))))) + +;; Wrap a bytevector in a bytestruct. +(define-syntax bytestruct-wrap + (lambda (stx) + (syntax-case stx () + ((_ bv offset) + (bytestruct-descriptor-identifier? #') + #'(make-bytestruct bv offset))))) + +;; Unwrap a bytestruct to a bytevector + offset. +(define-syntax bytestruct-unwrap + (lambda (stx) + (syntax-case stx () + ((_ bs) + (bytestruct-descriptor-identifier? #') + #`(match bs + (($ bv offset) + (values bv offset))))))) + +;; Size/align queries. +(define-syntax bytestruct-sizeof + (lambda (stx) + (syntax-case stx () + ((_ ) + (bytestruct-descriptor-identifier? #') + (bytestruct-descriptor-identifier-size #'))))) + +(define-syntax bytestruct-alignof + (lambda (stx) + (syntax-case stx () + ((_ ) + (bytestruct-descriptor-identifier? #') + (bytestruct-descriptor-identifier-alignment #'))))) + +;; 'bytestruct-pack!' and 'bytestruct-unpack' allow for directly +;; interpreting bytevector contents as structured data. +(define-syntax bytestruct-unpack + (lambda (stx) + (syntax-case stx () + ((_ (elem ...) bv i) + (bytestruct-descriptor-identifier? #') + #`(values + #,@(map (lambda (elem) + (syntax-case elem () + ((e ...) + #'(( getter e ...) bv i)))) + #'(elem ...))))))) + +(define-syntax bytestruct-pack! + (lambda (stx) + (syntax-case stx () + ((_ ((elem val) ...) bv i) + (bytestruct-descriptor-identifier? #') + #`(begin + #,@(map (lambda (elem val) + (syntax-case elem () + ((e ...) + #`(( 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 () + ((_ (elem val) ...) + (bytestruct-descriptor-identifier? #') + (let ((size (bytestruct-descriptor-identifier-size #'))) + #`(let ((bv (make-bytevector #,size 0))) + (bytestruct-pack! ((elem val) ...) bv 0) + (bytestruct-wrap bv 0))))))) + +;; Return the value of an element. +(define-syntax bytestruct-ref + (lambda (stx) + (syntax-case stx () + ((_ (elem ...) bs) + (bytestruct-descriptor-identifier? #') + #`(match bs + ;; Using 'exact-integer?' here assists the type inference + ;; pass and allows for unboxed addition of offsets. + (($ bv (? exact-integer? offset)) + (bytestruct-unpack ((elem ...)) bv offset))))))) + +;; Create a pointer to some element within a bytestruct. +(define-syntax bytestruct-&ref + (lambda (stx) + (syntax-case stx () + ((_ (elem ...) bs) + (bytestruct-descriptor-identifier? #') + #'(match bs + (($ bv (? exact-integer? offset)) + (call-with-values (lambda () (( 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 () + ((_ elem bs x) + (bytestruct-descriptor-identifier? #') + #'(match bs + (($ bv (? exact-integer? offset)) + (bytestruct-pack! ((elem x)) bv offset))))))) + +(define-syntax bytestruct-copy! + (lambda (stx) + (syntax-case stx () + ((_ src dst) + (bytestruct-descriptor-identifier? #') + #'(match src + (($ src-bv (? exact-integer? src-offset)) + (match dst + (($ dst-bv (? exact-integer? dst-offset)) + (bytevector-copy! src-bv src-offset + dst-bv dst-offset + (bytestruct-sizeof )))))))))) + +(define-syntax bytestruct-copy + (lambda (stx) + (syntax-case stx () + ((_ src) + (bytestruct-descriptor-identifier? #') + #'(let ((dst (bytestruct-alloc ))) + (bytestruct-copy! 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 elem ...) + (define-inlinable (name ))) + +(define-syntax-rule (define-bytestruct-predicate name ) + (define-inlinable (name obj) + (bytestruct? obj))) + +(define-syntax-rule (define-bytestruct-getter name elem) + (define-inlinable (name bs) + (bytestruct-ref elem bs))) + +(define-syntax-rule (define-bytestruct-setter name elem) + (define-inlinable (name bs x) + (bytestruct-set! elem bs x))) + +(define-syntax define-bytestruct-accessor + (syntax-rules () + ((_ (getter setter) elem) + (begin + (define-bytestruct-getter getter elem) + (define-bytestruct-setter setter elem))) + ((_ (getter) elem) + (define-bytestruct-getter getter 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 () + ((_ + (constructor arg ...) + predicate + fields+kwargs ...) + (and (identifier? #') + (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 + (struct (field-name field-type) ...) + #:printer (lambda (obj port) + (display "#<" port) + (display ' port) + (let ((val (bytestruct-ref (field-name) obj))) + (display " " port) + (display 'field-name) + (display ": " port) + (display val port)) + ... + (display ">" port)) + #,@kwargs) + (define-inlinable (constructor arg ...) + (bytestruct-alloc ((arg) arg) ...)) + (define-bytestruct-predicate predicate ) + (define-bytestruct-accessor (field-getter . field-setter) + (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 +;;; +;;; 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 + (struct (x f32) (y f32))) + +(define-bytestruct + (struct (xy ) (uv ))) + +;; For testing arrays. +(define-bytestruct + (array 16 f32)) + +;; For testing variable length arrays. +(define-bytestruct + (struct (items (* f32)))) + +;; For testing unions. +(define-bytestruct + (struct (type u8) (x s32) (y s32))) + +(define-bytestruct + (struct (type u8) (button u8) (state u8) (x s32) (y s32))) + +(define-bytestruct + (union (type u8) + (mouse-move ) + (mouse-button ))) + +;; For testing recursive types. +(define-bytestruct + (struct (item int) (next (* )))) + +(with-tests "bytestruct" + (test-group "bytestruct?" + (test-assert (bytestruct? (bytestruct-alloc ))) + (test-assert (not (bytestruct? 'vec2))) + (test-assert (bytestruct? (bytestruct-alloc ))) + (test-assert (not (bytestruct? (bytestruct-alloc ))))) + + (test-group "bytestruct=?" + (test-assert (bytestruct=? + (bytestruct-alloc ((x) 42) ((y) 69)) + (bytestruct-alloc ((x) 42) ((y) 69)))) + (test-assert (not (bytestruct=? + (bytestruct-alloc ((x) 42) ((y) 69)) + (bytestruct-alloc ((x) 77) ((y) 89)))))) + + (test-group "bytestruct->sexp" + (test-equal '(struct (x 42.0) (y 69.0)) + (bytestruct->sexp (bytestruct-alloc ((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 + ((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 ((type) 1)))) + (test-equal '(struct (item 42) (next null)) + (bytestruct->sexp (bytestruct-alloc ((item) 42))))) + + (test-group "bytestruct->pointer" + (test-equal #vu8(0 0 40 66 0 0 138 66) + (let ((v (bytestruct-alloc ((x) 42) ((y) 69)))) + (pointer->bytevector (bytestruct->pointer v) + (bytestruct-sizeof ))))) + + (test-group "pointer->bytestruct" + (test-equal 69.0 + (let ((v (bytestruct-alloc ((x) 42) ((y) 69)))) + (bytestruct-ref (y) + (pointer->bytestruct + (bytestruct->pointer v)))))) + + (test-group "bytestruct-wrap" + (test-equal 69.0 + (bytestruct-ref (y) (bytestruct-wrap (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 + (bytestruct-alloc + ((x) 42) + ((y) 69)))) + list))) + + (test-group "bytestruct-alignof" + (test-equal (alignof (list float float)) + (bytestruct-alignof )) + (test-equal (alignof (list (list float float) (list float float))) + (bytestruct-alignof )) + (test-equal (alignof (make-list 16 float)) + (bytestruct-alignof )) + (test-equal (alignof (list uint8 int32 int32)) + (bytestruct-alignof )) + (test-equal (alignof (list uint8 uint8 uint8 int32 int32)) + (bytestruct-alignof )) + (test-equal (max (alignof (list uint8)) + (alignof (list uint8 int32 int32)) + (alignof (list uint8 uint8 uint8 int32 int32))) + (bytestruct-alignof ))) + + (test-group "bytestruct-sizeof" + (test-equal (sizeof (list float float)) + (bytestruct-sizeof )) + (test-equal (sizeof (list (list float float) (list float float))) + (bytestruct-sizeof )) + (test-equal (sizeof (make-list 16 float)) + (bytestruct-sizeof )) + (test-equal (sizeof (list uint8 int32 int32)) + (bytestruct-sizeof )) + (test-equal (sizeof (list uint8 uint8 uint8 int32 int32)) + (bytestruct-sizeof )) + (test-equal (max (sizeof (list uint8)) + (sizeof (list uint8 int32 int32)) + (sizeof (list uint8 uint8 uint8 int32 int32))) + (bytestruct-sizeof ))) + + (test-group "bytestruct-ref" + (test-equal 69.0 + (bytestruct-ref (y) (bytestruct-alloc ((x) 42) ((y) 69)))) + (test-equal 42.0 + (bytestruct-ref (uv x) (bytestruct-alloc ((uv x) 42)))) + (test-equal 4.0 + (let ((bv (f32vector 1 2 3 4))) + (bytestruct-ref (items (* 3)) + (bytestruct-alloc + ((items) (bytevector->pointer bv)))))) + (test-equal %null-pointer + (bytestruct-ref (next) (bytestruct-alloc )))) + + (test-group "bytestruct-&ref" + (let ((bv (f32vector 42 69))) + (test-equal (bytevector->pointer bv 4) + (bytestruct-&ref (y) (bytestruct-wrap bv 0))))) + + (test-group "bytestruct-set!" + (test-equal 42.0 + (let ((v (bytestruct-alloc ))) + (bytestruct-set! (y) v 42) + (bytestruct-ref (y) v))) + (test-equal 42.0 + (let ((a (bytestruct-alloc ))) + (bytestruct-set! (7) a 42) + (bytestruct-ref (7) a))) + (test-equal 42.0 + (let* ((bv (f32vector 0 0 0 0)) + (f (bytestruct-alloc ))) + (bytestruct-set! (items) f (bytevector->pointer bv)) + (bytestruct-set! (items (* 3)) f 42) + (bytestruct-ref (items (* 3)) f))) + (test-equal 42 + (let ((e (bytestruct-alloc ))) + (bytestruct-set! (mouse-move y) e 42) + (bytestruct-ref (mouse-move y) e))) + (test-equal 69 + (let* ((a (bytestruct-alloc ((item) 42))) + (b (bytestruct-alloc ((item) 69)))) + (bytestruct-set! (next) a (bytestruct->pointer b)) + (bytestruct-ref (next * item) a)))) + + (test-group "bytestruct-pack!" + (test-equal (f32vector 42 69) + (let ((bv (f32vector 0 0))) + (bytestruct-pack! (((x) 42) ((y) 69)) bv 0) + bv)) + (test-equal (f32vector 1 2 3 4) + (let ((bv (f32vector 0 0 0 0))) + (bytestruct-pack! + (((xy) (bytestruct-alloc ((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! + (((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 ) 0))) + (bytestruct-pack! + (((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 ((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 + ((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 + ((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 + ((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 ((x) 42) ((y) 69))) + (v* (bytestruct-copy v))) + (list (bytestruct-ref (x) v*) + (bytestruct-ref (y) v*))))) + + (test-group "bytestruct-copy!" + (test-equal '(42.0 69.0) + (let* ((v (bytestruct-alloc ((x) 42) ((y) 69))) + (v* (bytestruct-alloc ))) + (bytestruct-copy! v v*) + (list (bytestruct-ref (x) v*) + (bytestruct-ref (y) v*)))))) -- cgit v1.2.3