Posted 2020-12-17 19:59:09 GMT
allocate-instance Advent Calendar 2020 18日目の記事です。
これまで、スロットのストレージを二次元配列にしてみたり、構造体にしてみたりと妙なことを試してきましたが、標準的なスロットストレージを持つオブジェクト(standard-object等)とのchange-classでの相互運用を考慮した場合、スロットストレージも伸展や縮退をサポートする必要があります。
この辺りを司るのは、change-classの下請けのupdate-instance-for-different-classになりますが、滅多に使わない機能というか、私個人もメソッド定義する必要に遭遇したことがありません。
それはさておき、とりあえずの例として、スロットストレージが拡張された、a-class、b-classと、標準構成の三つのクラスを定義したとします。
(defpackage "fd84d50c-3573-5d37-aed2-73e7d98bb52d"
(:use c2cl slotted-objects))
(cl:in-package "fd84d50c-3573-5d37-aed2-73e7d98bb52d")
(defclass a-class (slotted-class)
())
(defclass a-object (slotted-object)
()
(:metaclass a-class))
(defclass b-class (slotted-class)
())
(defclass b-object (slotted-object)
()
(:metaclass a-class))
(defmethod allocate-instance ((class a-class) &key &allow-other-keys)
(allocate-slotted-instance (class-wrapper class)
(make-array `(2 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defmethod allocate-instance ((class b-class) &key &allow-other-keys)
(allocate-slotted-instance (class-wrapper class)
(make-array `(4 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defmethod slot-value-using-class ((class a-class) instance (slotd slot-definition))
(aref (instance-slots instance) 0 (slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class a-class) instance (slotd slot-definition))
(setf (aref (instance-slots instance) 0 (slot-definition-location slotd))
value))
(defmethod slot-value-using-class ((class b-class) instance (slotd slot-definition))
(aref (instance-slots instance) 1 (slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class b-class) instance (slotd slot-definition))
(setf (aref (instance-slots instance) 1 (slot-definition-location slotd))
value))
とりあえず、インスタンスのクラスを変更することがなければ、別段このままでも問題ありません。
(defclass foo (a-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass a-class))
(defclass bar (b-object)
((a :initform 4)
(b :initform 5)
(c :initform 6))
(:metaclass b-class))
(defclass baz (standard-object)
((a :initform 7)
(b :initform 8)
(c :initform 9)))
(progn
(describe (make-instance 'foo))
(describe (make-instance 'bar))
(describe (make-instance 'baz)))
#<foo 402005E1FB> is a foo
a 0
b 1
c 2
#<bar 402005E59B> is a bar
a 4
b 5
c 6
#<baz 402005E8D3> is a baz
a 7
b 8
c 9
しかし、change-classするとなると、インスタンスのストレージが違うので、違いを吸収するメソッドをupdate-instance-for-different-classに定義してやる必要があります。
standard-objectにchange-classする分には拡張したスロットストレージが削られることになるので、特に難しいことはありません。
(defmethod update-instance-for-different-class
((pre slotted-object) (cur standard-object) &key &allow-other-keys)
(dolist (slotd (class-slots (class-of cur)))
(let ((slot-name (slot-definition-name slotd)))
(when (slot-exists-p pre slot-name)
(setf (slot-value cur slot-name)
(slot-value pre slot-name))))))standard-objectから拡張したものにchange-classする分には拡張したスロットストレージを使うことになるので、ストレージのアロケートをして、新しいストレージ側に値をコピーする必要があります。
ストレージのアロケーションをメタクラスで切り替えたいとすると、allocate-instanceの下請けとして共通のメソッドを定義するのが良さそうです。
今回は、allocate-slot-storageというメソッドを定義して使うことにしてみました。
(defgeneric allocate-slot-storage (class size initial-value))
(defmethod allocate-slot-storage ((class a-class) size initial-value)
(make-array `(2 ,size) :initial-element initial-value))
(defmethod allocate-slot-storage ((class b-class) size initial-value)
(make-array `(4 ,size) :initial-element initial-value))
;; ... allocate-instanceの書き換えは略 ...
(defmethod update-instance-for-different-class
((pre standard-object) (cur slotted-object) &key &allow-other-keys)
(let ((cur-class (class-of cur)))
(setf (instance-slots cur)
(allocate-slot-storage cur-class
(length (class-slots cur-class))
(make-unbound-marker)))
(dolist (slotd (class-slots cur-class))
(let ((slot-name (slot-definition-name slotd)))
(when (slot-exists-p pre slot-name)
(setf (slot-value cur slot-name)
(slot-value pre slot-name)))))))
標準→拡張と内容は同じなのですが、このパターンも用意しておく必要があります。
(defmethod update-instance-for-different-class
((pre slotted-object) (cur slotted-object) &key &allow-other-keys)
(let ((cur-class (class-of cur)))
(setf (instance-slots cur)
(allocate-slot-storage cur-class
(length (class-slots cur-class))
(make-unbound-marker)))
(dolist (slotd (class-slots cur-class))
(let ((slot-name (slot-definition-name slotd)))
(when (slot-exists-p pre slot-name)
(setf (slot-value cur slot-name)
(slot-value pre slot-name)))))))なお、基本的に拡張への移行は、新しくインスタンスのストレージを確保する部分だけなので、update-instance-for-different-classの:beforeメソッドで、ストレージの置き換えを定義するだけで良いのかもしれません。
このあたりの参考資料が見付けられないので良く分からず……。
以上で相互変換が可能になります。
(progn
(progn
;; slotted-object → standard-object
(describe (change-class (make-instance 'foo) 'baz))
(describe (change-class (make-instance 'bar) 'baz))
(describe (change-class (make-instance 'baz) 'baz)))
(progn
;; standard-object → slotted-object
(describe (change-class (make-instance 'bar) 'foo))
(describe (change-class (make-instance 'baz) 'foo)))
(progn
;; slotted-object → slotted-object
(describe (change-class (make-instance 'foo) 'bar))
(describe (change-class (make-instance 'bar) 'bar))))#<baz 402005EC43> is a baz
a 0
b 1
c 2
#<baz 402005F163> is a baz
a 4
b 5
c 6
#<baz 402005F64B> is a baz
a 7
b 8
c 9
#<foo 402005FB33> is a foo
a 4
b 5
c 6
#<foo 4020060073> is a foo
a 7
b 8
c 9
#<bar 4020060583> is a bar
a 0
b 1
c 2
#<bar 4020230B2B> is a bar
a 4
b 5
c 6
allocate-なんとかのメソッドを上手い感じに命名してまとめたいところなのですが難しい……。
一応今回は、Closetteを参考に命名してみました。
■
HTML generated by 3bmd in LispWorks 7.0.0