图 17.7: 定义实例

    这个改变意味着放弃动态定义新属性的可能性。目前我们可通过引用任何对象，给它定义一个属性。现在当一个类别被创建时，我们会需要给出一个列表，列出该类有的新属性，而当实例被创建时，他们会恰好有他们所继承的属性。

    在先前的实现里，类别与实例没有实际区别。一个实例只是一个恰好有一个父类的类别。如果我们改动一个实例的父类，它就变成了一个类别。在新的实现里，类别与实例有实际区别；它使得将实例转成类别不再可能。

    在图 17.8-17.10 的代码是一个完整的新实现。图片 17.8 给创建类别与实例定义了新的操作符。类别与实例用向量来表示。表示类别与实例的向量的前三个元素包含程序自身要用到的信息，而图 17.8 的前三个宏是用来引用这些元素的：

    2. (defmacro layout (v) `(the simple-vector (svref ,v 1)))
    3. (defmacro preclist (v) `(svref ,v 2))
    5. (defmacro class (&optional parents &rest props)
    6.   `(class-fn (list ,@parents) ',props))
    8. (defun class-fn (parents props)
    9.   (let* ((all (union (inherit-props parents) props))
    10.          (obj (make-array (+ (length all) 3)
    11.                           :initial-element :nil)))
    12.     (setf (parents obj)  parents
    13.           (layout obj)   (coerce all 'simple-vector)
    14.           (preclist obj) (precedence obj))
    15.     obj))
    17. (defun inherit-props (classes)
    18.   (delete-duplicates
    19.     (mapcan #'(lambda (c)
    20.                 (nconc (coerce (layout c) 'list)
    21.                        (inherit-props (parents c))))
    22.             classes)))
    24. (defun precedence (obj)
    25.   (labels ((traverse (x)
    26.              (cons x
    27.                    (mapcan #'traverse (parents x)))))
    28.     (delete-duplicates (traverse obj))))
    30. (defun inst (parent)
    31.   (let ((obj (copy-seq parent)))
    32.     (setf (parents obj)  parent
    33.           (preclist obj) nil)
    34.     (fill obj :nil :start 3)

    图 17.8: 向量实现：创建

    1. parents 字段取代旧实现中，哈希表条目里 :parents 的位置。在一个类别里， parents 会是一个列出父类的列表。在一个实例里， parents 会是一个单一的父类。
    2. layout 字段是一个包含属性名字的向量，指出类别或实例的从第四个元素开始的设计 (layout)。
    3. preclist 字段取代旧实现中，哈希表条目里 :preclist 的位置。它会是一个类别的优先级列表，实例的话就是一个空表。

    因为这些操作符是宏，他们全都可以被 setf 的第一个参数使用（参考 10.6 节）。

    class 宏用来创建类别。它接受一个含有其基类的选择性列表，伴随着零个或多个属性名称。它返回一个代表类别的对象。新的类别会同时有自己本身的属性名，以及从所有基类继承而来的属性。

    1. > (setf *print-array* nil
    2.         gemo-class (class nil area)
    3.         circle-class (class (geom-class) radius))
    4. #<Simple-Vector T 5 C6205E>
    1. > (coerce (layout circle-class) 'list)

    显示了五个字段里，最后两个的名称。

    class 宏只是一个 class-fn 的介面，而 class-fn 做了实际的工作。它调用 inherit-props 来汇整所有新对象的父类，汇整成一个列表，创建一个正确长度的向量，并适当地配置前三个字段。（ preclist 由 precedence 创建，本质上 precedence 没什么改变。）类别余下的字段设置为 :nil 来指出它们尚未初始化。要检视 circle-class 的 area 属性，我们可以：

    稍后我们会定义存取函数来自动办到这件事。

    最后，函数 inst 用来创建实例。它不需要是一个宏，因为它仅接受一个参数：

    1. > (setf our-circle (inst circle-class))
    2. #<Simple-Vector T 5 C6464E>

    比较 inst 与 class-fn 是有益学习的，它们做了差不多的事。因为实例仅有一个父类，不需要决定它继承什么属性。实例可以仅拷贝其父类的设计。它也不需要构造一个优先级列表，因为实例没有优先级列表。创建实例因此与创建类别比起来来得快许多，因为创建实例在多数应用里比创建类别更常见。

    1. (declaim (inline lookup (setf lookup)))
    3. (defun rget (prop obj next?)
    4.   (let ((prec (preclist obj)))
    5.     (if prec
    6.         (dolist (c (if next? (cdr prec) prec) :nil)
    7.           (let ((val (lookup prop c)))
    8.             (unless (eq val :nil) (return val))))
    9.         (let ((val (lookup prop obj)))
    10.           (if (eq val :nil)
    11.               (rget prop (parents obj) nil)
    12.               val)))))
    14. (defun lookup (prop obj)
    15.   (let ((off (position prop (layout obj) :test #'eq)))
    16.     (if off (svref obj (+ off 3)) :nil)))
    18. (defun (setf lookup) (val prop obj)
    19.   (let ((off (position prop (layout obj) :test #'eq)))
    20.     (if off
    21.         (setf (svref obj (+ off 3)) val)
    22.         (error "Can't set ~A of ~A." val obj))))

    图 17.9: 向量实现：存取

    现在我们可以创建所需的类别层级及实例，以及需要的函数来读写它们的属性。图 17.9 的第一个函数是 rget 的新定义。它的形状与图 17.7 的 rget 相似。条件式的两个分支，分别处理类别与实例。

    1. 若对象是一个类别，我们遍历其优先级列表，直到我们找到一个对象，其中欲找的属性不是 :nil 。如果没有找到，返回 :nil 。

    函数 lookup 及其反相扮演着先前 rget 函数里 gethash 的角色。它们使用一个对象的 layout ，来取出或设置一个给定名称的属性。这条查询是先前的一个复本：

    1. > (lookup 'area circle-class)
    2. :NIL

    由于 lookup 的 setf 也定义了，我们可以给 定义一个 area 方法，通过：

    在这个程序里，和先前的版本一样，没有特别区别出方法与槽。一个“方法”只是一个字段，里面有着一个函数。这将很快会被一个更方便的前端所隐藏起来。

    1. (declaim (inline run-methods))
    3. (defmacro defprop (name &optional meth?)
    4.   `(progn
    5.      (defun ,name (obj &rest args)
    6.        ,(if meth?
    7.             `(run-methods obj ',name args)
    8.             `(rget ',name obj nil)))
    9.      (defun (setf ,name) (val obj)
    10.        (setf (lookup ',name obj) val))))
    12. (defun run-methods (obj name args)
    13.   (let ((meth (rget name obj nil)))
    14.     (if (not (eq meth :nil))
    15.         (apply meth obj args)
    16.         (error "No ~A method for ~A." name obj))))
    18. (defmacro defmeth (name obj parms &rest body)
    19.   (let ((gobj (gensym)))
    20.     `(let ((,gobj ,obj))
    21.        (defprop ,name t)
    22.        (setf (lookup ',name ,gobj)
    23.              (labels ((next () (rget ,gobj ',name t)))
    24.                #'(lambda ,parms ,@body))))))

    图 17.10: 向量实现：宏介面

    图 17.10 包含了新的实现的最后部分。这个代码没有给程序加入任何威力，但使程序更容易使用。宏 defprop 本质上没有改变；现在仅调用 lookup 而不是 gethash 。与先前相同，它允许我们用函数式的语法来引用属性：

    1. > (defprop radius)
    2. (SETF RADIUS)
    3. > (radius our-circle)
    4. :NIL
    5. > (setf (radius our-circle) 2)
    6. 2

    如果 defprop 的第二个选择性参数为真的话，它展开成一个 run-methods 调用，基本上也没什么改变。

    最后，函数 defmeth 提供了一个便捷方式来定义方法。这个版本有三件新的事情：它隐含了 defprop ，它调用 lookup 而不是 gethash ，且它调用 regt 而不是 278 页的 get-next (译注: 图 17.7 的 get-next )来获得下个方法。现在我们理解给 rget 添加额外参数的理由。它与 get-next 非常相似，我们同样通过添加一个额外参数，在一个函数里实现。若这额外参数为真时， rget 取代 get-next 的位置。

    1. (defmeth area circle-class (c)
    2.   (* pi (expt (radius c) 2)))

    注意我们可以直接调用 radius 而无须调用 rget ，因为我们使用 defprop 将它定义成一个函数。因为隐含的 defprop 由 defmeth 实现，我们也可以调用 来获得 our-circle 的面积：