lwo-read.lisp

   1
   2
   3 (in-package :cl-lwo)
   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 ;; (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)))
  62
  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)))
  68
  69
  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))))
  78
  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)))))
  93
  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
 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
 104       (ccase endian
 105         (:little
 106          (let ((u32 0))
 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))
 111            u32))
 112         (:big
 113          (let ((u32 0))
 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))
 118            u32)))))
 119
 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)
 125             (- u32 #X100000000)
 126             u32))))
 127
 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
 131       (ccase endian
 132         (:little
 133          (let ((u64 0))
 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))
 142           u64))
 143         (:big
 144         (let ((u64 0))
 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))
 153           u64)))))
 154
 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)
 161             u64))))
 162
 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))))
 168
 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))))
 174
 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)))))