#:g1: MOP vs マクロ (3)

Posted 2019-02-03 20:45:41 GMT

前回は、全面的なマクロから、ensure-classを使って若干のMOP利用へと進めましたが、今回は、ensure-class-using-classを利用して、もう一歩進めてみたいと思います。

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的でない?

しかし、上記のコードを眺めると判るように前回とさして変化ありません。
アクセサの名前に接頭辞を付けるのだから、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

comments powered by Disqus