#:g1: MOPで隠しスロットの実現

Posted 2019-12-09 19:26:03 GMT

ここ最近、standard-instance-accessでインスタンス内部のベクタに直接アクセスするようなことを試していましたが、インデックスを求める方法があやふやでした。
compute-slotsで並んだ順で確定するのは分かっていたのですが、並び順ということは飛び飛びにはできないわけで、どうしたものかと考えていましたが、compute-slotsの説明を良く読んだら、compute-slotsのプライマリメソッドでスロット定義を並べて、compute-slots:aroundメソッドでslot-definition-locationの内容を確定するようなことが書いてあります。

In the final step, the location for each effective slot definition is
set. This is done by specified around-methods; portable methods cannot
take over this behavior. For more information on the slot definition
locations, see the section ``Instance Structure Protocol.''

ということでSBCLのMOP実装を確認してみましたが、やはり:aroundlocationを設定していました。なるほど。

compute-slots:aroundを乗っ取るには、さらなる:aroundを定義するしかないわけですが、どうも可搬性のためにはいじってはいけない場所のようです。

とはいえ、インデックスの設定方法が分かったので、試しに今回は、X3J13-88-003R-DRAFTのコード例にあるfaceted-slot-classを動かしてみたいと思います。

faceted-slot-class

X3J13-88-003Rのドラフトにはindex-in-instanceというAPIが存在していて、スロット名からインデックスを算出する仕組みになっていたようです。

このindex-in-instanceの利用例として、0、2、4…をスロット、1、3、5…をファセットとして配置するメタクラスを定義しています。

動作は下記のようになります。

(defclass zot ()
  ((a :initform 42)
   (b :initform 43)
   (c :initform 44))
  (:metaclass faceted-slot-class))

(let ((o (make-instance 'zot))) (values (with-slots (a b c) o (list a b c)) (loop :for index :from 0 :repeat (compute-instance-size (class-of o)) :collect (standard-instance-access o index))))(42 43 44) (42 #<Slot Unbound Marker> 43 #<Slot Unbound Marker> 44 #<Slot Unbound Marker>)

;;; ファセットに値を設定 (let ((o (make-instance 'zot))) (setf (slot-facet o 'a) 'facet-a) (setf (slot-facet o 'b) 'facet-b) (setf (slot-facet o 'c) 'facet-c) (values (with-slots (a b c) o (list a b c)) (loop :for index :from 0 :repeat (compute-instance-size (class-of o)) :collect (standard-instance-access o index))))(42 43 44) (42 facet-a 43 facet-b 44 facet-c)

実装

ということで実装ですが、元のコードのAPIをできるだけ残したかったのですが、どうもコンセプトコードのようで実際に動かすと色々矛盾がある様子。
その辺りは適当に辻褄を合せました。
しかし、辻褄が合わないところもあり、

等は、index-in-instanceの内容をcompute-slotの中にベタ書きで展開することで回避しています。

以下、LispWorks依存なコードです。
LispWorks標準のslot-value-using-classは、スロットのインデックスが隙間無く並んでいることを前提としていて、疎な配置にすると動作がおかしくなるので、自前で定義しています。

(ql:quickload :closer-mop)

(defpackage "2f1cccc9-c776-5726-9e68-91d2d9042169" (:use :c2cl))

(in-package "2f1cccc9-c776-5726-9e68-91d2d9042169")

(defgeneric index-in-instance (class description))

(defmethod index-in-instance ((class cl:standard-class) description) (typecase description (symbol (position description (class-slots class) :key #'slot-definition-name)) (T (error "Don't understand the description ~S." description))))

(defgeneric compute-instance-size (class))

(defmethod compute-instance-size ((class cl:standard-class)) (length (class-slots class)))

(defclass faceted-slot-class (standard-class) ())

(defmethod validate-superclass ((c faceted-slot-class) (s standard-class)) T)

(defmethod compute-instance-size ((class faceted-slot-class)) (* 2 (call-next-method)))

(defmethod allocate-instance ((class faceted-slot-class) &rest initargs) (let ((class (clos::ensure-class-finalized class))) (sys:alloc-fix-instance (clos::class-wrapper class) (sys:alloc-g-vector$fixnum (compute-instance-size class) clos::*slot-unbound*))))

(defmethod index-in-instance ((class faceted-slot-class) description) (cond ((symbolp description) (let ((index (call-next-method))) (and index (* 2 index)))) ((and (consp description) (eq (car description) 'facet)) (1+ (index-in-instance class (cadr description)))) (T (error "Don't understand the description ~S." description))))

(defun standard-instance-access* (instance description trap not-bound-function missing-function) (declare (ignore trap)) (let* ((class (class-of instance)) (index (index-in-instance class description))) (cond ((null index) (funcall missing-function instance description)) ((not (numberp index)) (slot-value index 'value)) ((null (standard-instance-boundp instance index)) (funcall not-bound-function instance description)) (T (standard-instance-access instance index)))))

(defun (setf standard-instance-access*) (val instance description trap not-bound-function missing-function) (declare (ignore trap not-bound-function)) (let* ((class (class-of instance)) (index (index-in-instance class description))) (cond ((null index) (funcall missing-function instance description)) ((not (numberp index)) (slot-value index 'value)) (T (setf (standard-instance-access instance index) val)))))

(defun standard-instance-boundp (instance index) (not (eq clos::*slot-unbound* (standard-instance-access instance index))))

(defun slot-facet (instance slot-name) (standard-instance-access* instance (list 'facet slot-name) nil #'facet-unbound #'facet-missing))

(defun (setf slot-facet) (new-value instance slot-name) (setf (standard-instance-access* instance (list 'facet slot-name) nil #'facet-unbound #'facet-missing) new-value))

(defun facet-unbound (instance facet) (error "The facet ~S is unbound in the object ~S" (cadr facet) instance))

(defun facet-missing (instance facet) (error "The facet ~S is missing from the object ~S" (cadr facet) instance))

(defmethod compute-slots :around ((class faceted-slot-class)) (let ((slotds (call-next-method))) (dolist (s slotds) ;; Base case (setf (slot-definition-location s) (* 2 (position s slotds)))) slotds))

(defmethod slot-value-using-class ((class faceted-slot-class) instance slot-name) (let ((index (index-in-instance class slot-name))) (cond ((null index) (slot-missing class instance slot-name 'slot-makunbound)) ((not (numberp index)) (slot-value index 'value)) ((null (standard-instance-boundp instance index)) (slot-unbound class instance slot-name)) (T (standard-instance-access instance index)))))

まとめ

index-in-instanceは、class-slotsslot-definition-nameslot-definition-locationの組み合わせとも大差ないともいえますが、index-in-instanceの方がスロット名とインデックスの関係が明確になる上にカスタマイズしやすそうな気もします。
今回の例では、index-in-instanceを呼びまくっていますが、ちょっと遅そうなので、クラスにインデックスを保持させる方が良いかもしれません。


HTML generated by 3bmd in LispWorks 7.0.0

comments powered by Disqus