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
)))
101 (defmethod read-value ((type (eql 'u32
)) (self stream
) &key
(array-size 0) (alignment 1) (endian :little
))
102 (with-size-and-alignment-read
103 (unsigned-byte 32) alignment array-size
107 (setf (ldb (byte 8 0) u32
) (read-byte self
))
108 (setf (ldb (byte 8 8) u32
) (read-byte self
))
109 (setf (ldb (byte 8 16) u32
) (read-byte self
))
110 (setf (ldb (byte 8 24) u32
) (read-byte self
))
114 (setf (ldb (byte 8 24) u32
) (read-byte self
))
115 (setf (ldb (byte 8 16) u32
) (read-byte self
))
116 (setf (ldb (byte 8 8 ) u32
) (read-byte self
))
117 (setf (ldb (byte 8 0) u32
) (read-byte self
))
120 (defmethod read-value ((type (eql 's32
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
121 (with-size-and-alignment-read
122 (unsigned-byte 32) alignment array-size
123 (let ((u32 (read-value 'u32 self
:endian endian
)))
124 (if (> u32
#X7FFFFFFF
)
128 (defmethod read-value ((type (eql 'u64
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
129 (with-size-and-alignment-read
130 (unsigned-byte 32) alignment array-size
134 (setf (ldb (byte 8 0) u64
) (read-byte self
))
135 (setf (ldb (byte 8 8) u64
) (read-byte self
))
136 (setf (ldb (byte 8 16) u64
) (read-byte self
))
137 (setf (ldb (byte 8 24) u64
) (read-byte self
))
138 (setf (ldb (byte 8 32) u64
) (read-byte self
))
139 (setf (ldb (byte 8 40) u64
) (read-byte self
))
140 (setf (ldb (byte 8 48) u64
) (read-byte self
))
141 (setf (ldb (byte 8 56) u64
) (read-byte self
))
145 (setf (ldb (byte 8 56) u64
) (read-byte self
))
146 (setf (ldb (byte 8 48) u64
) (read-byte self
))
147 (setf (ldb (byte 8 40) u64
) (read-byte self
))
148 (setf (ldb (byte 8 32) u64
) (read-byte self
))
149 (setf (ldb (byte 8 24) u64
) (read-byte self
))
150 (setf (ldb (byte 8 16) u64
) (read-byte self
))
151 (setf (ldb (byte 8 8 ) u64
) (read-byte self
))
152 (setf (ldb (byte 8 0) u64
) (read-byte self
))
155 (defmethod read-value ((type (eql 's64
)) (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 (if (> u64
#X7FFFFFFFFFFFFFFF
)
160 (- u64
#X10000000000000000
)
163 (defmethod read-value ((type (eql 'float32
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
164 (with-size-and-alignment-read
165 (unsigned-byte 32) alignment array-size
166 (let ((u32 (read-value 'u32 self
:endian endian
)))
167 (ieee-floats::decode-float32 u32
))))
169 (defmethod read-value ((type (eql 'float64
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
170 (with-size-and-alignment-read
171 (unsigned-byte 32) alignment array-size
172 (let ((u64 (read-value 'u64 self
:endian endian
)))
173 (ieee-floats::decode-float64 u64
))))
175 (defmethod read-value ((type (eql 'asciiz
)) (self stream
) &key
( array-size
0 ) ( alignment
1 ) (endian :little
))
176 (with-size-and-alignment-read
177 (simple-array character
*) alignment array-size
178 (with-output-to-string (s)
179 (loop for char
= (code-char (read-value 'u8 self
:endian endian
))
180 until
(char= char
#\Nul
) do
(write-char char s
)))))