17.7 新的实现 (New Implementation)

我们到目前为止所做的改善都是牺牲灵活性交换而来。在这个系统的开发后期，一个 Lisp 程序通常可以牺牲些许灵活性来获得好处，这里也不例外。目前为止我们使用哈希表来表示所有的对象。这给我们带来了超乎我们所需的灵活性，以及超乎我们所想的花费。在这个小节里，我们会重写我们的程序，用简单向量来表示对象。

  1. (defun inst (parent)
  2.   (let ((obj (make-hash-table)))
  3.     (setf (gethash :parents obj) parent)
  4.     obj))
  6. (defun rget (prop obj)
  7.   (let ((prec (gethash :preclist obj)))
  8.     (if prec
  9.         (dolist (c prec)
  10.           (multiple-value-bind (val in) (gethash prop c)
  11.             (if in (return (values val in)))))
  12.       (multiple-value-bind (val in) (gethash prop obj)
  13.         (if in
  14.             (values val in)
  15.             (rget prop (gethash :parents obj)))))))
  17. (defun get-next (obj name)
  18.   (let ((prec (gethash :preclist obj)))
  19.     (if prec
  20.         (some #'(lambda (x) (gethash name x))
  21.               (cdr prec))
  22.       (get-next (gethash obj :parents) name))))

图 17.7: 定义实例

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

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

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

  1. (defmacro parents (v) `(svref ,v 0))
  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)
  35.     obj))

图 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>

这里我们创建了两个类别： geom-class 没有基类，且只有一个属性， area ； circle-class 是 gemo-class 的子类，并添加了一个属性， radius 。 [1] circle-class 类的设计

  1. > (coerce (layout circle-class) 'list)
  2. (AREA RADIUS)

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

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

  1. > (svref circle-class
  2.          (+ (position 'area (layout circle-class)) 3))
  3. :NIL

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

最后，函数 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 。
  2. 若对象是一个实例，我们直接查找属性，并在没找到时递回地调用 rget 。

rget 与 next? 新的第三个参数稍后解释。现在只要了解如果是 nil ， rget 会像平常那样工作。

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

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

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

  1. (setf (lookup 'area circle-class)
  2.       #'(lambda (c)
  3.           (* pi (expt (rget 'radius c nil) 2))))

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

  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 实现，我们也可以调用 area 来获得 our-circle 的面积：

  1. > (area our-circle)
  2. 12.566370614359173