#:g1: Tiny CLOS MOPが本家CLOS MOPの進化版だった件

Posted 2020-12-05 23:00:44 GMT

allocate-instance Advent Calendar 2020 6日目の記事です。

今回は、allocate-instanceを含めたInstance Structure Protocol(ISP)について書きたいと思います。

Advances in Object-Oriented Metalevel Architectures and Reflectionというオブジェクト指向プログラミングの本で、ECLOSというCLOS MOPの活用事例の紹介論文があるのですが、この論文の補遺にKiczales先生が1990年代前半に考えていたCLOS MOPのISPの改善案が紹介されています。

改善案では、

というのが主なところですが、compute-getter-and-setterはTiny CLOS系でお馴染です。
ここで紹介されている改善案とTiny CLOSのISP構成を比較してみると、実際そのまま同じ構成でした。
旧プロトコルの問題としては、

—等があり、この辺りをcompute-getter-and-setterでslot-valueの下請けのセッターとゲッターをまとめて管理するようにすることで改善できた、としています。

コンセプトを説明するためのコードも記載されているので、試しに既存のCommon Lisp上で動くかを試してみましたが、ISPをまるごと差し替えるのは、それなりに面倒な様子です。

具体的には、クラスの再定義時のインスタンス情報の更新プロトコルも併せて修正する必要がありそうです。

まとめ

Tiny CLOS系のMOPと、CLOS MOPで結構違うのがスロットのカスタマイズの作法ですが、Tiny CLOS方式の方が見通し良くコードも簡潔にカスタマイズできます。
パフォーマンスに関しては、Common Lisp処理系でもCLOS MOPの枠内での工夫があるので、そこまでの違いはなさそうな気はします。

AMOPがCommon LispのMOPの決定版の地位を確立したところまでは良かったのですが、それ以降は停滞してしまいました。
CLOS MOPはANSI規格で定義されているわけではないので、処理系ごとに色々できそうですが、AMOPという定番がある故にそこから逸脱することも難しく色々微妙なことになっています……。

コード

(defpackage "899d6e7c-87b9-559a-8075-8452920d48fc" 
  (:use c2cl slotted-objects)
  (:shadow slot-value class-slots))

(in-package "899d6e7c-87b9-559a-8075-8452920d48fc")

(defclass new-standard-class (standard-class)
  ((nfields :initform nil)
   (getters-n-setters :initform '())
   (slots :initform '() :accessor class-slots)))

(defmethod validate-superclass ((c new-standard-class) (s standard-class))
  T)

(defmethod allocate-instance ((class new-standard-class) &rest initargs)
  (allocate-slotted-instance (class-wrapper class)
                          (make-sequence 'vector (cl:slot-value class 'nfields)
                                         :initial-element (make-unbound-marker))))

(defgeneric compute-getter-and-setter (class eslotd eslotds field-allocator))

(defmethod compute-getter-and-setter ((class standard-class)
                                      (eslotd standard-effective-slot-definition)
                                      eslotds
                                      field-allocator)
  (ecase (slot-definition-allocation eslotd)
    (:instance (list eslotd
                     (funcall field-allocator)
                     (lambda (ignore-obj val) 
                       (declare (ignore ignore-obj))
                       val)
                     (lambda (ignore-obj val new) 
                       (declare (ignore val ignore-obj))
                       new)))
    (:class (let ((cell (cons (make-unbound-marker) nil)))
              (list eslotd
                    nil
                    (lambda (ignore-obj ignore-val) 
                      (declare (ignore ignore-obj ignore-val))
                      (car cell))
                    (lambda (ignore-obj ignore-val new)
                      (declare (ignore ignore-obj ignore-val))
                      (setf (car cell) new)))))))

#+lispworks
(defun make-wrapper (class eslotds)
  (let ((wrapper (clos::make-wrapper-standard (length eslotds))))
    (clos::initialize-wrapper wrapper)
    (setf (elt wrapper 1)
          (mapcar #'slot-definition-name eslotds))
    (setf (clos::wrapper-class wrapper)
          class)
    (setf (elt wrapper 4)
          eslotds)
    wrapper))

(defmethod finalize-inheritance ((class new-standard-class))
  (setf (class-precedence-list class)
        (compute-class-precedence-list class))
  (setf (cl:slot-value class 'slots) (compute-slots class))
  (let* ((eslotds (class-slots class))
         (nfields 0)
         (field-allocator (lambda ()
                            (prog1 
                              nfields
                              (incf nfields)))))
    (setf (cl:slot-value class 'getters-n-setters)
          (mapcar (lambda (eslotd)
                    (compute-getter-and-setter class eslotd eslotds field-allocator))
                  eslotds))
    (setf (cl:slot-value class 'nfields) nfields)
    (setf (class-default-initargs class)
          (compute-default-initargs class))
    (setf (clos::class-wrapper class)
          (make-wrapper class eslotds)))
  nil)

(defgeneric get-field (object field))

(defmethod get-field ((object standard-object) field)
  (elt (instance-slots object) field))

(defgeneric set-field (object field value))

(defmethod set-field ((object standard-object) field value)
  (setf (elt (instance-slots object) field)
        value))

(defun slot-value (object slot-name)
  (let* ((class (class-of object))
         (eslotd (find slot-name (class-slots class)
                       :key #'slot-definition-name)))
    (destructuring-bind (field getter setter)
                        (cdr (assoc eslotd (cl:slot-value class 'getters-n-setters)))
      (declare (ignore setter))
      (funcall getter object (and field (get-field object field))))))

(defun (setf slot-value) (new object slot-name)
  (let* ((class (class-of object))
         (eslotd (find slot-name (class-slots class)
                       :key #'slot-definition-name)))
    (destructuring-bind (field getter setter)
                        (cdr (assoc eslotd (cl:slot-value class 'getters-n-setters)))
      (declare (ignore getter))
      (if field
          (set-field object
                     field
                     (funcall setter object (get-field object field) new))
          (funcall setter object nil new)))))

■

HTML generated by 3bmd in LispWorks 7.0.0

comments powered by Disqus