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 ;; why am I advancing this byte by byte?
  19 (defmethod align-for-read ((self stream) alignment)
  20   "Align a file stream for reading at alignment bytes boundary."
  21   (when (not (zerop alignment))
  22     (iterate
  23      (until (zerop (logand (file-position self) alignment)))
  24      (file-position self (1+ (file-position self))))))
  25
  26 ;; -- read arrays of binary data ---------------------------------------------
  27 ;; -- note the lack of hygine with regards to "endian"
  28
  29 (defmacro with-size-and-alignment-read (array-element-type alignment array-size &rest body)
  30   "Use the function body to read a value into an array of the given
  31 size, begnning the read at the given alignment. Assumes the read will
  32 be from a variable bound to a symbol called self, and alingment is
  33 performed by calling (align-for-read self bytes)."
  34   (once-only (alignment array-size)
  35              (with-gensyms (read-once result)
  36                `(labels ((,read-once ()
  37                           ,@body))
  38                  (when ,alignment
  39                    (align-for-read self alignment))
  40                  (if (not (zerop ,array-size))
  41                      (let ((,result (make-array ,array-size :element-type ',array-element-type)))
  42                        (loop
  43                           for index from 0 below ,array-size
  44                           do
  45                             (setf (aref ,result index) (,read-once)))
  46                        ,result)
  47                      (,read-once))))))
  48
  49
  50 (defmethod read-value ((type (eql 'u8)) (self stream) &key (array-size 0) (alignment 1) (endian :little))
  51   (declare (ignore endian))
  52   (with-size-and-alignment-read
  53       (unsigned-byte 8) alignment array-size
  54       (read-byte self)))
  55
  56
  57 (defmethod read-value ((type (eql 's8)) (self stream) &key (array-size 0) (alignment 1) (endian :little))
  58   (declare (ignore endian))
  59   (with-size-and-alignment-read
  60       (unsigned-byte 8) alignment array-size
  61       (let ((u8 (read-value 'u8 self)))
  62         (if (> u8 #X7F)
  63             (- u8 #X100)
  64             u8))))
  65
  66 (defmethod read-value ((type (eql 'u16)) (self stream) &key (array-size 0) (alignment 1) (endian :little))
  67   (with-size-and-alignment-read
  68       (unsigned-byte 16) alignment array-size
  69       (ccase endian
  70         (:little
  71          (let ((u16 0))
  72            (setf (ldb (byte 8 0) u16) (read-byte self))
  73            (setf (ldb (byte 8 8) u16) (read-byte self))
  74           u16))
  75         (:big
  76          (let ((u16 0))
  77            (setf (ldb (byte 8 8) u16) (read-byte self))
  78            (setf (ldb (byte 8 0) u16) (read-byte self))
  79            u16)))))
  80
  81 (defmethod read-value ((type (eql 's16)) (self stream) &key (array-size 0) (alignment 1) (endian :little))
  82   (with-size-and-alignment-read
  83       (unsigned-byte 16) alignment array-size
  84       (let ((u16 (read-value 'u16 self :endian endian)))
  85         (if (> u16 #X7FFF)
  86             (- u16 #X10000)
  87             u16))))
  88
  89 (defmethod read-value ((type (eql 'u32)) (self stream) &key (array-size 0) (alignment 1) (endian :little))
  90   (with-size-and-alignment-read
  91       (unsigned-byte 32) alignment array-size
  92       (ccase endian
  93         (:little
  94          (let ((u32 0))
  95            (setf (ldb (byte 8 0) u32) (read-byte self))
  96            (setf (ldb (byte 8 8) u32) (read-byte self))
  97            (setf (ldb (byte 8 16) u32) (read-byte self))
  98            (setf (ldb (byte 8 24) u32) (read-byte self))
  99            u32))
 100         (:big
 101          (let ((u32 0))
 102            (setf (ldb (byte 8 24) u32) (read-byte self))
 103            (setf (ldb (byte 8 16) u32) (read-byte self))
 104            (setf (ldb (byte 8 8 ) u32) (read-byte self))
 105            (setf (ldb (byte 8 0) u32) (read-byte self))
 106            u32)))))
 107
 108 (defmethod read-value ((type (eql 's32)) (self stream) &key ( array-size 0 ) ( alignment 1 ) (endian :little))
 109   (with-size-and-alignment-read
 110       (unsigned-byte 32) alignment array-size
 111        (let ((u32 (read-value 'u32 self :endian endian)))
 112         (if (> u32 #X7FFFFFFF)
 113             (- u32 #X100000000)
 114             u32))))
 115
 116 (defmethod read-value ((type (eql 'u64)) (self stream) &key ( array-size 0 ) ( alignment 1 ) (endian :little))
 117   (with-size-and-alignment-read
 118       (unsigned-byte 64) alignment array-size
 119       (ccase endian
 120         (:little
 121          (let ((u64 0))
 122           (setf (ldb (byte 8 0) u64) (read-byte self))
 123           (setf (ldb (byte 8 8) u64) (read-byte self))
 124           (setf (ldb (byte 8 16) u64) (read-byte self))
 125           (setf (ldb (byte 8 24) u64) (read-byte self))
 126           (setf (ldb (byte 8 32) u64) (read-byte self))
 127           (setf (ldb (byte 8 40) u64) (read-byte self))
 128           (setf (ldb (byte 8 48) u64) (read-byte self))
 129           (setf (ldb (byte 8 56) u64) (read-byte self))
 130           u64))
 131         (:big
 132         (let ((u64 0))
 133           (setf (ldb (byte 8 56) u64) (read-byte self))
 134           (setf (ldb (byte 8 48) u64) (read-byte self))
 135           (setf (ldb (byte 8 40) u64) (read-byte self))
 136           (setf (ldb (byte 8 32) u64) (read-byte self))
 137           (setf (ldb (byte 8 24) u64) (read-byte self))
 138           (setf (ldb (byte 8 16) u64) (read-byte self))
 139           (setf (ldb (byte 8 8 ) u64) (read-byte self))
 140           (setf (ldb (byte 8 0) u64) (read-byte self))
 141           u64)))))
 142
 143 (defmethod read-value ((type (eql 's64)) (self stream) &key ( array-size 0 ) ( alignment 1 ) (endian :little))
 144   (with-size-and-alignment-read
 145       (unsigned-byte 32) alignment array-size
 146       (let ((u64 (read-value 'u64 self :endian endian)))
 147         (if (> u64 #X7FFFFFFFFFFFFFFF)
 148             (- u64 #X10000000000000000)
 149             u64))))
 150
 151 (defmethod read-value ((type (eql 'float32))  (self stream) &key ( array-size 0 ) ( alignment 1 ) (endian :little))
 152   (with-size-and-alignment-read
 153       (unsigned-byte 32) alignment array-size
 154       (let ((u32 (read-value 'u32 self :endian endian)))
 155         (ieee-floats::decode-float32 u32))))
 156
 157 (defmethod read-value ((type (eql 'float64))  (self stream) &key ( array-size 0 ) ( alignment 1 ) (endian :little))
 158   (with-size-and-alignment-read
 159       (unsigned-byte 32) alignment array-size
 160       (let ((u64 (read-value 'u64 self :endian endian)))
 161         (ieee-floats::decode-float64 u64))))
 162
 163 (defmethod read-value ((type (eql 'asciiz)) (self stream) &key ( array-size 0 ) ( alignment 1 ) (endian :little))
 164   "Read a number of zero terminated ascii strings from the stream"
 165   (declare (ignorable endian))
 166   (with-size-and-alignment-read
 167       t 0 alignment array-size
 168       (let ((result (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t)))
 169         (iterate
 170           (for byte = (read-byte self))
 171           (until (zerop byte))
 172           (vector-push-extend (code-char byte) result)) ;; to do - a byte isn't a char, use octets-to-string?
 173         result)))
 174
 175 (defmethod read-value ((type (eql 'nstring32))  (self stream) &key ( array-size 0 ) ( alignment 1 ) (endian :little))
 176   "Read a string preceeded with a 32 bit length from the stream"
 177   (declare (ignorable endian))
 178   (with-size-and-alignment-read
 179       t alignment array-size
 180       (let ((result (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t)))
 181         (let ((string-length (read-value 'u32 self :array-size 0 :alignment alignment :endian endian)))
 182           (iterate
 183             (for index from 0 below string-length)
 184             (for byte = (read-byte self))
 185             (vector-push-extend (code-char byte) result))
 186           result))))