#:g1: CommonObjectsをつくろう(2)

Posted 2021-08-21 20:09:52 GMT

CommonObjectsの継承

CommonObjectsの継承は所謂多重継承をサポートしていますが、そもそも継承の仕組みがちょっと変わっていて、インスタンスは上位クラスで定義されたスロットを取捨選択して一本化するのではなく、上位クラスのスロット全部を保持します。
継承戦略として木構造を採用しているということみたいですが、詳細は下記の論文を参照してください。

上位クラスのスロットを保持させる

この辺りの詳細が不明なのでcoolの実装を眺めてみましたが、上位クラスの定義を全部インスタンス化して保持するという結構富豪的な解決方法を採っているようです。
coolは1986年時点のMOPの上に実装されているので、現在のCLOS MOPとは結構違いますが、バッキングストレージのベクタは、

  1. クラスオブジェクト
  2. 自分自身(self)
  3. 上位クラスのインスタンス
  4. スロットの値

を保持しています。
なお、上位クラスのインスタンスもまた同じ構造をしていますが、selfは上位クラスのものではなく元オブジェクトを指すようになっています。

とりあえず、今回はベクタの配置のオフセットの計算が面倒に感じたので、構造体を使うことにしてみました。 インスタンス内部のベクタを挿げ替える方法はポータブルではないので、allocate-instanceで親オブジェクトを生成してテーブルに保持しておく、という方法でも良いかなと思います。

;;; https://github.com/g000001/slotted-objects を利用

(defstruct (common-objects-object-storage 
            (:constructor allocate-common-objects-object-storage))
  (self nil)
  (parents '())
  (slots nil))
(defun common-objects-class-precedence-list (class)
  (let* ((cpl (class-precedence-list class))
         (pos (position (find-class 'common-objects-object) cpl)))
    (subseq cpl 0 (or pos 0))))
(defmethod allocate-instance ((class common-objects-class) &rest initargs)
  (let* ((storage (allocate-common-objects-object-storage))
         (inst (slotted-objects:allocate-slotted-instance (slotted-objects:class-wrapper class) storage))
         (baseclass (find-class 'common-objects-object)))
    (setf (common-objects-object-storage-self storage) inst)
    (setf (common-objects-object-storage-slots storage) 
          (make-array (length (class-slots class)) :initial-element *undefined-slot-value*))
    (setf (common-objects-object-storage-parents storage)
          (loop :for c :in (cdr (common-objects-class-precedence-list class))
                :until (eql baseclass c)
                :collect (let* ((parent (make-instance c))
                                (parent-storage (slotted-objects:instance-slots parent)))
                           (setf (common-objects-object-storage-self parent-storage) inst)
                           parent)))
    inst))

(defmethod slot-value-using-class ((class common-objects-class) instance (slotd slot-definition))
  (elt (common-objects-object-storage-slots (slotted-objects:instance-slots instance))
       (slot-definition-location slotd)))

(defmethod (setf slot-value-using-class) (value (class common-objects-class) instance (slotd slot-definition))
  (setf (elt (common-objects-object-storage-slots (slotted-objects:instance-slots instance))
             (slot-definition-location slotd))
        value))

親のスロットとマージしないようにする

親クラスのインスタンスをそのまま保持する方式のため、Common Lispのデフォルト動作であるスロット定義の一本化をやめるようにします。

(defmethod compute-slots ((class common-objects-class))
  (mapcar (lambda (slotd)
            (compute-effective-slot-definition class
                                               (slot-definition-name slotd)
                                               (list slotd)))
          (class-direct-slots class)))

そして、その代りに親インスタンスのスロットを参照できるようなユーティリティを定義しておきます。

(defun parent-instance (inst type)
  (find type (common-objects-object-storage-parents (slotted-objects:instance-slots inst))
        :key #'type-of))

:inherit-from オプションの処理

これだけでは不十分ですが、暫定的な定義としてこんな感じにします。

(defun process-inherit-from (slots)
  (let ((ans '()))
    (dolist (s slots)
      (typecase s
        ((cons (eql :inherit-from) *) 
         (push (elt s 1) ans))))
    (or (nreverse ans)
        (list 'common-objects-object))))

動作確認

上記の定義で、下記のような処理ができるにはなりました。

(define-type a
  (:var a (:init 0))
  :all-settable)

(define-type b
  (:var b (:init 1))
  (:inherit-from a)
  :all-settable)

(=> (make-instance 'b) :b)
→ 1
(=> (make-instance 'b) :a)
!!! slot-missing
(=> (parent-instance (make-instance 'b) 'a) :a)
→ 0

さてしかし、CommonObjectsでは、上位クラスのメソッドは継承してくる(しかし同名メソッドは複数あるとクラス定義不可)ので、継承してきた:aメソッドが機能する必要があります。

(=> (make-instance 'b) :a)
→ 0

となれば良いのですが、これをどう実現したものか。

とりあえず、slot-missingで転送すれば似た挙動にすることは可能ですが、メソッドの継承回りをちゃんと作らないと上手く機能しなさそうです。

(defmethod slot-missing ((class (eql (find-class 'race-hourse)))
                         instance
                         slot-name
                         operation
                         &optional new-value)
  (ecase operation
    (slot-value (slot-value (parent-instance instance 'animal) slot-name))
    (setf (setf (slot-value (parent-instance instance 'animal) slot-name)
                new-value))))
(=> (make-instance 'b) :a)
→ 0

まとめ

継承まわりの設計はマニュアルではあまり説明されていないので、CommonObjectsの論文を読んだりしてどのような設計なのかを探る必要がありそうです。

■

HTML generated by 3bmd in LispWorks 7.0.0

comments powered by Disqus