lodematron-rw.lisp

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