lodematron-read.lisp

   1
   2
   3 (in-package :lodematron)
   4
   5  ;; -- reading atomic binary values  -----------------------------------------
   6
   7 (defgeneric read-value (type stream &key array-size alignment endian)
   8   (:documentation "Read a value of the given type from the file."))
   9
  10 ;; -- read aligned binary data  ----------------------------------------------
  11
  12 (defgeneric align-for-read (stream alignment))
  13
  14 (defconstant +word-align+  1)
  15 (defconstant +dword-align+ 3)
  16 (defconstant +qword-align+ 7)
  17
  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))))
  24
  25 ;; -- read arrays of binary data ---------------------------------------------
  26
  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
  42                           do
  43                             (setf (aref ,result index) (,read-once)))
  44                        ,result)
  45                      (,read-once))))))
  46
  47
  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
  52       (read-byte self)))
  53
  54
  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)))
  60         (if (> u8 #X7F)
  61             (- u8 #X100)
  62             u8))))
  63
  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
  67       (ccase endian
  68         (:little
  69          (let ((u16 0))
  70            (setf (ldb (byte 8 0) u16) (read-byte self))
  71            (setf (ldb (byte 8 8) u16) (read-byte self))
  72           u16))
  73         (:big
  74          (let ((u16 0))
  75            (setf (ldb (byte 8 8) u16) (read-byte self))
  76            (setf (ldb (byte 8 0) u16) (read-byte self))
  77            u16)))))
  78
  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)))
  83         (if (> u16 #X7FFF)
  84             (- u16 #X10000)
  85             u16))))
  86
  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
  90       (ccase endian
  91         (:little
  92          (let ((u32 0))
  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))
  97            u32))
  98         (:big
  99          (let ((u32 0))
 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))
 104            u32)))))
 105
 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)
 111             (- u32 #X100000000)
 112             u32))))
 113
 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
 117       (ccase endian
 118         (:little
 119          (let ((u64 0))
 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))
 128           u64))
 129         (:big
 130         (let ((u64 0))
 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))
 139           u64)))))
 140
 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)
 147             u64))))
 148
 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))))
 154
 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))))
 160
 161 (defmethod read-value ((type (eql 'asciiz)) (self stream) &key ( array-size 0 ) ( alignment 1 ) (endian :little))
 162   "Read a number of zero terminated ascii strings from the stream"
 163   (with-size-and-alignment-read
 164       t alignment array-size
 165       (let ((result (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t)))
 166         (iterate
 167           (for byte = (read-byte self))
 168           (until (zerop byte))
 169           (vector-push-extend (code-char byte) result)) ;; to do - a byte isn't a char, use octets-to-string?
 170         result)))
 171
 172 (defmethod read-value ((type (eql 'nstring32))  (self stream) &key ( array-size 0 ) ( alignment 1 ) (endian :little))
 173   "Read a string preceeded with a 32 bit length from the stream"
 174   (with-size-and-alignment-read
 175       t alignment array-size
 176       (let ((result (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t)))
 177         (let ((string-length (read-value 'u32 self :array-size 0 :alignment alignment :endian endian)))
 178           (iterate
 179             (for index from 0 below string-length)
 180             (for byte = (read-byte self))
 181             (vector-push-extend (code-char byte) result))
 182           result))))