More work on lwo loading. Useful bit - destructuring macro.
[lodematron.git] / lwo-read.lisp
blobdbbb8223fc6f352b655cc2f0d389c74669b117ad
3 (in-package :cl-lwo)
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))
21 (iterate
22 (until (zerop (logand (file-position self) alignment)))
23 (read-byte self))))
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 ()
35 ,@body))
36 (when ,alignment
37 (align-for-read self alignment))
38 (if (not (zerop ,array-size))
39 (let ((,result (make-array ,array-size :element-type ',array-element-type)))
40 (loop
41 for index from 0 below ,array-size
43 (setf (aref ,result index) (,read-once)))
44 ,result)
45 (,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))
51 ;; result))))
52 ;; (when alignment
53 ;; (align-for-read self alignment))
54 ;; (if array-size
55 ;; (read-once)
56 ;; (let ((result (make-array array-size :element-type '(unsigned-byte 8))))
57 ;; (loop
58 ;; for index from 0 below array-size
59 ;; do
60 ;; (setf (aref result index) (read-once)))
61 ;; result)))
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
67 (read-byte self)))
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)))
75 (if (> u8 #X7F)
76 (- u8 #X100)
77 u8))))
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
82 (ccase endian
83 (:little
84 (let ((u16 0))
85 (setf (ldb (byte 8 0) u16) (read-byte self))
86 (setf (ldb (byte 8 8) u16) (read-byte self))
87 u16))
88 (:big
89 (let ((u16 0))
90 (setf (ldb (byte 8 8) u16) (read-byte self))
91 (setf (ldb (byte 8 0) u16) (read-byte self))
92 u16)))))
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)))
98 (if (> u16 #X7FFF)
99 (- u16 #X10000)
100 u16))))
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
105 (ccase endian
106 (:little
107 (let ((u32 0))
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))
112 u32))
113 (:big
114 (let ((u32 0))
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))
119 u32)))))
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)
126 (- u32 #X100000000)
127 u32))))
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
132 (ccase endian
133 (:little
134 (let ((u64 0))
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))
143 u64))
144 (:big
145 (let ((u64 0))
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))
154 u64)))))
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)
162 u64))))
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)))
178 (iterate
179 (for byte = (read-byte self))
180 (until (zerop byte))
181 (vector-push-extend (code-char byte) result))
182 result))