Peter Siebel - Practical Common Lisp

(setf (get 'foo 'slots) '(x y z))

You want this bookkeeping to happen as part of evaluating the define-binary-classof foo. However, it's not clear where to put the expression. If you evaluate it when you compute the macro's expansion, it'll get evaluated when you compile the define-binary-classform but not if you later load a file that contains the resulting compiled code. On the other hand, if you include the expression in the expansion, then it won't be evaluated during compilation, which means if you compile a file with several define-binary-classforms, none of the information about what classes define what slots will be available until the whole file is loaded, which is too late.

This is what the special operator EVAL-WHEN I discussed in Chapter 20 is for. By wrapping a form in an EVAL-WHEN , you can control whether it's evaluated at compile time, when the compiled code is loaded, or both. For cases like this where you want to squirrel away some information during the compilation of a macro form that you also want to be available after the compiled form is loaded, you should wrap it in an EVAL-WHEN like this:

(eval-when (:compile-toplevel :load-toplevel :execute)

(setf (get 'foo 'slots) '(x y z)))

and include the EVAL-WHEN in the expansion generated by the macro. Thus, you can save both the slots and the direct superclasses of a binary class by adding this form to the expansion generated by define-binary-class:

(eval-when (:compile-toplevel :load-toplevel :execute)

(setf (get ',name 'slots) ',(mapcar #'first slots))

(setf (get ',name 'superclasses) ',superclasses))

Now you can define three helper functions for accessing this information. The first simply returns the slots directly defined by a binary class. It's a good idea to return a copy of the list since you don't want other code to modify the list of slots after the binary class has been defined.

(defun direct-slots (name)

(copy-list (get name 'slots)))

The next function returns the slots inherited from other binary classes.

(defun inherited-slots (name)

(loop for super in (get name 'superclasses)

nconc (direct-slots super)

nconc (inherited-slots super)))

Finally, you can define a function that returns a list containing the names of all directly defined and inherited slots.

(defun all-slots (name)

(nconc (direct-slots name) (inherited-slots name)))

When you're computing the expansion of a define-generic-binary-classform, you want to generate a WITH-SLOTS form that contains the names of all the slots defined in the new class and all its superclasses. However, you can't use all-slotswhile you're generating the expansion since the information won't be available until after the expansion is compiled. Instead, you should use the following function, which takes the list of slot specifiers and superclasses passed to define-generic-binary-classand uses them to compute the list of all the new class's slots:

(defun new-class-all-slots (slots superclasses)

(nconc (mapcan #'all-slots superclasses) (mapcar #'first slots)))

With these functions defined, you can change define-binary-classto store the information about the class currently being defined and to use the already stored information about the superclasses' slots to generate the WITH-SLOTS forms you want like this:

(defmacro define-binary-class (name (&rest superclasses) slots)

(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))

(defmethod read-object progn ((,objectvar ,name) ,streamvar)

(with-slots ,(new-class-all-slots slots superclasses) ,objectvar

,@(mapcar #'(lambda (x) (slot->read-value x streamvar)) slots)))

(defmethod write-object progn ((,objectvar ,name) ,streamvar)

(with-slots ,(new-class-all-slots slots superclasses) ,objectvar

,@(mapcar #'(lambda (x) (slot->write-value x streamvar)) slots))))))

With the ability to define binary classes that extend other binary classes, you're ready to define a new macro for defining classes to represent "tagged" structures. The strategy for reading tagged structures will be to define a specialized read-valuemethod 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-classwith the addition of a :dispatchoption used to specify a form that should evaluate to the name of a binary class. The :dispatchform 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 :dispatchform 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-classwill contain a DEFCLASS and a write-objectmethod just like the expansion of define-binary-class, but instead of a read-objectmethod it'll contain a read-valuemethod 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-classand define-binary-classare 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)