Practical Common Lisp

specialized read-value method that knows how to read the values that make up the start of the structure and then use those values to determine what subclass to instantiate. It'll then make an instance of that class with MAKE-INSTANCE, passing the already read values as initargs, and pass the object to read-object, allowing the actual class of the object to determine how the rest of the structure is read.

The new macro, define-tagged-binary-class, will look like define-binary-class with the addition of a :dispatch option used to specify a form that should evaluate to the name of a binary class. The :dispatch form will be evaluated in a context where the names of the slots defined by the tagged class are bound to variables that hold the values read from the file. The class whose name it returns must accept initargs corresponding to the slot names defined by the tagged class. This is easily ensured if the :dispatch form always evaluates to the name of a class that subclasses the tagged class.

For instance, supposing you have a function, find-frame-class, that will map a string identifier to a binary class representing a particular kind of ID3 frame, you might define a tagged binary class, id3- frame, like this:

(define-tagged-binary-class id3-frame ()
  ((id   (iso-8859-1-string :length 3))
   (size u3))
  (:dispatch (find-frame-class id)))

The expansion of a define-tagged-binary-class will contain a DEFCLASS and a write-object method just like the expansion of define-binary-class, but instead of a read-object method it'll contain a read-value method that looks like this:

(defmethod read-value ((type (eql 'id3-frame)) stream &key)
  (let ((id (read-value 'iso-8859-1-string stream :length 3))
        (size (read-value 'u3 stream)))
    (let ((object (make-instance (find-frame-class id) :id id :size size)))
      (read-object object stream)
      object)))

Since the expansions of define-tagged-binary-class and define-binary-class are going to be identical except for the read method, you can factor out the common bits into a helper macro, define-generic-binary-class, that accepts the read method as a parameter and interpolates it.

(defmacro define-generic-binary-class (name (&rest superclasses) slots read-method)
  (with-gensyms (objectvar streamvar)
    `(progn
       (eval-when (:compile-toplevel :load-toplevel :execute)
         (setf (get ',name 'slots) ',(mapcar #'first slots))
         (setf (get ',name 'superclasses) ',superclasses))
       (defclass ,name ,superclasses
         ,(mapcar #'slot->defclass-slot slots))
       ,read-method
       (defmethod write-object progn ((,objectvar ,name) ,streamvar)
         (declare (ignorable ,streamvar))
         (with-slots ,(new-class-all-slots slots superclasses) ,objectvar
           ,@(mapcar #'(lambda (x) (slot->write-value x streamvar)) slots))))))

Now you can define both define-binary-class and define-tagged-binary-class to expand into a call to define-generic-binary-class. Here's a new version of define- binary-class that generates the same code as the earlier version when it's fully expanded:

(defmacro define-binary-class (name (&rest superclasses) slots)
  (with-gensyms (objectvar streamvar)
    `(define-generic-binary-class ,name ,superclasses ,slots
       (defmethod read-object progn ((,objectvar ,name) ,streamvar)
         (declare (ignorable ,streamvar))
         (with-slots ,(new-class-all-slots slots superclasses) ,objectvar
           ,@(mapcar #'(lambda (x) (slot->read-value x streamvar)) slots))))))

And here's define-tagged-binary-class along with two new helper functions it uses:

(defmacro define-tagged-binary-class (name (&rest superclasses) slots &rest options)
  (with-gensyms (typevar objectvar streamvar)
    `(define-generic-binary-class ,name ,superclasses ,slots
      (defmethod read-value ((,typevar (eql ',name)) ,streamvar &key)
        (let* ,(mapcar #'(lambda (x) (slot->binding x streamvar)) slots)
          (let ((,objectvar
                 (make-instance
                  ,@(or (cdr (assoc :dispatch options))
                        (error 'Must supply :dispatch form.'))
                  ,@(mapcan #'slot->keyword-arg slots))))
            (read-object ,objectvar ,streamvar)
            ,objectvar))))))
(defun slot->binding (spec stream)
  (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
    `(,name (read-value ',type ,stream ,@args))))
(defun slot->keyword-arg (spec)
  (let ((name (first spec)))
    `(,(as-keyword name) ,name)))

Primitive Binary Types

While define-binary-class and define-tagged-binary-class make it easy to define composite structures, you still have to write read-value and write-value methods for primitive data types by hand. You could decide to live with that, specifying that users of the library need to write appropriate methods on read-value and write-value to support the primitive types used by their binary classes.

However, rather than having to document how to write a suitable read-value/write- value pair, you can provide a macro to do it automatically. This also has the advantage of making the abstraction created by define-binary-class less leaky. Currently, define-binary- class depends on having methods on read-value and write-value defined in a particular way, but that's really just an implementation detail. By defining a macro that generates the read-value and write-value methods for primitive types, you hide those details behind an abstraction you control. If you decide later to change the implementation of define-binary- class, you can change your primitive-type-defining macro to meet the new requirements without requiring