1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
;;; bitfields.scm --- Struct bitfield constructor.
;; Copyright © 2015, 2016 Taylan Kammer <taylan.kammer@gmail.com>
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This module is complementary to the struct module. It isn't used on its own.
;; This code partly uses rational numbers for byte counts and offsets, to
;; represent granularity down to bits. I.e. 1/8 is a size or offset of one bit.
;;; Code:
;;; Only a macro for efficiency reasons.
(define-syntax bit-field/signed
(syntax-rules ()
((_ <num> <width> <start> <end> <signed?>)
(let ((unsigned-value (bit-field <num> <start> <end>)))
(if (not <signed?>)
unsigned-value
(let ((sign (bit-set? (- <width> 1) unsigned-value)))
(if sign
(- unsigned-value (expt 2 <width>))
unsigned-value)))))))
(define (validate-integer-descriptor descriptor)
(when (not (assq descriptor integer-descriptors))
(error "Invalid descriptor for bitfield." descriptor)))
(define (integer-descriptor-signed? descriptor)
(assq descriptor signed-integer-descriptors))
(define integer-descriptor-signed->unsigned-mapping
(map cons
(map car signed-integer-descriptors)
(map car unsigned-integer-descriptors)))
(define (integer-descriptor-signed->unsigned descriptor)
(cdr (assq descriptor integer-descriptor-signed->unsigned-mapping)))
(define (unsigned-integer-descriptor integer-descriptor)
(if (integer-descriptor-signed? integer-descriptor)
(integer-descriptor-signed->unsigned integer-descriptor)
integer-descriptor))
(define-record-type <bitfield-metadata>
(make-bitfield-metadata int-descriptor width)
bitfield-metadata?
(int-descriptor bitfield-metadata-int-descriptor)
(width bitfield-metadata-width))
(define (bitfield-descriptor int-descriptor bit-offset width)
(validate-integer-descriptor int-descriptor)
(let ((signed? (integer-descriptor-signed? int-descriptor))
(uint-descriptor (unsigned-integer-descriptor int-descriptor)))
(let ((num-getter (bytestructure-descriptor-getter uint-descriptor))
(num-setter (bytestructure-descriptor-setter uint-descriptor)))
(define start bit-offset)
(define end (+ start width))
(define (getter syntax? bytevector offset)
(let ((num (num-getter syntax? bytevector offset)))
(if syntax?
(quasisyntax
(bit-field/signed (unsyntax num) (unsyntax width)
(unsyntax start) (unsyntax end)
(unsyntax signed?)))
(bit-field/signed num width start end signed?))))
(define (setter syntax? bytevector offset value)
(let* ((oldnum (num-getter syntax? bytevector offset))
(newnum (if syntax?
(quasisyntax
(copy-bit-field (unsyntax oldnum) (unsyntax value)
(unsyntax start) (unsyntax end)))
(copy-bit-field oldnum value start end))))
(num-setter syntax? bytevector offset newnum)))
(define meta (make-bitfield-metadata int-descriptor width))
(make-bytestructure-descriptor #f #f #f getter setter meta))))
;;; bitfields.scm ends here
|
