Posted 2019-02-03 20:45:41 GMT
前回は、全面的なマクロから、ensure-class
を使って若干のMOP利用へと進めましたが、今回は、ensure-class-using-class
を利用して、もう一歩進めてみたいと思います。
ensure-class
は関数ということもあり、プロトコルを成しているメソッド群をカスタマイズするという感じではありませんが、ensure-class
の下請けのensure-class-using-class
は、standard-class
をカスタマイズしたメタクラスでディスパッチさせることが可能です。
(defpackage d34ab7fb-8666-4f9c-ac95-833380ffefee
(:use :c2mop :cl)
(:shadowing-import-from :c2mop
:defmethod :standard-class :defgeneric
:standard-generic-function :funcallable-standard-class))(in-package d34ab7fb-8666-4f9c-ac95-833380ffefee)
(defun slot-name-conc (prefix name)
(let ((pkg (etypecase prefix
((or null string) *package*)
(symbol (symbol-package prefix)))))
(intern (concatenate 'string (string prefix) (string name)) pkg)))
(defclass conc-name-class (standard-class)
((conc-name :initarg :conc-name :accessor class-conc-name)))
(defmethod validate-superclass ((class conc-name-class) (super standard-class))
T)
上記では、standard-class
メタクラスのサブクラスとしてconc-name-class
メタクラスを定義してみています。
これで、ensure-class-using-class
がディスパッチできるようになります。
(defmethod ensure-class-using-class ((class conc-name-class) name
&rest initargs
&key (conc-name (concatenate 'string (string name) ".") conc-name-sup?)
direct-slots
&allow-other-keys)
(when conc-name-sup?
(setq conc-name (car conc-name)))
(setq direct-slots
(loop :for s :in direct-slots
:collect (destructuring-bind (&key name readers writers &allow-other-keys)
s
(let ((aname (slot-name-conc conc-name name)))
`(:name ,name
:readers (,aname ,@readers)
:writers ((setf ,aname) ,@writers))))))
(let ((class (apply #'call-next-method class name :direct-slots direct-slots
initargs)))
(setf (class-conc-name class) conc-name)
class))
ensure-class
と同じく、ensure-class-using-class
が取るキーワード引数は、defclass
のクラスオプションが渡ってきますので、以上で下記のように書けます。
(defclass foo ()
(x
y
(z :accessor z))
(:metaclass conc-name-class)
(:conc-name foo.))(let ((qqq (make-instance 'foo)))
(with-slots (x y z) qqq
(setq x 42 y 43 z 44))
(incf (foo.z qqq))
(list (foo.x qqq)
(foo.y qqq)
(foo.z qqq)))
→ (42 43 45)
マクロ的なアプローチの問題点として
というのがありましたが、:metaclass
を一々指定するのは面倒臭いもののdefclass
の標準構文に収まりました。
また、
というのもensure-class
が正規化して渡してくれるので、ensure-class
よりはすっきりします。
しかし、上記のコードを眺めると判るように前回とさして変化ありません。
アクセサの名前に接頭辞を付けるのだから、MOP的にするなら、スロット定義メタオブジェクトをあれこれするのが筋なのではないか、ということになります。
ということで、スロット定義のプロトコルをカスタマイズしてみます。
(defclass conc-name-direct-slot-definition (standard-direct-slot-definition)
((conc-name :initform nil :initarg :conc-name)))(defmethod direct-slot-definition-class ((class conc-name-class) &rest initargs)
(find-class 'conc-name-direct-slot-definition))
(defmethod initialize-instance :around ((sd conc-name-direct-slot-definition) &rest args &key name conc-name)
(let ((aname (slot-name-conc conc-name name))
(inst (call-next-method)))
(pushnew aname (slot-definition-readers sd) :test #'equal)
(pushnew `(setf ,aname) (slot-definition-writers sd) :test #'equal)
inst))
(defmethod ensure-class-using-class ((class conc-name-class) name
&rest initargs
&key (default-conc-name (concatenate 'string (string name) ".") default-conc-name-sup?)
direct-slots
&allow-other-keys)
(when default-conc-name-sup?
(setq default-conc-name (car default-conc-name)))
(apply #'call-next-method
class
name
:default-conc-name default-conc-name
:direct-slots (mapcar (lambda (s)
(if (getf s :conc-name)
s
(list* :conc-name default-conc-name s)))
direct-slots)
initargs))
解説すると、まずデフォルトのstandard-direct-slot-definition
をカスタマイズするために、conc-name-direct-slot-definition
を定義します。
conc-name-direct-slot-definition
の中では、指定された接頭辞をもとにアクセサ名を生成します。
スロット定義では、:conc-name
で接頭辞を指定しますが、スロット定義メタオブジェクトを生成する時のキーワード引数はdefclass
のスロットのキーワード引数が正規化されたものになりますので、単純に:conc-name
を追加しておけばOKです。
次に、このスロット定義を呼び出すために、direct-slot-definition-class
が返すクラスをconc-name-direct-slot-definition
に設定します。
direct-slot-definition-class
が返すクラスでスロット定義を生成するプロトコルなので、スロット定義のサブクラスを作ってカスタマイズしても、これに設定しないと有効にできません。
また、クラス定義の方で指定する接頭辞とスロットで指定する接頭辞を区別したいので、クラス定義の方は、default-conc-name
と変更します。
(defclass conc-name-class (standard-class)
((conc-name :initarg :default-conc-name :accessor class-conc-name)))
これでこんな感じに書けます
(defclass bar ()
((x :conc-name bar=)
(y :conc-name bar_)
(z :accessor z))
(:default-conc-name bar.)
(:metaclass conc-name-class))(let ((qqq (make-instance 'bar)))
(with-slots (x y z) qqq
(setq x 42 y 43 z 44))
(incf (bar.z qqq))
(list (bar=x qqq)
(bar_y qqq)
(bar.z qqq)))
→ (42 43 45)
スロットごとに接頭辞を付けて便利なことがあるかは不明ですが、スロット定義のプロトコルに従ったお蔭でおまけ的に別個に指定できたりします。
以上、マクロだけでの実現からMOP的なものまでを順に考えてきましたが、MOPの方は作法を憶えるのが面倒臭いです。
まあしかし、MOPの作法は一応標準化されていますので、俺マクロの使い方を憶えるよりは、ましだったりするかもしれません。
■
HTML generated by 3bmd in LispWorks 7.0.0