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
)))
47 ;; (defmethod read-value ((type (eql 'u8)) (self binary-file-data) &key array-size alignment)
48 ;; (labels ((read-once ()
49 ;; (let ((result (aref (buffered-data-of self) (buffer-pos-of self))))
50 ;; (incf (buffer-pos-of self))
53 ;; (align-for-read self alignment))
56 ;; (let ((result (make-array array-size :element-type '(unsigned-byte 8))))
58 ;; for index from 0 below array-size
60 ;; (setf (aref result index) (read-once)))
63 (defmethod read-value ((type (eql 'u8
)) (self stream
) &key
(array-size 0) (alignment 1) (endian :little
))
64 (declare (ignore endian
))
65 (with-size-and-alignment-read
66 (unsigned-byte 8) alignment array-size
70 (defmethod read-value ((type (eql 's8
)) (self stream
) &key
(array-size 0) (alignment 1) (endian :little
))
71 (declare (ignore endian
))
72 (with-size-and-alignment-read
73 (unsigned-byte 8) alignment array-size
74 (let ((u8 (read-value 'u8 self
)))
79 (defmethod read-value ((type (eql 'u16
)) (self stream
) &key
(array-size 0) (alignment 1) (endian :little
))
80 (with-size-and-alignment-read
81 (unsigned-byte 16) alignment array-size
85 (setf (ldb (byte 8 0) u16
) (read-byte self
))
86 (setf (ldb (byte 8 8) u16
) (read-byte self
))
90 (setf (ldb (byte 8 8) u16
) (read-byte self
))
91 (setf (ldb (byte 8 0) u16
) (read-byte self
))
94 (defmethod read-value ((type (eql 's16
)) (self stream
) &key
(array-size 0) (alignment 1) (endian :little
))
95 (with-size-and-alignment-read
96 (unsigned-byte 16) alignment array-size
97 (let ((u16 (read-value 'u16 self
:endian endian
)))
102 (defmethod read-value ((type (eql 'u32
)) (self stream
) &key
(array-size 0) (alignment 1) (endian :little
))
103 (with-size-and-alignment-read
104 (unsigned-byte 32) alignment array-size
108 (setf (ldb (byte 8 0) u32
) (read-byte self
))
109 (setf (ldb (byte 8 8) u32
) (read-byte self
))
110 (setf (ldb (byte 8 16) u32
) (read-byte self
))
111 (setf (ldb (byte 8 24) u32
) (read-byte self
))
115 (setf (ldb (byte 8 24) u32
) (read-byte self
))
116 (setf (ldb (byte 8 16) u32
) (read-byte self
))
117 (setf (ldb (byte 8 8 ) u32
) (read-byte self
))
118 (setf (ldb (byte 8 0) u32
) (read-byte self
))
121 (defmethod read-value ((type (eql 's32
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
122 (with-size-and-alignment-read
123 (unsigned-byte 32) alignment array-size
124 (let ((u32 (read-value 'u32 self
:endian endian
)))
125 (if (> u32
#X7FFFFFFF
)
129 (defmethod read-value ((type (eql 'u64
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
130 (with-size-and-alignment-read
131 (unsigned-byte 32) alignment array-size
135 (setf (ldb (byte 8 0) u64
) (read-byte self
))
136 (setf (ldb (byte 8 8) u64
) (read-byte self
))
137 (setf (ldb (byte 8 16) u64
) (read-byte self
))
138 (setf (ldb (byte 8 24) u64
) (read-byte self
))
139 (setf (ldb (byte 8 32) u64
) (read-byte self
))
140 (setf (ldb (byte 8 40) u64
) (read-byte self
))
141 (setf (ldb (byte 8 48) u64
) (read-byte self
))
142 (setf (ldb (byte 8 56) u64
) (read-byte self
))
146 (setf (ldb (byte 8 56) u64
) (read-byte self
))
147 (setf (ldb (byte 8 48) u64
) (read-byte self
))
148 (setf (ldb (byte 8 40) u64
) (read-byte self
))
149 (setf (ldb (byte 8 32) u64
) (read-byte self
))
150 (setf (ldb (byte 8 24) u64
) (read-byte self
))
151 (setf (ldb (byte 8 16) u64
) (read-byte self
))
152 (setf (ldb (byte 8 8 ) u64
) (read-byte self
))
153 (setf (ldb (byte 8 0) u64
) (read-byte self
))
156 (defmethod read-value ((type (eql 's64
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
157 (with-size-and-alignment-read
158 (unsigned-byte 32) alignment array-size
159 (let ((u64 (read-value 'u64 self
:endian endian
)))
160 (if (> u64
#X7FFFFFFFFFFFFFFF
)
161 (- u64
#X10000000000000000
)
164 (defmethod read-value ((type (eql 'float32
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
165 (with-size-and-alignment-read
166 (unsigned-byte 32) alignment array-size
167 (let ((u32 (read-value 'u32 self
:endian endian
)))
168 (ieee-floats::decode-float32 u32
))))
170 (defmethod read-value ((type (eql 'float64
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
171 (with-size-and-alignment-read
172 (unsigned-byte 32) alignment array-size
173 (let ((u64 (read-value 'u64 self
:endian endian
)))
174 (ieee-floats::decode-float64 u64
))))
176 (defmethod read-value ((type (eql 'asciiz
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
177 (let ((result (make-array '(0) :element-type
'base-char
:fill-pointer
0 :adjustable t
)))
179 (for byte
= (read-byte self
))
181 (vector-push-extend (code-char byte
) result
))