#:g1: MOPを活用するユーティリティを眺める(2): Moptilities

Posted 2013-12-21 06:30:00 GMT

(Metaobject Protocol(MOP) Advent Calendar 2013参加エントリ)

 Metaobject Protocol(MOP) Advent Calendar 2013 21日目です。
MOPを活用するユーティリティを眺めるの二回目。今回は、Moptilitiesを眺めてみたいと思います。

Moptilitiesとは

 Moptilities はGary King氏作のMOP系のユーティリティ集です。

Moptilitiesを眺める

 では、Moptilitiesを早速眺めていきましょう。
動作確認用にクラスを定義しておきます。

(defclass foo ()
  ((x :reader x)
   (y :writer y)
   (z :accessor z)))

(defclass bar (foo) (a b c))

get-class

(get-class 'standard-object)
;=>  #<STANDARD-CLASS STANDARD-OBJECT>

(get-class 'so)
;=>  NIL

 find-classとclass-ofを合体したような便利関数

finalize-class-if-necessary

 c2mop:class-finalized-pして必要時 c2mop:finalize-inheritance するという便利関数

superclasses

(superclasses 'standard-class)
;=>  (#<STANDARD-CLASS SB-PCL::STD-CLASS> #<STANDARD-CLASS SB-PCL::SLOT-CLASS>
;     #<STANDARD-CLASS SB-PCL::PCL-CLASS> #<STANDARD-CLASS CLASS>
;     #<STANDARD-CLASS SB-PCL::DEPENDENT-UPDATE-MIXIN>
;     #<STANDARD-CLASS SB-PCL::PLIST-MIXIN>
;     #<STANDARD-CLASS SB-PCL::DEFINITION-SOURCE-MIXIN>
;     #<STANDARD-CLASS SB-PCL::STANDARD-SPECIALIZER>
;     #<STANDARD-CLASS SB-MOP:SPECIALIZER> #<STANDARD-CLASS SB-MOP:METAOBJECT>
;     #<STANDARD-CLASS STANDARD-OBJECT> #<SB-PCL::SLOT-CLASS SB-PCL::SLOT-OBJECT>
;     #<BUILT-IN-CLASS T>)

 その名の通り、 superclass を列挙するもの

direct-superclasses

(direct-superclasses 'standard-class)
;=>  (#<STANDARD-CLASS SB-PCL::STD-CLASS>)

 その名の通り、direct-superclasses を列挙するもの

method-name

(method-name (find-method #'foo '() `(,(find-class 'list))))
;=>  FOO

 メソッドから総称関数の名前を取得するもの

get-method

(get-method #'foo '() 'list)
;=>  #<STANDARD-METHOD FOO (LIST) {10145845D3}>

 その名の通り、メソッドを取得するものですが、fboundpが関数を返す処理系でしか動きません。
fboundp name => generalized-boolean なのでOKではありますが、fdefinitionなら処理系依存でないので、こっちの方が好ましいような。
さらに、cl:standard-generic-function クラスが c2mop:standard-generic-function に差し替わっているのはOKなのでしょうか。バグなのかどうか。

remove-generic-function

(remove-generic-function 'foo)
;=>  FOO

 総称関数のメソッドを全部削除してからfmakunboundするというもの。 fmakunbound だけじゃ駄目なんですかね。駄目なんでしょう。

slot-names

(slot-names 'standard-generic-function)
;=>  (SB-PCL::SOURCE SB-PCL::PLIST SB-PCL::%DOCUMENTATION SB-PCL::INITIAL-METHODS
;     SB-PCL::NAME SB-PCL::METHODS SB-PCL::METHOD-CLASS SB-PCL::%METHOD-COMBINATION
;     SB-PCL::DECLARATIONS SB-PCL::ARG-INFO SB-PCL::DFUN-STATE SB-PCL::%LOCK
;     SB-PCL::INFO-NEEDS-UPDATE)

 その名の通り、スロット名一覧を所得

slot-properties

(slot-properties 'standard-generic-function 'SB-PCL::%LOCK)
;=>  (:NAME SB-PCL::%LOCK :INITARGS NIL :INITFORM
;     (SB-THREAD:MAKE-MUTEX :NAME "GF lock") :READERS (SB-PCL::GF-LOCK) :WRITERS NIL
;     :DOCUMENTATION "")

 指定したスロットの内容を取得

get-slot-definition

(get-slot-definition 'standard-generic-function 'SB-PCL::%LOCK)
;=>  #<SB-MOP:STANDARD-DIRECT-SLOT-DEFINITION SB-PCL::%LOCK>
;    NIL

 指定したスロットの定義を取得

direct-slot-names

(direct-slot-names 'standard-generic-function)
;=>  (SB-PCL::NAME SB-PCL::METHODS SB-PCL::METHOD-CLASS SB-PCL::%METHOD-COMBINATION
;     SB-PCL::DECLARATIONS SB-PCL::ARG-INFO SB-PCL::DFUN-STATE SB-PCL::%LOCK
;     SB-PCL::INFO-NEEDS-UPDATE)

 ダイレクトスロット一覧を取得

reader-method-p

(reader-method-p (get-method #'x '() 'foo))
;=>  T

(reader-method-p (get-method #'y '() t 'foo))
;=>  NIL

 リーダーメソッドかどうかを判定

writer-method-p

(writer-method-p (get-method #'x '() 'foo))
;=>  NIL

(writer-method-p (get-method #'y '() t 'foo))
;=>  T

 ライターメソッドかどうかを判定

map-methods

(map-methods 'foo (lambda (gf m) (print (method-name m))))
;>>  
;>>  (SETF Z) 
;>>  Z 
;>>  Y 
;>>  X 
;=>  NIL

 クラスに紐付いているメソッドに関数を適用。 CL系では、map系の名前で副作用目的なものもありなので要注意。

remove-methods

(remove-methods 'foo :dry-run? T)
;>>  #<STANDARD-WRITER-METHOD (SETF Z), slot:Z, (T FOO) {101E81AF63}>
;>>  #<STANDARD-READER-METHOD Z, slot:Z, (FOO) {101E896AC3}>
;>>  #<STANDARD-WRITER-METHOD Y, slot:Y, (T FOO) {101E81AF83}>
;>>  #<STANDARD-READER-METHOD X, slot:X, (FOO) {101E896AE3}>
;=>  4

 クラスに紐付いているメソッドを削除。 :dry-run? オプションで動作確認のみ

remove-methods-if

 任意の述語を取れる remove-methods の汎用版

(generic-functions 'standard-class)
;=>  (#<STANDARD-GENERIC-FUNCTION SB-PCL::STANDARD-CLASS-P (2)>
;     #<STANDARD-GENERIC-FUNCTION CHANGE-CLASS (7)>
;     #<STANDARD-GENERIC-FUNCTION ALLOCATE-INSTANCE (5)>
;     #<STANDARD-GENERIC-FUNCTION SB-PCL::WRAPPER-FETCHER (2)>
;     #<STANDARD-GENERIC-FUNCTION SB-PCL::SLOTS-FETCHER (2)>
;     #<STANDARD-GENERIC-FUNCTION SB-PCL::RAW-INSTANCE-ALLOCATOR (2)>
;     #<STANDARD-GENERIC-FUNCTION SB-MOP:COMPUTE-SLOTS (8)>
;     #<STANDARD-GENERIC-FUNCTION DOCUMENTATION (26)>
;     #<STANDARD-GENERIC-FUNCTION (SETF DOCUMENTATION) (23)>
;     #<STANDARD-GENERIC-FUNCTION SB-MOP:VALIDATE-SUPERCLASS (4)>
;     #<STANDARD-GENERIC-FUNCTION SWANK-BACKEND:EMACS-INSPECT (27)>)

 クラスに紐付いている総称関数を取得

direct-specializers-of

(direct-specializers-of 'standard-class)
;=>  (SWANK-BACKEND:EMACS-INSPECT SB-MOP:VALIDATE-SUPERCLASS (SETF DOCUMENTATION)
;                                 (SETF DOCUMENTATION) DOCUMENTATION DOCUMENTATION
;                                 SB-MOP:COMPUTE-SLOTS SB-MOP:COMPUTE-SLOTS
;                                 SB-PCL::RAW-INSTANCE-ALLOCATOR
;                                 SB-PCL::SLOTS-FETCHER SB-PCL::WRAPPER-FETCHER
;                                 ALLOCATE-INSTANCE CHANGE-CLASS CHANGE-CLASS
;                                 CHANGE-CLASS SB-PCL::STANDARD-CLASS-P)

 指定したクラスを引数で直接特定化しているメソッド一覧を取得

specializers-of

(specializers-of 'standard-class)
;=>  (SWANK-BACKEND:EMACS-INSPECT (SETF DOCUMENTATION) DOCUMENTATION
;                                 SB-MOP:COMPUTE-SLOTS
;                                 SB-PCL::RAW-INSTANCE-ALLOCATOR
;                                 SB-PCL::SLOTS-FETCHER SB-PCL::WRAPPER-FETCHER
...
  ...
    ...
;                                 (SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DFUN-STATE
;                                  SB-PCL::READER))

 指定したクラスを引数で特定化しているメソッド一覧を取得

map-subclasses

(map-subclasses 'standard-class #'identity)
;=>  (#<STANDARD-CLASS JSON:FLUID-CLASS>)

(map-subclasses 'standard-class (lambda (x) (print (class-name x))))
;>>  
;>>  STANDARD-CLASS 
;>>  JSON:FLUID-CLASS 
;=>  (#<STANDARD-CLASS JSON:FLUID-CLASS>)

 サブクラスをマップ処理するもの。あまり関係ないですが、mapcの返り値を使ってる関数を初めて見ました。

subclasses

(subclasses 'standard-generic-function)
;=>  (#<SB-MOP:FUNCALLABLE-STANDARD-CLASS C2MOP:STANDARD-GENERIC-FUNCTION>)

 その名の通りサブクラス一覧を取得

function-arglist

(function-arglist 'make-instance)
;=>  (CLASS &REST SB-PCL::INITARGS &ALLOW-OTHER-KEYS)

 関数の引数を取得。これは別にMOPに特化しているという訳でもないですが。

mopu-class-initargs

;;; LispWorksでの例
(mopu-class-initargs 'standard-class)
;=> (:METHOD-COMBINATION-OPTIONS :METHOD-COMBINATION :METHOD-CLASS :INITIAL-METHODS :DOCUMENTATION :DECLARATIONS :ARGUMENT-PRECEDENCE-ORDER :LAMBDA-LIST :NAME :DECLARATIONS)

 SBCLだと実装されていません

eql-specializer-p

(eql-specializer-p (c2mop:intern-eql-specializer 'x))
;=>  (EQL X)

 eql-specializerかどうかを判定。

default-initargs

(default-initargs 'standard-generic-function)
;=>  ((:METHOD-CLASS SB-PCL::*THE-CLASS-STANDARD-METHOD* #<FUNCTION # {10099DB2BB}>)
;     (:METHOD-COMBINATION SB-PCL::*STANDARD-METHOD-COMBINATION*
;      #<FUNCTION # {10099DB36B}>))

 class-direct-default-initargs と、 class-default-initargs を足したものを返す

leaf-class-p

(leaf-class-p 'bar)
;=>  T

 サブクラスがないクラスかどうかを判定

leaf-subclasses

(leaf-subclasses 'standard-generic-function)
;=>  (#<SB-MOP:FUNCALLABLE-STANDARD-CLASS C2MOP:STANDARD-GENERIC-FUNCTION>)

 サブクラスがないクラス一覧を取得

class-name-of

(class-name-of (find-class 'foo))
;=>  FOO

 class-of して class-name するもの

copy-template

(copy-template (get-class 'foo))
;=>  #<STANDARD-CLASS FOO>

 インスタンスをコピーしてテンプレートに使うというもの。

(make-graph (type-of old-graph)
            :vertex-test (vertex-test old-graph) 
            :vertex-key (vertex-key old-graph)
            :edge-test (edge-test old-graph)
            :edge-key (edge-key old-graph)
            :default-edge-type (default-edge-type old-graph)
            :default-edge-class (default-edge-class old-graph)
            :directed-edge-class (directed-edge-class old-graph)
            :undirected-edge-class (undirected-edge-class old-graph))

みたいな場合に便利よ、とのこと fare-mop:remake-object と同じものですね

*debugging-finalization*

 デバッグ時用の変数で、非nilにすると、ファイナライズ指定したオブジェクトの回収時にメッセージが *debug-io* に印字

care-when-finalized

(let ((*debugging-finalization* T)
      (x (make-instance 'standard-generic-function)))
  (care-when-finalized x)
  (setq x nil)
  (sb-ext:gc :full t))
;>> Finalized #<STANDARD-GENERIC-FUNCTION NIL (0) {1015226BDB}>
;=>  NIL

 MOP利用に限定されるものでもありませんが、オブジェクトをファイナライズ指定します。
SBCLだと sb-ext:finalize が取る引数の関数は、無引数なので修正の必要あり

ignore-finalization

 ファイナライズをキャンセル

まとめ

 今回はMetatilitiesを眺めてみました、
開発時に便利っぽい関数が結構ありますね。

comments powered by Disqus