More work on lwo loading. Useful bit - destructuring macro.
[lodematron.git] / lwo-rw.lisp
blobc1ea4eff7d409f9e267617c1ffc1d8564322e7db
1 ;;;; Silly emacs, this is -*- Lisp -*-
3 (in-package :cl-lwo)
5 ;; define-binary-class ------------------------------------------------------
6 ;; Heavily influenced by (stolen, really) from Practical Common Lisp
7 ;; thx Peter Seibel!
9 (defun as-keyword (sym)
10 (intern (string sym) :keyword))
12 (defun as-accessor (sym)
13 (intern (concatenate 'string (string sym) "-OF")))
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))))
20 (defun mklist (x)
21 "Return the argument as a list if it isn't already"
22 (if (listp x) x (list x)))
24 (defun normalize-slot-spec (spec)
25 (list (first spec) (mklist (cdr spec))))
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))))
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)))
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)))))
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))))))