2 (in-package :lodematron
)
4 ;; WIP -- an array knows it's own size and element type. Perhaps we could dispatch on these?
6 (defgeneric write-value
(type stream value
&key array-size alignment endian
)
7 (:documentation
"Read a value of the given type from the file."))
9 ;; write aligned binary data -----------------------------------------
11 (defgeneric align-for-write
(stream alignment
))
13 (defmethod align-for-write ((self stream
) alignment
)
14 "Align a file stream for reading at alignment bytes boundary."
15 (when (not (zerop alignment
))
17 (until (zerop (logand (file-position self
) alignment
)))
18 (file-position self
(1+ (file-position self
))))))
21 (defmacro with-size-and-alignment-write
(alignment array-size value-sym
&rest body
)
22 (once-only (alignment array-size
)
23 (with-gensyms (write-once index
)
24 `(labels ((,write-once
(,value-sym
)
27 (align-for-write self alignment
))
28 (if (not (zerop ,array-size
))
30 (for ,index from
0 below
,array-size
)
31 (,write-once
(elt ,value-sym
,index
)))
32 (,write-once
,value-sym
))))))
34 (defmethod write-value ((type (eql :u8
)) (self stream
) value
&key array-size
(alignment 0) (endian :little
))
35 (declare (ignore endian
))
36 (with-size-and-alignment-write
37 alignment array-size value
38 (write-byte value self
)))
40 (defmethod write-value ((type (eql :s8
)) (self stream
) value
&key array-size
(alignment 0) (endian :little
))
41 (declare (ignore endian
))
42 (with-size-and-alignment-write
43 alignment array-size value
44 (write-byte value self
)))
46 (defmethod write-value ((type (eql :u16
)) (self stream
) value
&key array-size alignment
(endian :little
))
47 (with-size-and-alignment-write
48 alignment array-size value
52 (write-byte (ldb (byte 8 0) u16
) self
)
53 (write-byte (ldb (byte 8 8) u16
) self
)))
56 (write-byte (ldb (byte 8 8) u16
) self
)
57 (write-byte (ldb (byte 8 0) u16
) self
))))))
59 (defmethod write-value ((type (eql :s16
)) (self stream
) value
&key
(array-size 0) (alignment 0) (endian :little
))
60 (with-size-and-alignment-write
61 alignment array-size value
65 (write-byte (ldb (byte 8 0) s16
) self
)
66 (write-byte (ldb (byte 8 8) s16
) self
)))
69 (write-byte (ldb (byte 8 8) s16
) self
)
70 (write-byte (ldb (byte 8 0) s16
) self
))))))
73 (defmethod write-value ((type (eql :u32
)) (self stream
) value
&key
(array-size 0) (alignment 0) (endian :little
))
74 (with-size-and-alignment-write
75 alignment array-size value
79 (write-byte (ldb (byte 8 0) u32
) self
)
80 (write-byte (ldb (byte 8 8) u32
) self
)
81 (write-byte (ldb (byte 8 16) u32
) self
)
82 (write-byte (ldb (byte 8 24) u32
) self
)))
85 (write-byte (ldb (byte 8 24) u32
) self
)
86 (write-byte (ldb (byte 8 16) u32
) self
)
87 (write-byte (ldb (byte 8 8) u32
) self
)
88 (write-byte (ldb (byte 8 0) u32
) self
))))))
90 (defmethod write-value ((type (eql :s32
)) (self stream
) value
&key
(array-size 0) (alignment 0) (endian :little
))
91 (with-size-and-alignment-write
92 alignment array-size value
96 (write-byte (ldb (byte 8 0) s32
) self
)
97 (write-byte (ldb (byte 8 8) s32
) self
)
98 (write-byte (ldb (byte 8 16) s32
) self
)
99 (write-byte (ldb (byte 8 24) s32
) self
)))
102 (write-byte (ldb (byte 8 24) s32
) self
)
103 (write-byte (ldb (byte 8 16) s32
) self
)
104 (write-byte (ldb (byte 8 8) s32
) self
)
105 (write-byte (ldb (byte 8 0) s32
) self
))))))
107 (defmethod write-value ((type (eql :float32
)) value
(self stream
) &key
( array-size
0 ) ( alignment
0 ) (endian :little
))
108 (with-size-and-alignment-write
109 alignment array-size value
110 (let ((u32 (ieee-floats::encode-float32 value
)))
113 (write-byte (ldb (byte 8 0) u32
) self
)
114 (write-byte (ldb (byte 8 8) u32
) self
)
115 (write-byte (ldb (byte 8 16) u32
) self
)
116 (write-byte (ldb (byte 8 24) u32
) self
))
118 (write-byte (ldb (byte 8 24) u32
) self
)
119 (write-byte (ldb (byte 8 16) u32
) self
)
120 (write-byte (ldb (byte 8 8) u32
) self
)
121 (write-byte (ldb (byte 8 0) u32
) self
))))))
123 (defmethod write-value ((type (eql :u64
)) (self stream
) value
&key
(array-size 0) (alignment 0) (endian :little
))
124 (with-size-and-alignment-write
125 alignment array-size value
129 (write-byte (ldb (byte 8 0) u64
) self
)
130 (write-byte (ldb (byte 8 8) u64
) self
)
131 (write-byte (ldb (byte 8 16) u64
) self
)
132 (write-byte (ldb (byte 8 24) u64
) self
)
133 (write-byte (ldb (byte 8 32) u64
) self
)
134 (write-byte (ldb (byte 8 40) u64
) self
)
135 (write-byte (ldb (byte 8 48) u64
) self
)
136 (write-byte (ldb (byte 8 56) u64
) self
)))
139 (write-byte (ldb (byte 8 56) u64
) self
)
140 (write-byte (ldb (byte 8 48) u64
) self
)
141 (write-byte (ldb (byte 8 40) u64
) self
)
142 (write-byte (ldb (byte 8 32) u64
) self
)
143 (write-byte (ldb (byte 8 24) u64
) self
)
144 (write-byte (ldb (byte 8 16) u64
) self
)
145 (write-byte (ldb (byte 8 8) u64
) self
)
146 (write-byte (ldb (byte 8 0) u64
) self
))))))
148 (defmethod write-value ((type (eql :s64
)) (self stream
) value
&key
(array-size 0) (alignment 0) (endian :little
))
149 (with-size-and-alignment-write
150 alignment array-size value
154 (write-byte (ldb (byte 8 0) s64
) self
)
155 (write-byte (ldb (byte 8 8) s64
) self
)
156 (write-byte (ldb (byte 8 16) s64
) self
)
157 (write-byte (ldb (byte 8 24) s64
) self
)
158 (write-byte (ldb (byte 8 32) s64
) self
)
159 (write-byte (ldb (byte 8 40) s64
) self
)
160 (write-byte (ldb (byte 8 48) s64
) self
)
161 (write-byte (ldb (byte 8 56) s64
) self
)))
164 (write-byte (ldb (byte 8 56) s64
) self
)
165 (write-byte (ldb (byte 8 48) s64
) self
)
166 (write-byte (ldb (byte 8 40) s64
) self
)
167 (write-byte (ldb (byte 8 32) s64
) self
)
168 (write-byte (ldb (byte 8 24) s64
) self
)
169 (write-byte (ldb (byte 8 16) s64
) self
)
170 (write-byte (ldb (byte 8 8) s64
) self
)
171 (write-byte (ldb (byte 8 0) s64
) self
))))))
173 (defmethod write-value ((type (eql :float64
)) (self stream
) value
&key
( array-size
0 ) ( alignment
0 ) (endian :little
))
174 (with-size-and-alignment-write
175 alignment array-size value
176 (let ((u64 (ieee-floats::encode-float64 value
)))
179 (write-byte (ldb (byte 8 0) u64
) self
)
180 (write-byte (ldb (byte 8 8) u64
) self
)
181 (write-byte (ldb (byte 8 16) u64
) self
)
182 (write-byte (ldb (byte 8 24) u64
) self
)
183 (write-byte (ldb (byte 8 32) u64
) self
)
184 (write-byte (ldb (byte 8 40) u64
) self
)
185 (write-byte (ldb (byte 8 48) u64
) self
)
186 (write-byte (ldb (byte 8 56) u64
) self
))
188 (write-byte (ldb (byte 8 56) u64
) self
)
189 (write-byte (ldb (byte 8 48) u64
) self
)
190 (write-byte (ldb (byte 8 40) u64
) self
)
191 (write-byte (ldb (byte 8 32) u64
) self
)
192 (write-byte (ldb (byte 8 24) u64
) self
)
193 (write-byte (ldb (byte 8 16) u64
) self
)
194 (write-byte (ldb (byte 8 8) u64
) self
)
195 (write-byte (ldb (byte 8 0) u64
) self
))))))
198 (defmethod write-value ((type (eql :asciiz
)) (self stream
) string
&key
(array-size 0) (alignment 0) endian
)
199 (declare (ignore endian
))
200 (with-size-and-alignment-write
201 alignment array-size string
204 (for char in-string string
)
205 (write-char char self
))
206 (write-char #\Nul self
))))
208 (defmethod write-value ((type (eql :nstring32
)) (self stream
) string
&key
(array-size 0) (alignment 0) endian
)
209 (with-size-and-alignment-write
210 alignment array-size string
214 (let ((u32 (length string
)))
215 (write-byte (ldb (byte 8 0) u32
) self
)
216 (write-byte (ldb (byte 8 8) u32
) self
)
217 (write-byte (ldb (byte 8 16) u32
) self
)
218 (write-byte (ldb (byte 8 24) u32
) self
)))
220 (let ((u32 (length string
)))
221 (write-byte (ldb (byte 8 24) u32
) self
)
222 (write-byte (ldb (byte 8 16) u32
) self
)
223 (write-byte (ldb (byte 8 8) u32
) self
)
224 (write-byte (ldb (byte 8 0) u32
) self
))))
226 (for char in-string string
)
227 (write-char char self
))
228 (write-char #\Nul self
))))