From 70505351d88920f9894e2115da53dc6c1fdc7f97 Mon Sep 17 00:00:00 2001 From: John Connors Date: Mon, 16 Jun 2008 00:40:52 +0100 Subject: [PATCH] Writing files is compiling. --- lodematron-read.lisp | 12 +- lodematron-write.lisp | 329 ++++++++++++++++++++++++++++++++++---------------- 2 files changed, 236 insertions(+), 105 deletions(-) rewrite lodematron-write.lisp (99%) diff --git a/lodematron-read.lisp b/lodematron-read.lisp index 04e7093..b699298 100644 --- a/lodematron-read.lisp +++ b/lodematron-read.lisp @@ -15,14 +15,16 @@ (defconstant +dword-align+ 3) (defconstant +qword-align+ 7) +;; why am I advancing this byte by byte? (defmethod align-for-read ((self stream) alignment) "Align a file stream for reading at alignment bytes boundary." (when (not (zerop alignment)) (iterate (until (zerop (logand (file-position self) alignment))) - (read-byte self)))) + (file-position self (1+ (file-position self)))))) ;; -- read arrays of binary data --------------------------------------------- +;; -- note the lack of hygine with regards to "endian" (defmacro with-size-and-alignment-read (array-element-type alignment array-size &rest body) "Use the function body to read a value into an array of the given @@ -113,7 +115,7 @@ performed by calling (align-for-read self bytes)." (defmethod read-value ((type (eql 'u64)) (self stream) &key ( array-size 0 ) ( alignment 1 ) (endian :little)) (with-size-and-alignment-read - (unsigned-byte 32) alignment array-size + (unsigned-byte 64) alignment array-size (ccase endian (:little (let ((u64 0)) @@ -160,8 +162,9 @@ performed by calling (align-for-read self bytes)." (defmethod read-value ((type (eql 'asciiz)) (self stream) &key ( array-size 0 ) ( alignment 1 ) (endian :little)) "Read a number of zero terminated ascii strings from the stream" + (declare (ignorable endian)) (with-size-and-alignment-read - t alignment array-size + t 0 alignment array-size (let ((result (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t))) (iterate (for byte = (read-byte self)) @@ -171,6 +174,7 @@ performed by calling (align-for-read self bytes)." (defmethod read-value ((type (eql 'nstring32)) (self stream) &key ( array-size 0 ) ( alignment 1 ) (endian :little)) "Read a string preceeded with a 32 bit length from the stream" + (declare (ignorable endian)) (with-size-and-alignment-read t alignment array-size (let ((result (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t))) @@ -179,4 +183,4 @@ performed by calling (align-for-read self bytes)." (for index from 0 below string-length) (for byte = (read-byte self)) (vector-push-extend (code-char byte) result)) - result)))) \ No newline at end of file + result)))) diff --git a/lodematron-write.lisp b/lodematron-write.lisp dissimilarity index 99% index 2e960eb..127f711 100644 --- a/lodematron-write.lisp +++ b/lodematron-write.lisp @@ -1,101 +1,228 @@ - -;; (in-package :lodematron) - -;; WIP - -;; ;; write aligned binary data ----------------------------------------- - -;; (defgeneric align-for-write (binary-file-data alignment)) - -;; (defmethod align-for-write ((self binary-file-data) alignment) -;; (loop -;; until (zerop (logand (length (buffered-data-of self)) (1- alignment))) -;; do -;; (vector-push-extend 0 (buffered-data-of self)))) - -;; (defgeneric write-value (type binary-file-data value &key) -;; (:documentation "Read a value of the given type from the file.")) - -;; (defmacro with-size-and-alignment-write (element-type alignment array-size value-sym &rest body) -;; (once-only (alignment array-size) -;; (with-gensyms (write-once result) -;; `(labels ((,write-once (,value-sym) -;; ,@body)) -;; (when ,alignment -;; (align-for-write self alignment)) -;; (if ,array-size -;; (let ((,result (make-array ,array-size :element-type ',element-type))) -;; (loop -;; for index from 0 below ,array-size -;; do -;; (,write-once (aref ,result index)))) -;; (,write-once ,value-sym)))))) - -;; ;; (defmethod write-value ((type (eql 'u8)) (self binary-file-data) value &key array-size alignment) -;; ;; (labels ((write-once (value) -;; ;; (vector-push-extend value (buffered-data-of self)))) -;; ;; (when alignment -;; ;; (align-for-write self alignment)) -;; ;; (if (array-size) -;; ;; (loop -;; ;; for index from 0 below array-size -;; ;; do -;; ;; (write-once (aref value index))) -;; ;; (write-once value)))) - -;; (defmethod write-value ((type (eql 'u8)) (self binary-file-data) value &key array-size alignment (endian :little)) -;; (declare (ignore endian)) -;; (with-size-and-alignment-write -;; (unsigned-byte 8) alignment array-size value -;; (vector-push-extend value (buffered-data-of self))))) - - -;; (defmethod write-value ((type (eql 's8)) (self binary-file-data) value &key array-size alignment (endian :little)) -;; (declare (ignore endian)) -;; (with-size-and-alignment-write -;; (unsigned-byte 8) alignment array-size value -;; (vector-push-extend value (buffered-data-of self))))) - -;; (defmethod write-value ((type (eql 'u16)) (self binary-file-data) value &key array-size alignment (endian :little)) -;; (with-size-and-alignment-write -;; (unsigned-byte 16) alignment array-size value - -;; (vector-push-extend (ldb (byte 8 0) value) -;; (buffered-data-of self)) -;; (vector-push-extend (ldb (byte 8 8) value) -;; (buffered-data-of self))))) - -;; (defmethod write-value ((type (eql 's16)) (self binary-file-data) value &key array-size alignment (endian :little)) -;; (with-size-and-alignment-write -;; (unsigned-byte 16) alignment array-size value -;; (vector-push-extend (ldb (byte 8 0) value) -;; (buffered-data-of self)) -;; (vector-push-extend (ldb (byte 8 8) value) -;; (buffered-data-of self)))) - -;; (defmethod write-value ((type (eql 'u32)) (self binary-file-data) value &key array-size alignment (endian :little)) -;; (with-size-and-alignment-write -;; (unsigned-byte 32) alignment array-size value -;; (vector-push-extend (ldb (byte 8 0) value) (buffered-data-of self)) -;; (vector-push-extend (ldb (byte 8 8) value) (buffered-data-of self)) -;; (vector-push-extend (ldb (byte 8 16) value) (buffered-data-of self)) -;; (vector-push-extend (ldb (byte 8 24) value) (buffered-data-of self))))) - -;; (defmethod write-value ((type (eql 's32)) (self binary-file-data) value &key array-size alignment (endian :little)) -;; (with-size-and-alignment-write -;; (unsigned-byte 32) alignment array-size value -;; (vector-push-extend (ldb (byte 8 0) value) (buffered-data-of self)) -;; (vector-push-extend (ldb (byte 8 8) value) (buffered-data-of self)) -;; (vector-push-extend (ldb (byte 8 16) value) (buffered-data-of self)) -;; (vector-push-extend (ldb (byte 8 24) value) (buffered-data-of self))))) - - -;; (defmethod write-value ((type (eql 'asciiz)) (self binary-file-data) string &key array-size alignment (endian :little)) -;; (with-size-and-alignment-write -;; string alignment array-size string -;; (loop -;; for char across string -;; do (vector-push-extend -;; (char-code char) -;; (buffered-data-of self)) -;; (vector-push-extend (char-code #\Nul) (buffered-data-of self))))) + +(in-package :lodematron) + +;; WIP -- an array knows it's own size and element type. Perhaps we could dispatch on these? + +(defgeneric write-value (type stream value &key array-size alignment endian) + (:documentation "Read a value of the given type from the file.")) + +;; write aligned binary data ----------------------------------------- + +(defgeneric align-for-write (stream alignment)) + +(defmethod align-for-write ((self stream) alignment) + "Align a file stream for reading at alignment bytes boundary." + (when (not (zerop alignment)) + (iterate + (until (zerop (logand (file-position self) alignment))) + (file-position self (1+ (file-position self)))))) + + +(defmacro with-size-and-alignment-write (alignment array-size value-sym &rest body) + (once-only (alignment array-size) + (with-gensyms (write-once index) + `(labels ((,write-once (,value-sym) + ,@body)) + (when ,alignment + (align-for-write self alignment)) + (if (not (zerop ,array-size)) + (iterate + (for ,index from 0 below ,array-size) + (,write-once (elt ,value-sym ,index))) + (,write-once ,value-sym)))))) + +(defmethod write-value ((type (eql 'u8)) (self stream) value &key array-size alignment (endian :little)) + (declare (ignore endian)) + (with-size-and-alignment-write + alignment array-size value + (write-byte value self))) + +(defmethod write-value ((type (eql 's8)) (self stream) value &key array-size alignment (endian :little)) + (declare (ignore endian)) + (with-size-and-alignment-write + alignment array-size value + (write-byte value self))) + +(defmethod write-value ((type (eql 'u16)) (self stream) value &key array-size alignment (endian :little)) + (with-size-and-alignment-write + alignment array-size value + (ccase endian + (:little + (let ((u16 value)) + (write-byte (ldb (byte 8 0) u16) self) + (write-byte (ldb (byte 8 8) u16) self))) + (:big + (let ((u16 value)) + (write-byte (ldb (byte 8 8) u16) self) + (write-byte (ldb (byte 8 0) u16) self)))))) + +(defmethod write-value ((type (eql 's16)) (self stream) value &key (array-size 0) (alignment 1) (endian :little)) + (with-size-and-alignment-write + alignment array-size value + (ccase endian + (:little + (let ((s16 value)) + (write-byte (ldb (byte 8 0) s16) self) + (write-byte (ldb (byte 8 8) s16) self))) + (:big + (let ((s16 value)) + (write-byte (ldb (byte 8 8) s16) self) + (write-byte (ldb (byte 8 0) s16) self)))))) + + +(defmethod write-value ((type (eql 'u32)) (self stream) value &key (array-size 0) (alignment 1) (endian :little)) + (with-size-and-alignment-write + alignment array-size value + (ccase endian + (:little + (let ((u32 value)) + (write-byte (ldb (byte 8 0) u32) self) + (write-byte (ldb (byte 8 8) u32) self) + (write-byte (ldb (byte 8 16) u32) self) + (write-byte (ldb (byte 8 24) u32) self))) + (:big + (let ((u32 value)) + (write-byte (ldb (byte 8 24) u32) self) + (write-byte (ldb (byte 8 16) u32) self) + (write-byte (ldb (byte 8 8) u32) self) + (write-byte (ldb (byte 8 0) u32) self)))))) + +(defmethod write-value ((type (eql 's32)) (self stream) value &key (array-size 0) (alignment 1) (endian :little)) + (with-size-and-alignment-write + alignment array-size value + (ccase endian + (:little + (let ((s32 value)) + (write-byte (ldb (byte 8 0) s32) self) + (write-byte (ldb (byte 8 8) s32) self) + (write-byte (ldb (byte 8 16) s32) self) + (write-byte (ldb (byte 8 24) s32) self))) + (:big + (let ((s32 value)) + (write-byte (ldb (byte 8 24) s32) self) + (write-byte (ldb (byte 8 16) s32) self) + (write-byte (ldb (byte 8 8) s32) self) + (write-byte (ldb (byte 8 0) s32) self)))))) + +(defmethod write-value ((type (eql 'float32)) value (self stream) &key ( array-size 0 ) ( alignment 1 ) (endian :little)) + (with-size-and-alignment-write + alignment array-size value + (let ((u32 (ieee-floats::encode-float32 value))) + (ccase endian + (:little + (write-byte (ldb (byte 8 0) u32) self) + (write-byte (ldb (byte 8 8) u32) self) + (write-byte (ldb (byte 8 16) u32) self) + (write-byte (ldb (byte 8 24) u32) self)) + (:big + (write-byte (ldb (byte 8 24) u32) self) + (write-byte (ldb (byte 8 16) u32) self) + (write-byte (ldb (byte 8 8) u32) self) + (write-byte (ldb (byte 8 0) u32) self)))))) + +(defmethod write-value ((type (eql 'u64)) (self stream) value &key (array-size 0) (alignment 1) (endian :little)) + (with-size-and-alignment-write + alignment array-size value + (ccase endian + (:little + (let ((u64 value)) + (write-byte (ldb (byte 8 0) u64) self) + (write-byte (ldb (byte 8 8) u64) self) + (write-byte (ldb (byte 8 16) u64) self) + (write-byte (ldb (byte 8 24) u64) self) + (write-byte (ldb (byte 8 32) u64) self) + (write-byte (ldb (byte 8 40) u64) self) + (write-byte (ldb (byte 8 48) u64) self) + (write-byte (ldb (byte 8 56) u64) self))) + (:big + (let ((u64 value)) + (write-byte (ldb (byte 8 56) u64) self) + (write-byte (ldb (byte 8 48) u64) self) + (write-byte (ldb (byte 8 40) u64) self) + (write-byte (ldb (byte 8 32) u64) self) + (write-byte (ldb (byte 8 24) u64) self) + (write-byte (ldb (byte 8 16) u64) self) + (write-byte (ldb (byte 8 8) u64) self) + (write-byte (ldb (byte 8 0) u64) self)))))) + +(defmethod write-value ((type (eql 's64)) (self stream) value &key (array-size 0) (alignment 1) (endian :little)) + (with-size-and-alignment-write + alignment array-size value + (ccase endian + (:little + (let ((s64 value)) + (write-byte (ldb (byte 8 0) s64) self) + (write-byte (ldb (byte 8 8) s64) self) + (write-byte (ldb (byte 8 16) s64) self) + (write-byte (ldb (byte 8 24) s64) self) + (write-byte (ldb (byte 8 32) s64) self) + (write-byte (ldb (byte 8 40) s64) self) + (write-byte (ldb (byte 8 48) s64) self) + (write-byte (ldb (byte 8 56) s64) self))) + (:big + (let ((s64 value)) + (write-byte (ldb (byte 8 56) s64) self) + (write-byte (ldb (byte 8 48) s64) self) + (write-byte (ldb (byte 8 40) s64) self) + (write-byte (ldb (byte 8 32) s64) self) + (write-byte (ldb (byte 8 24) s64) self) + (write-byte (ldb (byte 8 16) s64) self) + (write-byte (ldb (byte 8 8) s64) self) + (write-byte (ldb (byte 8 0) s64) self)))))) + +(defmethod write-value ((type (eql 'float64)) (self stream) value &key ( array-size 0 ) ( alignment 1 ) (endian :little)) + (with-size-and-alignment-write + alignment array-size value + (let ((u64 (ieee-floats::encode-float64 value))) + (ccase endian + (:little + (write-byte (ldb (byte 8 0) u64) self) + (write-byte (ldb (byte 8 8) u64) self) + (write-byte (ldb (byte 8 16) u64) self) + (write-byte (ldb (byte 8 24) u64) self) + (write-byte (ldb (byte 8 32) u64) self) + (write-byte (ldb (byte 8 40) u64) self) + (write-byte (ldb (byte 8 48) u64) self) + (write-byte (ldb (byte 8 56) u64) self)) + (:big + (write-byte (ldb (byte 8 56) u64) self) + (write-byte (ldb (byte 8 48) u64) self) + (write-byte (ldb (byte 8 40) u64) self) + (write-byte (ldb (byte 8 32) u64) self) + (write-byte (ldb (byte 8 24) u64) self) + (write-byte (ldb (byte 8 16) u64) self) + (write-byte (ldb (byte 8 8) u64) self) + (write-byte (ldb (byte 8 0) u64) self)))))) + + +(defmethod write-value ((type (eql 'asciiz)) (self stream) string &key (array-size 0) (alignment 1) endian) + (declare (ignore endian)) + (with-size-and-alignment-write + alignment array-size string + (progn + (iterate + (for char in-string string) + (write-char char self)) + (write-char #\Nul self)))) + +(defmethod write-value ((type (eql 'nstring32)) (self stream) string &key (array-size 0) (alignment 1) endian) + (with-size-and-alignment-write + alignment array-size string + (progn + (ccase endian + (:little + (let ((u32 (length string))) + (write-byte (ldb (byte 8 0) u32) self) + (write-byte (ldb (byte 8 8) u32) self) + (write-byte (ldb (byte 8 16) u32) self) + (write-byte (ldb (byte 8 24) u32) self))) + (:big + (let ((u32 (length string))) + (write-byte (ldb (byte 8 24) u32) self) + (write-byte (ldb (byte 8 16) u32) self) + (write-byte (ldb (byte 8 8) u32) self) + (write-byte (ldb (byte 8 0) u32) self)))) + (iterate + (for char in-string string) + (write-char char self)) + (write-char #\Nul self)))) \ No newline at end of file -- 2.11.4.GIT