1 ;;;; Silly emacs, this is -*- Lisp -*-
3 (in-package :lodematron
)
5 ;; define-binary-class ------------------------------------------------------
6 ;; Heavily influenced by (stolen, really) from Practical Common Lisp
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
))))
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
)
41 ;; generate a defclass form
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
))
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))))))