lodematron-rw.lisp

   1 ;;;; Silly emacs, this is -*- Lisp -*-
   2
   3 (in-package :lodematron)
   4
   5 ;; define-binary-class ------------------------------------------------------
   6 ;; Heavily influenced by Practical Common Lisp by Peter Seibel
   7
   8 (defun as-keyword (sym)
   9   (intern (string sym) :keyword))
  10
  11 (defun as-accessor (sym)
  12   (intern (concatenate 'string (string sym) "-OF")))
  13
  14 (defun slot->defclass-slot (spec)
  15   "Map a define-binary-class slot spec to a clos slot spec"
  16   (let ((name (first spec)))
  17     `(,name :initarg ,(as-keyword name) :accessor ,(as-accessor name))))
  18
  19 (defun mklist (x)
  20   "Return the argument as a list if it isn't already"
  21   (if (listp x) x (list x)))
  22
  23 (defun normalize-slot-spec (spec)
  24   (list (first spec) (mklist (cdr spec))))
  25
  26 (defun slot->read-value (spec file-data)
  27   (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
  28     `(setf ,name (read-value ',(find-symbol (symbol-name type)) ,file-data ,@args))))
  29
  30 (defun slot->write-value (spec file-data)
  31   (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
  32     `(write-value ',(find-symbol (symbol-name type)) ,file-data ,name ,@args)))
  33
  34
  35
  36 (defmacro define-binary-class (name slots)
  37   "Define a class that can be read or written to a flat binary file."
  38   (with-gensyms (typevar objectvar binary-data-var)
  39     `(progn
  40        ;; generate a defclass form
  41        (defclass ,name ()
  42          ,(mapcar #'slot->defclass-slot slots))
  43        ;; generate a method to read all slots
  44        (defmethod read-value ((,typevar (eql ',name)) ,binary-data-var &key (alignment 1) (array-size 0) (endian :little))
  45          (declare (ignore endian))
  46          (assert (= array-size 0))
  47          (align-for-read ,binary-data-var alignment)
  48          (let ((,objectvar (make-instance ',name)))
  49            (with-slots ,(mapcar #'first slots) ,objectvar
  50              ;; note - doesn't pass on endianness or allow alignment of slots yet -- to do
  51              ,@(mapcar #'(lambda (x) (slot->read-value x binary-data-var)) slots))
  52            ,objectvar))
  53         ;; generate a method to write all slots
  54        (defmethod write-value ((,typevar (eql ',name)) ,binary-data-var ,objectvar &key (alignment 1) (array-size 0) (endian :little))
  55          (declare (ignore endian))
  56          (assert (= array-size 0))
  57          (align-for-write ,binary-data-var alignment)
  58          (with-slots ,(mapcar #'first slots) ,objectvar
  59            ;; note - doesn't pass on endianness or allow alignment of slots yet -- to do
  60            ,@(mapcar #'(lambda (x) (slot->write-value x binary-data-var)) slots))
  61          (values)))))