lodematron-write.lisp

   1
   2 (in-package :lodematron)
   3
   4 ;; WIP -- an array knows it's own size and element type. Perhaps we could dispatch on these?
   5
   6 (defgeneric write-value (type stream value &key array-size alignment endian)
   7   (:documentation "Read a value of the given type from the file."))
   8
   9 ;; write aligned binary data  -----------------------------------------
  10
  11 (defgeneric align-for-write (stream alignment))
  12
  13 (defmethod align-for-write ((self stream) alignment)
  14   "Align a file stream for reading at alignment bytes boundary."
  15   (when (not (zerop alignment))
  16     (iterate
  17      (until (zerop (logand (file-position self) alignment)))
  18       (file-position self (1+ (file-position self))))))
  19
  20
  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)
  25                           ,@body))
  26                  (when ,alignment
  27                    (align-for-write self alignment))
  28                  (if (not (zerop ,array-size))
  29                      (iterate
  30                         (for ,index from 0 below ,array-size)
  31                         (,write-once (elt ,value-sym ,index)))
  32                      (,write-once ,value-sym))))))
  33
  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)))
  39
  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)))
  45
  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
  49         (ccase endian
  50                (:little
  51                 (let ((u16 value))
  52                   (write-byte (ldb (byte 8 0) u16) self)
  53                   (write-byte (ldb (byte 8 8) u16) self)))
  54                (:big
  55                 (let ((u16 value))
  56                   (write-byte (ldb (byte 8 8) u16) self)
  57                   (write-byte (ldb (byte 8 0) u16) self))))))
  58
  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
  62         (ccase endian
  63                (:little
  64                 (let ((s16 value))
  65                   (write-byte (ldb (byte 8 0) s16) self)
  66                   (write-byte (ldb (byte 8 8) s16) self)))
  67                (:big
  68                 (let ((s16 value))
  69                   (write-byte (ldb (byte 8 8) s16) self)
  70                   (write-byte (ldb (byte 8 0) s16) self))))))
  71
  72
  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
  76         (ccase endian
  77           (:little
  78            (let ((u32 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)))
  83            (:big
  84             (let ((u32 value))
  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))))))
  89
  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
  93         (ccase endian
  94                (:little
  95                 (let ((s32 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)))
 100                (:big
 101                 (let ((s32 value))
 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))))))
 106
 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)))
 111         (ccase endian
 112           (:little
 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))
 117           (:big
 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))))))
 122
 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
 126         (ccase endian
 127           (:little
 128            (let ((u64 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)))
 137            (:big
 138             (let ((u64 value))
 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))))))
 147
 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
 151         (ccase endian
 152           (:little
 153            (let ((s64 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)))
 162            (:big
 163             (let ((s64 value))
 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))))))
 172
 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)))
 177         (ccase endian
 178           (:little
 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))
 187            (:big
 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))))))
 196
 197
 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
 202       (progn
 203         (iterate
 204          (for char in-string string)
 205          (write-char char self))
 206         (write-char #\Nul self))))
 207
 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
 211       (progn
 212         (ccase endian
 213                (:little
 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)))
 219                 (:big
 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))))
 225         (iterate
 226          (for char in-string string)
 227          (write-char char self))
 228         (write-char #\Nul self))))