summaryrefslogtreecommitdiff
path: root/bstruct.scm
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2024-11-23 10:02:52 -0500
committerDavid Thompson <dthompson2@worcester.edu>2024-11-23 10:02:52 -0500
commit8aff7a348967bafa5deeea10916d72370888a7d5 (patch)
treeeaa2ed9039cf7b44553761b7260ea9bcda7ac2df /bstruct.scm
parentb882724e502c07c7e4e475d266dbb5175c661b48 (diff)
Add bit fields.
Diffstat (limited to 'bstruct.scm')
-rw-r--r--bstruct.scm387
1 files changed, 266 insertions, 121 deletions
diff --git a/bstruct.scm b/bstruct.scm
index 2755303..df5163a 100644
--- a/bstruct.scm
+++ b/bstruct.scm
@@ -83,6 +83,22 @@
(native? scalar-native?) ; native endianness?
(type scalar-type))
+(define-record-type <bit-field>
+ (make-bit-field name offset length signed?)
+ bit-field?
+ (name bit-field-name)
+ (offset bit-field-offset)
+ (length bit-field-length)
+ (signed? bit-field-signed?))
+
+(define-record-type <bits>
+ (make-bits size align native? fields)
+ bits?
+ (size bits-size)
+ (align bits-align)
+ (native? bits-native?)
+ (fields bits-fields))
+
(define-record-type <struct-field>
(make-struct-field name offset type)
struct-field?
@@ -126,8 +142,6 @@
;; Mutable for setting up recursive types.
(type pointer-type set-pointer-type!))
-;; TODO: bitfields
-
(define (struct-field-ref struct name)
(and=> (find (match-lambda
(($ <struct-field> name*)
@@ -144,6 +158,7 @@
(define (bstruct-type? obj)
(or (scalar? obj)
+ (bits? obj)
(%struct? obj)
(union? obj)
(array? obj)
@@ -152,6 +167,7 @@
(define (sizeof type)
(match type
((or ($ <scalar> size)
+ ($ <bits> size)
($ <struct> size)
($ <union> size)
($ <array> size)
@@ -161,6 +177,7 @@
(define (alignof type)
(match type
((or ($ <scalar> _ align)
+ ($ <bits> _ align)
($ <struct> _ align)
($ <union> _ align)
($ <array> _ align)
@@ -354,6 +371,20 @@
('ptrdiff_t (bytevector-sint-ref bv offset e (ffi:sizeof ffi:ptrdiff_t)))
('intptr_t (bytevector-sint-ref bv offset e (ffi:sizeof ffi:intptr_t)))
('uintptr_t (bytevector-uint-ref bv offset e (ffi:sizeof ffi:uintptr_t))))))
+ (($ <bits> size _ native? fields)
+ (let ((e (if native? (target-endianness) (non-target-endianness))))
+ `(bits
+ ,@(map (match-lambda
+ (($ <bit-field> name start len signed?)
+ (list name
+ (let ((x (ash (logand (bytevector-uint-ref bv offset
+ e size)
+ (ash (1- (ash 1 len)) start))
+ (- start))))
+ (if signed?
+ (centered-remainder x (ash 1 len))
+ x)))))
+ fields))))
(($ <struct> _ _ fields)
`(struct ,@(map (match-lambda
(($ <struct-field> name offset* type)
@@ -617,6 +648,10 @@
(define-syntax define-bstruct-descriptor
(lambda (stx)
+ (define (build-bit-field stx)
+ (syntax-case stx ()
+ ((name offset len signed?)
+ #`(make-bit-field 'name offset len signed?))))
(define (build-struct-field stx)
(syntax-case stx ()
((name offset type)
@@ -633,6 +668,10 @@
((scalar size align native? type)
(symbolic-match? scalar)
#'(make-scalar size align native? 'type))
+ ((bits size align native? (field ...))
+ (symbolic-match? bits)
+ (with-syntax (((field ...) (map build-bit-field #'(field ...))))
+ #'(make-bits size align native? (list field ...))))
((struct size align (field ...))
(symbolic-match? struct)
(with-syntax (((field ...) (map build-struct-field #'(field ...))))
@@ -663,6 +702,9 @@
((scalar size _ _ _)
(symbolic-match? scalar)
(syntax->datum #'size))
+ ((bits size _ _ _)
+ (symbolic-match? bits)
+ (syntax->datum #'size))
((struct size _ _)
(symbolic-match? struct)
(syntax->datum #'size))
@@ -686,6 +728,9 @@
((scalar _ align _ _)
(symbolic-match? scalar)
(syntax->datum #'align))
+ ((bits _ align _ _)
+ (symbolic-match? bits)
+ (syntax->datum #'align))
((struct _ align _)
(symbolic-match? struct)
(syntax->datum #'align))
@@ -722,6 +767,18 @@
(symbolic-match? scalar)
(syntax-case stx ()
(() (proc type offset))))
+ ((bits size _ native? (field ...))
+ (symbolic-match? bits)
+ (syntax-case stx ()
+ ((e)
+ (identifier? #'e)
+ (let ((name (syntax->datum #'e)))
+ (let field-lp ((fields #'(field ...)))
+ (syntax-case fields ()
+ (((name* offset* len signed?) . rest)
+ (if (identifier-eq? #'name* name)
+ (proc #`(bit-field size offset* len signed? native?) offset)
+ (field-lp #'rest)))))))))
((struct _ _ (field ...))
(symbolic-match? struct)
(syntax-case stx ()
@@ -730,9 +787,8 @@
(let ((name (syntax->datum #'e)))
(let field-lp ((fields #'(field ...)))
(syntax-case fields ()
- (() (error "no such struct field" name))
(((name* offset* type*) . rest)
- (if (eq? name (syntax->datum #'name*))
+ (if (identifier-eq? #'name* name)
(loop #'(elem ...) #'type* #`(+ #,offset offset*))
(field-lp #'rest)))))))))
((union _ _ (field ...))
@@ -743,9 +799,8 @@
(let ((name (syntax->datum #'e)))
(let field-lp ((fields #'(field ...)))
(syntax-case fields ()
- (() (error "no such union field" name))
(((name* type) . rest)
- (if (eq? name (syntax->datum #'name*))
+ (if (identifier-eq? #'name* name)
(loop #'(elem ...) #'type offset)
(field-lp #'rest)))))))))
((array _ _ length type)
@@ -828,66 +883,71 @@
((scalar size align native? type)
(symbolic-match? scalar)
#'(values bv offset))
+ ((bit-field size start len signed? native?)
+ (symbolic-match? bit-field)
+ (syntax-violation 'bstruct->pointer
+ "cannot create pointer to bit field"
+ id elems))
(sub-offset
#'(sub-offset bv (+ i offset))))))
elems id 'offset type)))
-(define (expand-getter elems id type)
;; Primitive getter/setter helpers
- (define (ref/endianness proc endianness)
- #`(lambda (bv i)
- (#,proc bv i #,endianness)))
- (define (uint-ref size endianness)
- #`(lambda (bv i)
- (bytevector-uint-ref bv i '#,(datum->syntax #f endianness) #,size)))
- (define (sint-ref size endianness)
- #`(lambda (bv i)
- (bytevector-sint-ref bv i '#,(datum->syntax #f endianness) #,size)))
- ;; Scalar types are divided into two categories: machine
- ;; indepenent and machine dependent. The machine independent
- ;; types (i32, f32, etc.) have a known size and alignment on all
- ;; platforms. The machine dependent types have a size and
- ;; alignment that can vary depending on the ABI of the system that
- ;; is compiling the code.
- (define (abi-ref type e) ; e for endianness
+(define (ref/endianness proc endianness)
+ #`(lambda (bv i)
+ (#,proc bv i #,endianness)))
+(define (uint-ref size endianness)
+ #`(lambda (bv i)
+ (bytevector-uint-ref bv i '#,(datum->syntax #f endianness) #,size)))
+(define (sint-ref size endianness)
+ #`(lambda (bv i)
+ (bytevector-sint-ref bv i '#,(datum->syntax #f endianness) #,size)))
+;; Scalar types are divided into two categories: machine
+;; indepenent and machine dependent. The machine independent
+;; types (i32, f32, etc.) have a known size and alignment on all
+;; platforms. The machine dependent types have a size and
+;; alignment that can vary depending on the ABI of the system that
+;; is compiling the code.
+(define (abi-ref type e) ; e for endianness
+ (match type
+ ('uint (uint-ref (sizeof* 'uint) e))
+ ('int (sint-ref (sizeof* 'int) e))
+ ('ulong (uint-ref (sizeof* 'ulong) e))
+ ('long (sint-ref (sizeof* 'long) e))
+ ('ushort (uint-ref (sizeof* 'ushort) e))
+ ('short (sint-ref (sizeof* 'short) e))
+ ('size_t (uint-ref (sizeof* 'size_t) e))
+ ('ssize_t (sint-ref (sizeof* 'ssize_t) e))
+ ('ptrdiff_t (sint-ref (sizeof* 'ptrdiff_t) e))
+ ('intptr_t (sint-ref (sizeof* 'intptr_t) e))
+ ('uintptr_t (uint-ref (sizeof* 'uintptr_t) e))))
+(define (primitive-getter native? type)
+ (if native?
(match type
- ('uint (uint-ref (sizeof* 'uint) e))
- ('int (sint-ref (sizeof* 'int) e))
- ('ulong (uint-ref (sizeof* 'ulong) e))
- ('long (sint-ref (sizeof* 'long) e))
- ('ushort (uint-ref (sizeof* 'ushort) e))
- ('short (sint-ref (sizeof* 'short) e))
- ('size_t (uint-ref (sizeof* 'size_t) e))
- ('ssize_t (sint-ref (sizeof* 'ssize_t) e))
- ('ptrdiff_t (sint-ref (sizeof* 'ptrdiff_t) e))
- ('intptr_t (sint-ref (sizeof* 'intptr_t) e))
- ('uintptr_t (uint-ref (sizeof* 'uintptr_t) e))))
- (define (primitive-getter size native? type)
- (if native?
+ ('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 #'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))))))
+ ('u16 (ref/endianness #'bytevector-u16-ref e))
+ ('s16 (ref/endianness #'bytevector-s16-ref e))
+ ('u32 (ref/endianness #'bytevector-u32-ref e))
+ ('s32 (ref/endianness #'bytevector-s32-ref e))
+ ('u64 (ref/endianness #'bytevector-u64-ref e))
+ ('s64 (ref/endianness #'bytevector-s64-ref e))
+ ('f32 (ref/endianness #'bytevector-ieee-single-ref e))
+ ('f64 (ref/endianness #'bytevector-ieee-double-ref e))
+ (_ (abi-ref type e))))))
+(define (expand-getter elems id type)
#`(lambda (bv i)
#,(expand-accessor
(lambda (type offset)
@@ -904,63 +964,83 @@
#,(target-word-size))))
((scalar size align native? type)
(symbolic-match? scalar)
- (with-syntax ((getter (primitive-getter (syntax->datum #'size)
- (syntax->datum #'native?)
+ (with-syntax ((getter (primitive-getter (syntax->datum #'native?)
(syntax->datum #'type))))
#'(getter bv (+ i offset))))
+ ((bit-field size start len signed? native?)
+ (symbolic-match? bit-field)
+ (let ((type (if (syntax->datum #'signed?)
+ (match (syntax->datum #'size)
+ (1 's8)
+ (2 's16)
+ (4 's32)
+ (8 's64))
+ (match (syntax->datum #'size)
+ (1 'u8)
+ (2 'u16)
+ (4 'u32)
+ (8 'u64)))))
+ (with-syntax ((getter (primitive-getter (syntax->datum #'native?)
+ type)))
+ #'(let ((x (ash (logand (getter bv (+ i offset))
+ (ash (1- (ash 1 len)) start))
+ (- start))))
+ (if signed?
+ (centered-remainder x (ash 1 len))
+ x)))))
(sub-get
#'(sub-get bv (+ i offset))))))
elems id 'getter type)))
-(define (expand-setter elems id type size)
- (define (set!/endianness proc endianness)
- #`(lambda (bv i x)
- (#,proc bv i x #,endianness)))
- (define (uint-set! size endianness)
- #`(lambda (bv i x)
- (bytevector-uint-set! bv i x '#,(datum->syntax #f endianness) #,size)))
- (define (sint-set! size endianness)
- #`(lambda (bv i x)
- (bytevector-sint-set! bv i x '#,(datum->syntax #f endianness) #,size)))
- (define (abi-set! type e)
- (match type
- ('uint (uint-set! (sizeof* 'uint) e))
- ('int (sint-set! (sizeof* 'int) e))
- ('ulong (uint-set! (sizeof* 'ulong) e))
- ('long (sint-set! (sizeof* 'long) e))
- ('ushort (uint-set! (sizeof* 'ushort) e))
- ('short (sint-set! (sizeof* 'short) e))
- ('size_t (uint-set! (sizeof* 'size_t) e))
- ('ssize_t (sint-set! (sizeof* 'ssize_t) e))
- ('ptrdiff_t (sint-set! (sizeof* 'ptrdiff_t) e))
- ('intptr_t (sint-set! (sizeof* 'intptr_t) e))
- ('uintptr_t (uint-set! (sizeof* 'uintptr_t) e))))
- (define (primitive-setter size native? type)
- (if native?
+(define (set!/endianness proc endianness)
+ #`(lambda (bv i x)
+ (#,proc bv i x #,endianness)))
+(define (uint-set! size endianness)
+ #`(lambda (bv i x)
+ (bytevector-uint-set! bv i x '#,(datum->syntax #f endianness) #,size)))
+(define (sint-set! size endianness)
+ #`(lambda (bv i x)
+ (bytevector-sint-set! bv i x '#,(datum->syntax #f endianness) #,size)))
+(define (abi-set! type e)
+ (match type
+ ('uint (uint-set! (sizeof* 'uint) e))
+ ('int (sint-set! (sizeof* 'int) e))
+ ('ulong (uint-set! (sizeof* 'ulong) e))
+ ('long (sint-set! (sizeof* 'long) e))
+ ('ushort (uint-set! (sizeof* 'ushort) e))
+ ('short (sint-set! (sizeof* 'short) e))
+ ('size_t (uint-set! (sizeof* 'size_t) e))
+ ('ssize_t (sint-set! (sizeof* 'ssize_t) e))
+ ('ptrdiff_t (sint-set! (sizeof* 'ptrdiff_t) e))
+ ('intptr_t (sint-set! (sizeof* 'intptr_t) e))
+ ('uintptr_t (uint-set! (sizeof* 'uintptr_t) e))))
+(define (primitive-setter native? type)
+ (if native?
+ (match type
+ ('u8 #'bytevector-u8-set!)
+ ('s8 #'bytevector-s8-set!)
+ ('u16 #'bytevector-u16-native-set!)
+ ('s16 #'bytevector-s16-native-set!)
+ ('u32 #'bytevector-u32-native-set!)
+ ('s32 #'bytevector-s32-native-set!)
+ ('u64 #'bytevector-u64-native-set!)
+ ('s64 #'bytevector-s64-native-set!)
+ ('f32 #'bytevector-ieee-single-native-set!)
+ ('f64 #'bytevector-ieee-double-native-set!)
+ (_ (abi-set! type (target-endianness))))
+ (let ((e (non-target-endianness)))
(match type
('u8 #'bytevector-u8-set!)
('s8 #'bytevector-s8-set!)
- ('u16 #'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))))))
+ ('u16 (set!/endianness #'bytevector-u16-set! e))
+ ('s16 (set!/endianness #'bytevector-s16-set! e))
+ ('u32 (set!/endianness #'bytevector-u32-set! e))
+ ('s32 (set!/endianness #'bytevector-s32-set! e))
+ ('u64 (set!/endianness #'bytevector-u64-set! e))
+ ('s64 (set!/endianness #'bytevector-s64-set! e))
+ ('f32 (set!/endianness #'bytevector-ieee-single-set! e))
+ ('f64 (set!/endianness #'bytevector-ieee-double-set! e))
+ (_ (abi-set! type e))))))
+(define (expand-setter elems id type size)
#`(lambda (bv i x)
#,(expand-accessor
(lambda (type offset)
@@ -980,13 +1060,46 @@
#,(target-word-size)))
((scalar size align native? type)
(symbolic-match? scalar)
- (with-syntax ((setter (primitive-setter (syntax->datum #'size)
- (syntax->datum #'native?)
+ (with-syntax ((setter (primitive-setter (syntax->datum #'native?)
(syntax->datum #'type))))
#'(setter bv (+ i offset) x)))
+ ((bit-field size start len signed? native?)
+ (symbolic-match? bit-field)
+ (let ((type (if (syntax->datum #'signed?)
+ (match (syntax->datum #'size)
+ (1 's8)
+ (2 's16)
+ (4 's32)
+ (8 's64))
+ (match (syntax->datum #'size)
+ (1 'u8)
+ (2 'u16)
+ (4 'u32)
+ (8 'u64))))
+ (native? (syntax->datum #'native?)))
+ (with-syntax ((getter (primitive-getter native? type))
+ (setter (primitive-setter native? type)))
+ ;; The mask keeps the bits that are *not* part of
+ ;; the bit field for the existing value.
+ #'(let* ((mask (lognot (ash (1- (ash 1 len)) start)))
+ (rest (logand (getter bv (+ i offset)) mask)))
+ (define (fail)
+ (error "bit field value out of range" x))
+ (if signed?
+ (if (<= (ash -1 (1- len)) x (1- (ash 1 (1- len))))
+ ;; Convert to unsigned representation.
+ (let ((u (logand (1- (ash 1 len)) x)))
+ (setter bv (+ i offset)
+ (logior rest (ash u start))))
+ (fail))
+ (if (<= 0 x (1- (ash 1 len)))
+ (setter bv (+ i offset)
+ (logior rest (ash x start)))
+ (fail)))))))
(sub-set!
#'(sub-set! bv (+ i offset) x)))))
elems id 'setter type)))
+
(define-syntax define-bstruct-macro
(lambda (stx)
(syntax-case stx ()
@@ -1036,6 +1149,8 @@
'(u8 s8 u16 s16 u32 s32 u64 s64 f32 f64
int uint long ulong short ushort
size_t ssize_t ptrdiff_t intptr_t uintptr_t))
+ (define bit-field-primitives
+ (remove (lambda (t) (memq t '(f32 f64))) primitives))
(define (target-endianness? e)
(eq? e (target-endianness)))
(define (resolve-endianness e)
@@ -1068,23 +1183,49 @@
#,(alignof* type)
#,(target-endianness? endianness)
primitive)))
+ ((bits field ...)
+ (symbolic-match? bits)
+ (let lp ((field-stx #'(field ...)) (fields '()) (bits 0))
+ (syntax-case field-stx ()
+ (()
+ (let ()
+ (define (finish size)
+ #`(bits #,size #,size
+ #,(target-endianness? endianness)
+ #,(reverse fields)))
+ (cond
+ ((<= bits 8) (finish 1))
+ ((<= bits 16) (finish 2))
+ ((<= bits 32) (finish 4))
+ ((<= bits 64) (finish 8))
+ (else
+ (syntax-violation 'define-bstruct
+ "bit fields exceed maximum of 64 bits"
+ stx)))))
+ (((underscore len) . rest)
+ (and (identifier-eq? #'underscore '_)
+ (exact-integer? (syntax->datum #'len))
+ (positive? (syntax->datum #'len)))
+ (lp #'rest fields (+ bits (syntax->datum #'len))))
+ (((name len sign) . rest)
+ (and (identifier? #'name)
+ (identifier-memq? #'sign '(u s))
+ (exact-integer? (syntax->datum #'len))
+ (positive? (syntax->datum #'len)))
+ (let ((signed? (identifier-eq? #'sign 's)))
+ (lp #'rest
+ (cons #`(name #,bits len #,signed?) fields)
+ (+ bits (syntax->datum #'len))))))))
((struct field ...)
(and (symbolic-match? struct)
(not (null? #'(field ...))))
- (let loop ((stx #'(field ...)) (fields '()) (offset 0) (align 0))
+ (let lp ((stx #'(field ...)) (fields '()) (offset 0) (align 0))
(syntax-case stx ()
(()
;; Round up to a multiple of align to get final
;; size.
(let ((size (* (ceiling (/ offset align)) align)))
#`(struct #,size #,align #,(reverse fields))))
- ;; An underscore indicates a padding pseudo-field. It is
- ;; not included in the struct field list and just adds to
- ;; the offset.
- (((underscore expr) . rest)
- (identifier-eq? #'underscore '_)
- (let ((type (compute-layout #'expr #f group-ids packed? endianness)))
- (loop #'rest fields (+ offset (sizeof/syntax type)) align)))
(((name expr) . rest)
(identifier? #'name)
(let* ((type (compute-layout #'expr
@@ -1098,10 +1239,14 @@
field-align)))
(offset (+ offset padding))
(align (max align field-align)))
- (loop #'rest
- (cons #`(name #,offset #,type) fields)
- (+ offset (sizeof/syntax type))
- align))))))
+ (lp #'rest
+ (syntax-case #'name ()
+ (underscore
+ (identifier-eq? #'underscore '_)
+ fields)
+ (_ (cons #`(name #,offset #,type) fields)))
+ (+ offset (sizeof/syntax type))
+ align))))))
((union field ...)
(and (symbolic-match? union)
(not (null? #'(field ...))))