Книга: Practical Common Lisp

Keeping Track of Inherited Slots

Keeping Track of Inherited Slots

This definition will work for many purposes. However, it doesn't handle one fairly common situation, namely, when you have a subclass that needs to refer to inherited slots in its own slot specifications. For instance, with the current definition of define-binary-class, you can define a single class like this:

(define-binary-class generic-frame ()
((id (iso-8859-1-string :length 3))
(size u3)
(data (raw-bytes :bytes size))))

The reference to size in the specification of data works the way you'd expect because the expressions that read and write the data slot are wrapped in a WITH-SLOTS that lists all the object's slots. However, if you try to split that class into two classes like this:

(define-binary-class frame ()
((id (iso-8859-1-string :length 3))
(size u3)))
(define-binary-class generic-frame (frame)
((data (raw-bytes :bytes size))))

you'll get a compile-time warning when you compile the generic-frame definition and a runtime error when you try to use it because there will be no lexically apparent variable size in the read-object and write-object methods specialized on generic-frame.

What you need to do is keep track of the slots defined by each binary class and then include inherited slots in the WITH-SLOTS forms in the read-object and write-object methods.

The easiest way to keep track of information like this is to hang it off the symbol that names the class. As I discussed in Chapter 21, every symbol object has an associated property list, which can be accessed via the functions SYMBOL-PLIST and GET. You can associate arbitrary key/value pairs with a symbol by adding them to its property list with SETF of GET. For instance, if the binary class foo defines three slots—x, y, and z—you can keep track of that fact by adding a slots key to the symbol foo's property list with the value (x y z) with this expression:

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

You want this bookkeeping to happen as part of evaluating the define-binary-class of 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-class form 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-class forms, 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-class form, 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-slots while 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-class and 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-class to 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))))))

Оглавление книги