3 (in-package :lodematron
)
5 ;; -- reading atomic binary values -----------------------------------------
7 (defgeneric read-value
(type stream
&key array-size alignment endian
)
8 (:documentation
"Read a value of the given type from the file."))
10 ;; -- read aligned binary data ----------------------------------------------
12 (defgeneric align-for-read
(stream alignment
))
14 (defconstant +word-align
+ 1)
15 (defconstant +dword-align
+ 3)
16 (defconstant +qword-align
+ 7)
18 (defmethod align-for-read ((self stream
) alignment
)
19 "Align a file stream for reading at alignment bytes boundary."
20 (when (not (zerop alignment
))
22 (until (zerop (logand (file-position self
) alignment
)))
25 ;; -- read arrays of binary data ---------------------------------------------
27 (defmacro with-size-and-alignment-read
(array-element-type alignment array-size
&rest body
)
28 "Use the function body to read a value into an array of the given
29 size, begnning the read at the given alignment. Assumes the read will
30 be from a variable bound to a symbol called self, and alingment is
31 performed by calling (align-for-read self bytes)."
32 (once-only (alignment array-size
)
33 (with-gensyms (read-once result
)
34 `(labels ((,read-once
()
37 (align-for-read self alignment
))
38 (if (not (zerop ,array-size
))
39 (let ((,result
(make-array ,array-size
:element-type
',array-element-type
)))
41 for index from
0 below
,array-size
43 (setf (aref ,result index
) (,read-once
)))
48 (defmethod read-value ((type (eql 'u8
)) (self stream
) &key
(array-size 0) (alignment 1) (endian :little
))
49 (declare (ignore endian
))
50 (with-size-and-alignment-read
51 (unsigned-byte 8) alignment array-size
55 (defmethod read-value ((type (eql 's8
)) (self stream
) &key
(array-size 0) (alignment 1) (endian :little
))
56 (declare (ignore endian
))
57 (with-size-and-alignment-read
58 (unsigned-byte 8) alignment array-size
59 (let ((u8 (read-value 'u8 self
)))
64 (defmethod read-value ((type (eql 'u16
)) (self stream
) &key
(array-size 0) (alignment 1) (endian :little
))
65 (with-size-and-alignment-read
66 (unsigned-byte 16) alignment array-size
70 (setf (ldb (byte 8 0) u16
) (read-byte self
))
71 (setf (ldb (byte 8 8) u16
) (read-byte self
))
75 (setf (ldb (byte 8 8) u16
) (read-byte self
))
76 (setf (ldb (byte 8 0) u16
) (read-byte self
))
79 (defmethod read-value ((type (eql 's16
)) (self stream
) &key
(array-size 0) (alignment 1) (endian :little
))
80 (with-size-and-alignment-read
81 (unsigned-byte 16) alignment array-size
82 (let ((u16 (read-value 'u16 self
:endian endian
)))
87 (defmethod read-value ((type (eql 'u32
)) (self stream
) &key
(array-size 0) (alignment 1) (endian :little
))
88 (with-size-and-alignment-read
89 (unsigned-byte 32) alignment array-size
93 (setf (ldb (byte 8 0) u32
) (read-byte self
))
94 (setf (ldb (byte 8 8) u32
) (read-byte self
))
95 (setf (ldb (byte 8 16) u32
) (read-byte self
))
96 (setf (ldb (byte 8 24) u32
) (read-byte self
))
100 (setf (ldb (byte 8 24) u32
) (read-byte self
))
101 (setf (ldb (byte 8 16) u32
) (read-byte self
))
102 (setf (ldb (byte 8 8 ) u32
) (read-byte self
))
103 (setf (ldb (byte 8 0) u32
) (read-byte self
))
106 (defmethod read-value ((type (eql 's32
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
107 (with-size-and-alignment-read
108 (unsigned-byte 32) alignment array-size
109 (let ((u32 (read-value 'u32 self
:endian endian
)))
110 (if (> u32
#X7FFFFFFF
)
114 (defmethod read-value ((type (eql 'u64
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
115 (with-size-and-alignment-read
116 (unsigned-byte 32) alignment array-size
120 (setf (ldb (byte 8 0) u64
) (read-byte self
))
121 (setf (ldb (byte 8 8) u64
) (read-byte self
))
122 (setf (ldb (byte 8 16) u64
) (read-byte self
))
123 (setf (ldb (byte 8 24) u64
) (read-byte self
))
124 (setf (ldb (byte 8 32) u64
) (read-byte self
))
125 (setf (ldb (byte 8 40) u64
) (read-byte self
))
126 (setf (ldb (byte 8 48) u64
) (read-byte self
))
127 (setf (ldb (byte 8 56) u64
) (read-byte self
))
131 (setf (ldb (byte 8 56) u64
) (read-byte self
))
132 (setf (ldb (byte 8 48) u64
) (read-byte self
))
133 (setf (ldb (byte 8 40) u64
) (read-byte self
))
134 (setf (ldb (byte 8 32) u64
) (read-byte self
))
135 (setf (ldb (byte 8 24) u64
) (read-byte self
))
136 (setf (ldb (byte 8 16) u64
) (read-byte self
))
137 (setf (ldb (byte 8 8 ) u64
) (read-byte self
))
138 (setf (ldb (byte 8 0) u64
) (read-byte self
))
141 (defmethod read-value ((type (eql 's64
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
142 (with-size-and-alignment-read
143 (unsigned-byte 32) alignment array-size
144 (let ((u64 (read-value 'u64 self
:endian endian
)))
145 (if (> u64
#X7FFFFFFFFFFFFFFF
)
146 (- u64
#X10000000000000000
)
149 (defmethod read-value ((type (eql 'float32
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
150 (with-size-and-alignment-read
151 (unsigned-byte 32) alignment array-size
152 (let ((u32 (read-value 'u32 self
:endian endian
)))
153 (ieee-floats::decode-float32 u32
))))
155 (defmethod read-value ((type (eql 'float64
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
156 (with-size-and-alignment-read
157 (unsigned-byte 32) alignment array-size
158 (let ((u64 (read-value 'u64 self
:endian endian
)))
159 (ieee-floats::decode-float64 u64
))))
161 (defmethod read-value ((type (eql 'asciiz
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
162 (with-size-and-alignment-read
163 t alignment array-size
164 (let ((result (make-array '(0) :element-type
'base-char
:fill-pointer
0 :adjustable t
)))
166 (for byte
= (read-byte self
))
168 (vector-push-extend (code-char byte
) result
))