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
))))
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
)
40 ;; generate a defclass form
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
))
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
))