diff options
Diffstat (limited to 'bstruct.scm')
| -rw-r--r-- | bstruct.scm | 387 |
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 ...)))) |