Adding blender exporter
[lodematron.git] / lodematron-rw.lisp
blob7d5e4453a0ede21b6e0c0b8b1b24b0565acebdc2
1 ;;;; Silly emacs, this is -*- Lisp -*-
3 (in-package :lodematron)
5 ;; define-binary-class ------------------------------------------------------
6 ;; Heavily influenced by Practical Common Lisp by Peter Seibel
8 (defun as-keyword (sym)
9 (intern (string sym) :keyword))
11 (defun as-accessor (sym)
12 (intern (concatenate 'string (string sym) "-OF")))
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))))
19 (defun mklist (x)
20 "Return the argument as a list if it isn't already"
21 (if (listp x) x (list x)))
23 (defun normalize-slot-spec (spec)
24 (list (first spec) (mklist (cdr spec))))
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))))
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)))
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)))))