Think Stitch
PRINCIPIA  最近の更新


Metaobject Protocol への階段

Metaobject Protocol (MOP) Advent Calendar 2013の参加エントリです.

Metaobject Protocol についての概念的な説明や,レベルの高いクールな応用については他の書き手の方々のすばらしい記事を読んでいただきたいと思います(とかいって,実は十分に理解できていなくて申し訳ないです...).この文書では基本に立ち返って,具体的に 0 からプログラムを書きながら Metaobject に迫ってみたいと思います.私自身 Metaobject や Metaobject Protocol が理解できているかどうか怪しいので,いつものように,理解の早道は実際にプログラムを書いてみることだと思い,奮闘した軌跡です.できるだけ贅沢な(?)部分を取り除いて,これだけはなくてはならないというものを積み重ねていくというアプローチで行きます.そうすればなぜそれが必要なのかよくわかると思ったからです.

処理系は Gauche を使います.

ステップ1. オブジェクト指向とディスパッチャ

まずとても単純なオブジェクト指向システムを作ることから始めます.オブジェクト指向システムなんていうと大げさですけど,ほんとに小さなものです.オブジェクト指向システムの必要最小限な概念や要素は何かという点についてはいろいろあるでしょうけど,オブジェクトは必要でしょう :P.オブジェクトはリストで表すことにします.

オブジェクトは最低1つのペアを持っていて,car にはクラスが入っているとします.より丁寧にいうとクラスオブジェクトへの参照が入っているというということです.cdr に何が入っているかということについては何も決めません.すべてクラスで決めると考えておきます.ほんとに最小限です.

(class . ?)

オブジェクトからクラスを取得する関数 class-of を定義しておきます.

(define (class-of object) (car object))

オブジェクトに何か仕事をしてもらうときには,メッセージを送ることにします.メッセージを送る構文を次のようにします.

(=> object selector arg ...)

やや古くさい感じですけど,手続き => がメッセージ送信の処理を担うとします.object はメッセージを受けるオブジェクトで,selector はメッセージの種類を表す識別子です.これをセレクタと呼ぶことにします.セレクタはシンボルで表すことにします.セレクタにつづいて,任意個数の引数をつづけることができるものとします.

(CLOS との比較でいうと,総称関数はなしでシングルメソッドということです.)

次にクラスを考えます.クラスに最小限必要なことは,メソッドを持つことだと考えました.そこでクラスの構造を次のようにします.

(#f method-alist)

method-alist はセレクタとメソッドの連想リストです.メソッド自体は次のようなクロージャで表すことにします.

(lambda (self arg ...) ...)

self はメッセージを受けたオブジェクトです.レシーバと呼ぶこともあります.

クラスは Lisp (Scheme) としてはもちろんオブジェクトですけど,オブジェクト指向システムとしてのオブジェクトにはなっていません.もしオブジェクトならクラスがあるはずですけど,それがないからです.car 部に #f を置いているのはそのための前準備といってもいいですけど,この段階では,単に method-alist の先頭にメソッドを追加するために,ペアがもう1つ必要だからというだけです.(だったら list じゃなくて cons でいいじゃないかと思う方もいるかもしれません.それは別の布石です.)

クラスの作成,メソッド連想リストの取り出し,メソッドの追加を行う手続きを定義します.セレクタの重複など,細かいことは気にしないでいきます.

(define (make-class) (list #f '()))

(define (%get-method-alist class) (cadr class))

(define (%add-method class selector method)
  (set-car! (cdr class)
            (cons (cons selector method)
                  (cadr class))))

次はメッセージ送信手続き => です.レシーバのクラスを取り出し,さらにメソッド連想リストを取り出します.セレクタで連想リストを引いて,もし対応するメソッドがあれば実行します.なければエラーにします.いずれの部分も構造についての知識を持っていて,直接利用しています.

(define (=> object selector . args)
  (let ((class (class-of object)))
    (let ((method-alist (%get-method-alist class)))
      (let ((p (assq selector method-alist)))
        (if p
            (apply (cdr p) object args)
            (error "no method" object selector args))))))

オブジェクト指向システムは以上です.スロット(インスタンス変数)もなければ継承もありません.

次のように,実際に動かしてみることができます.

(define BOX (make-class))

BOX
=> (#f ())

クラス作成直後はメソッドを持っていません.メソッドを追加してみます.

(%add-method BOX 'x (lambda (self) (cdr self)))
(%add-method BOX 'x! (lambda (self x) (set-cdr! self x)))

BOX
=> (#f ((x! . #<closure #f>) (x . #<closure #f>)))

メソッドが2つ追加されました.クラス BOX のインスタンスはペアの cdr 部に値を格納する能力を持っているとします.メッセージ x はその値を取り出します.メッセージ x! は値を更新します.

クラスのインスタンスを作るには専用の手続き make-BOX を用意する必要があります.インスタンスを作る能力を持つべきはクラスなので,クラスにメッセージを送ってインスタンスが作れるといいんですけど,残念ながらそれはできません.クラスはオブジェクト指向システムのオブジェクトではないので,メッセージを受け取る能力がないからです.代わりに make-BOX がオブジェクトの構造に関する知識を持っていて,インスタンスを作成します.

(define (make-BOX) (cons BOX 0))

(define box (make-BOX))

box
=> ((#f ((x! . #<closure #f>) (x . #<closure #f>))) . 0)

ちょっと見にくいですが,赤く色を付けた部分がクラス BOX です.その後ろが値で,初期値 0 が入っています.

実際にメッセージを送って見ることができます.

(=> box 'x)
=> 0

(=> box 'x! 271)
=> #<undef>

(=> box 'x)
=> 271

box
=> ((#f ((x! . #<closure #f>) (x . #<closure #f>))) . 271)

もう1つクラス POINT を作ってみます.こちらは cdr 部にリストを続けて,2つの値 x y を格納できるようにしています.

(define POINT (make-class))
(%add-method POINT 'x (lambda (self) (cadr self)))
(%add-method POINT 'y (lambda (self) (caddr self)))
(%add-method POINT 'x!
  (lambda (self x) (set-car! (cdr self) x)))
(%add-method POINT 'y!
  (lambda (self y) (set-car! (cddr self) y)))

(define (make-POINT x y) (list POINT x y))

(define pt (make-POINT 1 2))

(=> pt 'x)
=> 1

(=> pt 'y)
=> 2

(=> pt 'x! 314)
(=> pt 'x)
=> 314

BOX の例と POINT の例を見比べると,同じメッセージ x に対してそれぞれのオブジェクトが異なるメソッドを実行しています.したがってメッセージの呼び出し手は,オブジェクトの知識を持つ必要がありません.常識的なことをぐだぐだと書いて申し訳ないですが,この単純な実行時ディスパッチのしくみのおかげで,関心やドメインの知識,あるいは時間とともに要求が変化する速度の大きく異なる部分を分離できるわけです.

ステップ2. メタオブジェクトとインスタンスの生成

次にやりたいことは,make-BOX などのコンストラクタに漏れ出てしまっているオブジェクトの内部構造に関する知識を,クラスの中に隠すことです.そうすれば,オブジェクトの生成に関しても分離のしくみを利用できるようになります.

別の角度からいうと,やりたいことは次のような関数でインスタンスを生成できるようにすることです.

(define (make-instance class)
  (=> class 'new))

つまり,クラスにメッセージを送ることでインスタンスが作れるようにしたいということです.ちょっと贅沢をすると,初期化等の情報を渡したいので,引数を取れるようにしたいところです.

(define (make-instance class . args)
  (apply => class 'new args))

実際にこの関数を作ってもいいのですが,以下ではしくみがよく見えるようにメッセージ送信そのままで書くことにします.

まず始めにやらなければならないことは,クラスをオブジェクト指向システムのオブジェクトにすることです.そのためにはクラスオブジェクトのクラス,クラスオブジェクトをインスタンスとするようなクラスが必要です.これをメタクラスと呼ぶことにします(ほんと,ぐだぐだすみません).

すると,最低限のクラスの構造は次のようになります.

(metaclass method-alist)

この構造を作れるように make-class を変えます.

(define (make-class metaclass) (list metaclass '()))

ちょっと横道にそれますが,初期化等でよく使う交代リストのアクセサを用意しておきます.

(define (getl plist indicator default)
  (let loop ((xs plist))
    (cond ((null? xs) default)
          ((eq? (car xs) indicator)
           (cadr xs))
          (else
           (loop (cddr xs))))))

では実際にメタクラスを作ってみます.POINT クラスのメタクラス POINT-CLASS を作ります.

(define POINT-CLASS (list #f '()))

メタクラス自体はオブジェクトではないので,直接作りました.いわばブートストラップ部分です.つづいてメソッドを追加します.インスタンス生成のためのメソッドを new とします.

(%add-method POINT-CLASS 'new
  (lambda (self . args)
    (list self
          (getl args 'x 0)
          (getl args 'y 0))))

クラス POINT のインスタンスは2つの値 x y をリストとして持ちます.初期値はメッセージ new の引数で指定できるようにしています.

ちょっとややこしくなってきました.POINT クラスのインスタンスを生成するときには,クラスオブジェクト POINT に new メッセージを送るわけです.レシーバが POINT クラスですから,それに対応するメソッドを持っているのは POINT-CLASS ということになります.

混乱を避けるために,言葉の使い方を決めておきたいと思います.オブジェクト x がメッセージ msg を受け取って処理できるとき,「オブジェクト x はメッセージ msg に応答する」ということにします.メッセージ msg に対応するメソッドは,オブジェクト x のクラス C の中に格納されています.このことを「クラス C は(メッセージ msg に対応する)メソッドを持っている」ということにします.上の例でいうと,POINT は new に応答します.new に対応するメソッドを持っているのは POINT-CLASS です.

話を戻して,次にクラス POINT を作ります.make-class にメタクラス POINT-CLASS を渡します.

(define POINT (make-class POINT-CLASS))

(%add-method POINT 'x (lambda (self) (cadr self)))
(%add-method POINT 'y (lambda (self) (caddr self)))
(%add-method POINT 'x!
  (lambda (self x) (set-car! (cdr self) x)))
(%add-method POINT 'y!
  (lambda (self y) (set-car! (cddr self) y)))

以上より,次のようにクラス POINT にメッセージを送ることでインスタンスを生成することができるようになりました.初期値を指定することもできます.

(define pt1 (=> POINT 'new))
(define pt2 (=> POINT 'new 'x 1 'y 2))
(=> pt1 'x) => 0
(=> pt1 'y) => 0
(=> pt2 'x) => 1
(=> pt2 'y) => 2
(=> pt1 'x! 314)
(=> pt1 'x) => 314

ステップ3. メタメタクラスとクラスの生成

次にやりたいことは,make-class もインスタンス生成と同じしくみにすることでしょう.

(make-class metaclass arg ...)
=>
(make-instance metaclass arg ...)
=>
(=> metaclass 'new arg ...))

そのためにはメタクラスのクラスが必要になります.これをメタメタクラスと呼ぶことにします.ここではメタメタクラスの1つとして METACLASS を作ることにします.名前で混乱しますけど,例えばクラス POINT のように,一般にクラスの名前はインスタンスの種類を表すので,メタメタクラスの名前は METACLASS になるわけです(異なる流儀はあるでしょうけど).METACLASS をブートストラップ(?)します.

(define METACLASS (list #f '()))

次に METACLASS からメタクラス POINT-CLASS を生成します.やりたいことはこれです.

(define POINT-CLASS (=> METACLASS 'new))

しかしこれは動きません.メッセージ new に対応するメソッドを用意していないからではなく,new を処理するには METACLASS のクラスが必要になるからです.

これを解決する1つの方法はすぐに思いつきますね(笑).メタメタメタクラスを用意することです.:P

(define METAMETACLASS (list #f '()))

(%add-method METAMETACLASS 'new
  (lambda (self . args) (list self '())))

さらに METALCLASS も作ります.

(define METACLASS (list METAMETACLASS '()))

(%add-method METACLASS 'new
  (lambda (self . args) (list self '())))

すると次のように望み通りメッセージ new でメタクラス POINT-CLASS を作ることができます.

(define POINT-CLASS (=> METACLASS 'new))

メタの階層が高く(深く?)なって,さらにややこしくなってきました.ところで METACLASS と METAMETACLASS を見比べてみると,is-a 関係を除けば構造もメソッドも同じです.そこで次のようなもう1つの解決案があります.

(define METACLASS (list #f '()))

(set-car! METACLASS METACLASS)

(%add-method METACLASS 'new
  (lambda (self . args) (list self '())))

METAMETACLASS を作る代わりに,METACLASS のクラスを自分自身にしてしまうのです.これでもうまく動かすことができます.Smalltalk のように,複数のクラス間で循環させることもできるかもしれません.

ステップ4. スロット定義のできるクラスを作る

一般のオブジェクト指向システムでは,クラスを定義するときにスロット(インスタンス変数)を定義できるのがふつうだと思います.この「スロットを定義する」こと自体をメタクラスの定義で実現できるのかどうかやってみたいと思います.

メッセージ送信手続き => の改変

ここまで作ってきたオブジェクト指向システムではクラスの構造が固定されているので,そのままではスロット定義を追加することができません.METACLASS のようにもっともプリミティブな組み込みのクラスについては構造を決めなければなりませんが,それ以外についてはもっと自由度を高める必要があります.そこでシステムの動き自体をメッセージ送信で処理するようにして,カスタマイズできるようにします.

そのためにはメッセージ送信の手続き => を変える必要があります.いまの定義ではクラス構造に直接依存しているからです.そこでメッセージ送信の処理を次のように変えます.

(define (=> object selector . args)
  (let ((class (class-of object)))
    (=> class 'invoke-method object selector args)))

オブジェクトに送られたメッセージをどう処理するかを,そのクラスに任せてしまうわけです.またずいぶんと単純かつ極端に舵を切ったという感じですが,少しプロトコルっぽくなりました.

しかし残念ながらこれは動きません.なぜなら送られたメッセージはどんどんメタ階層の上へ上へと送られてしまうからです.もし METAMETACLASS の時のように最上位のクラスがある場合にはエラーになりますし,循環させている場合は無限ループになってしまいます.

プロトコルを細かくわけても問題は解決しないだろうと思います.例えば,まずセレクタに対応するメソッドだけを返してもらえるにクラスにお願いするとします.このメッセージを get-method とすると,やはり次のようになるからです.

(=> object 'msg arg ...)
=>
(=> class 'get-method object 'msg ...)
=>
(=> metaclass 'get-method class 'get-method ...)
=>
(=> metametaclass 'get-method metaclass 'get-method ...)
=> ...

そこで次のように考えます.まずメタ階層に最上位のクラスがあると仮定します.これを X としましょう. X は組み込みの基礎クラスなので,構造を決めなければなりません.これをここまでと同じように (? method-alist) としてみます.? については保留にしておきます.

最上位のクラス X のインスタンスもクラスでなければならず,その構造を固定しなければなりません.これについても上で見ました.2つの階層がないとコンストラクタが作れないからです(Smalltalk 流は考えないことにしておきます).そこで,この構造も (X method-alist) としておきます.

いま X のインスタンス C にメッセージが送られた場合を考えると,次のようになります.

(=> C 'msg arg ...)
=>
(=> X 'invoke-method C 'msg (arg ...))
=>
(=> ? 'invoke-method X 'invoke-method (C 'msg (arg ...)))

最後の式は実行できません.そこで1つ手前で止める必要があります.そこで X に invoke-method が送られて来たら,X は 指定されたセレクタに対応するメソッドを選択して C に適用することにします.基礎構造と同じようにここだけ処理を固定するということです.この手続きを invoke-method とします.するとメッセージ送信の手続き => は次のようにできます.

(define (=> object selector . args)
  (if (and (eq? object X) ; ★
           (eq? selector 'invoke-method))
      (invoke-method object
                     (car args) (cadr args) (caddr args))
      (let ((class (class-of object)))
        (=> class 'invoke-method object selector args))))

手続き invoke-method は次のようになります.以前の => とほぼ同じです.

(define (invoke-method class object selector args)
  (let ((p (assq selector (cadr class))))
    (if p
        (apply (cdr p) object args)
        (error "no method" selector object args))))

次に X のインスタンス C を生成する場合を考えます.これは X にメッセージ new を送ることになります. その処理は X の親がすることになりますが,X は最上位ですから循環させる必要があるということになります.

残る問題は,階層が何層必要かということです.これは抽象度をどれだけ高めるかということと関係するのだと思いますが,ここではあとでわかるように5階層(最下層のオブジェクト層を含む)あれば十分です.したがって最上位のクラス X の名前は METAMETACLASS とします.手続き invoke-method の★部分を METAMETACLASS に置き換えておきます.

メソッド定義 add-method のメッセージ化

クラスの構造を変えられるようにするので,メソッドの持ち方も変わる可能性があります.したがってメソッドの追加手続き %add-method も一般化する必要があります.make-instance のときと同じように,メッセージ送信にすればいいということです.

(define (add-method class selector method)
  (=> class 'add-method selector method))

これについても実際に関数を定義するのではなく,メッセージ式をそのまま使うことにします.手続き => と異なり,メソッドの追加では最上位のクラス METAMETACLASS にメソッドを追加するときだけ特別扱いをすれば済むので,無限後退切断のための(基底処理のための)場合分けは必要ありません.

スロットを持つオブジェクトとクラスの構造

スロットを定義できるクラスを作るということは,それをメタクラスで規定するということになります.そこでメタクラスを SLOT-CLASS とします.SLOT-CLASS のインスタンスであるクラスと,そのインスタンスであるオブジェクトの構造を決める必要があります.念のためいっておくと,これはメタクラス SLOT-CLASS が決めるということです.別のメタクラスを作れば,別の構造でスロットを実現できるということで,オブジェクト指向システム自体が固定のスロット構造を決めるということではありません.そういう試みです.

オブジェクトとクラスの構造を次のように決めます.

object = (class . slot-alist)
slot-alist = ((slot-name-symbol . value) ...)
class = (SLOT-CLASS method-alist slots)
slots = (slot-name-symbol ...)

オブジェクトを作るのはクラスで,(=> class 'new arg ...) として作ります.このメソッドを持っているのは class のクラスですから SLOT-CLASS です.

上の構造のクラス class を作るのはメタクラス SLOT-CLASS で,次のようにできるとします.

(=> SLOT-CLASS 'new 'slots '(x y))

インスタンス作成メッセージ new の引数でスロットの名前リストを指定できるようにします.これを処理するのは SLOT-CLASS のクラスですからメタメタクラスということになります.このメタメタクラスはスロット定義を持ったクラスの構造を知っているわけですから,スロット定義に関するクラス群の一部になります.そこでその名前を SLOT-METACLASS とします.SLOT-METACLASS のクラスはスロット定義とは関係しませんから,それが最上位になります.したがって5階層必要だというわけです.

METAMETACLASS

では順番にクラスを定義していきます.まず METAMETACLASS です.最上位のクラスとして循環させます.

(define METAMETACLASS (list #f '()))

(set-car! METAMETACLASS METAMETACLASS)

(%add-method METAMETACLASS 'add-method %add-method)

(=> METAMETACLASS 'add-method
    'new
    (lambda (self . args)
      (list self '())))

(=> METAMETACLASS 'add-method 'invoke-method invoke-method)

最初のメソッド add-method だけは %add-method を使って追加します.そうするとあとは add-method メッセージが使えるようになります.

METAMETACLASS は固定された基礎クラス構造のインスタンスを生成します.メソッドの追加と起動も構造に基づいたものになります.ここで invoke-method が必要なのは不思議かもしれませんがあとでわかります.

SLOT-METACLASS

メタメタクラス SLOT-METACLASS を定義します.このクラス自体の構造は固定された基礎構造と同じで,生成するインスタンスはスロットを持つ構造になります.メソッド new では引数からスロット指定を取り出しています.

構造は異なりますが,method-alist の位置が同じなので,%add-method と invoke-method が流用できます.:P

(define SLOT-METACLASS
  (=> METAMETACLASS 'new))

(=> SLOT-METACLASS 'add-method 'add-method %add-method)
(=> SLOT-METACLASS 'add-method 'invoke-method invoke-method)
(=> SLOT-METACLASS 'add-method
    'new
    (lambda (self . args)
      (list self
            (list
             (cons 'ref
                   (lambda (self slot)
                     (cdr (assq slot (cdr self)))))
             (cons 'set!
                   (lambda (self slot val)
                     (set-cdr! (assq slot (cdr self)) val))))
            (getl args 'slots '()))))

生成するクラスにはスロットのアクセサをあらかじめ登録しておくようにしました.継承がないので,メソッドは各クラスが自分のコピーを持たなければなりません.しかし生成時に自動登録されるので,いちいち add-method せずに済みます.

SLOT-CLASS

メタクラス SLOT-CLASS を定義します.SLOT-CLASS は自分で決めた構造の知識を持っていますから,直接インスタンスの中をのぞき見ます.new メソッドではスロット定義を取り出して,初期値と合わせて連想リストを作り,オブジェクトとします.

(define SLOT-CLASS
  (=> SLOT-METACLASS 'new))

(=> SLOT-CLASS 'add-method 'add-method %add-method)
(=> SLOT-CLASS 'add-method 'invoke-method invoke-method)
(=> SLOT-CLASS 'add-method
    'new
    (lambda (self . args)
      (cons self
            (map (lambda (slot) (cons slot (getl args slot #f)))
                 (caddr self)))))

METAMETACLASS で invoke-method を定義したわけはここにあります.SLOT-CLASS に add-method を送ったときの処理は次のようになるからです.

(=> SLOT-CLASS 'add-method ...)
=>
(=> SLOT-METACLASS 'invoke-method SLOT-CLASS 'add-method ...)
=>
(=> METAMETACLASS 'invoke-method SLOT-METACLASS 'invoke-method ...)

実行例

2つのスロット x y を持つクラス POINT を定義してみます.move メソッドも作ってみました.

(define POINT (=> SLOT-CLASS 'new 'slots '(x y)))

(=> POINT 'add-method
    'move
    (lambda (self dx dy)
      (=> self 'set! 'x (+ (=> self 'ref 'x) dx))
      (=> self 'set! 'y (+ (=> self 'ref 'y) dy))
      self))

(define pt (=> POINT 'new 'x 1 'y 2))

(cdr pt) => ((x . 1) (y . 2))
(=> pt 'ref 'x) => 1
(=> pt 'ref 'y) => 2
(=> pt 'set! 'x -2)
(=> pt 'ref 'x) => -2
(cdr pt) => ((x . -2) (y . 2))
(=> pt 'set! 'y 3)
(=> pt 'ref 'y) => 3
(cdr pt) => ((x . -2) (y . 3))
(=> pt 'move 10 20)
(=> pt 'ref 'x) => 8
(=> pt 'ref 'y) => 23
(cdr pt) => ((x . 8) (y . 23))

ステップ5. 継承を実現する

次はとうぜん継承ということになります.継承機構を持っていないオブジェクト指向システムに MOP で継承を実現するというわけです.(そういう認識で正しいのかどうか,ちょっと自信がないんですけど...そもそもメタクラス階層の継承を使ってカスタマイズできるというところが中心なら)

やりたいことは次の3つです.

これを可能にするクラスを定義するメタクラスを INHERITABLE-CLASS とします.次のような感じでクラスが定義できるようにしたいということです.

(define COLOR-POINT
  (=> INHERITABLE-CLASS 'new 'superclass POINT 'slots '(color))

クラスとオブジェクトの構造

メタクラス INHERITABLE-CLASS が定めるクラスの構造を次のようにします.

(INHERITABLE-CLASS method-alist slots superclass)

スロット定義については前と同じにします.したがってオブジェクトの構造も同じです.

(class . slot-alist)

INHERITABLE-METACLASS

スロット定義の時と同様に,メタメタクラスが必要になります.

(define INHERITABLE-METACLASS (=> METAMETACLASS 'new))

(=> INHERITABLE-METACLASS 'add-method 'add-method %add-method)
(=> INHERITABLE-METACLASS 'add-method 'invoke-method invoke-method)
(=> INHERITABLE-METACLASS 'add-method
    'new
    (lambda (self . args)
      (list self
            '()
            (getl args 'slots '())
            (getl args 'superclass #f))))

メッセージ new で指定されたスロットとスーパークラスを格納します.

INHERITABLE-CLASS

次はメタクラス INHERITABLE-CLASS の定義です.

(define INHERITABLE-CLASS (=> INHERITABLE-METACLASS 'new))

(=> INHERITABLE-CLASS 'add-method 'add-method %add-method)

オブジェクトの生成では,関数 collect-slots を使ってスーパークラスのスロット定義を集めてきます.

(=> INHERITABLE-CLASS 'add-method
    'new
    (lambda (self . args)
      (cons self
            (map (lambda (slot) (cons slot (getl args slot #f)))
                 (collect-slots self)))))

関数 collect-slots はクラスの構造について知識を持っていて,直接中身にアクセスするとします.スロット名の重複は気にしないでおきます.

(define (collect-slots class)
  (if class
      (append (caddr class)
              (collect-slots (cadddr class)))
      '()))

次は invoke-method です.指定されたセレクタに対応するメソッドを,継承関係をたどって探します.

(=> INHERITABLE-CLASS 'add-method
    'invoke-method
    (lambda (self object selector args)
      (let loop ((class self))
        (if class
            (let ((method-alist (cadr class))) ; ★
              (let ((p (assq selector method-alist)))
                (if p
                    (apply (cdr p) object args)
                    (loop (cadddr class))))) ; ★
            (error "no method" object selector args)))))

ここでもクラスの構造を直接触っています.実際には,スーパークラスが INHERITABLE-CLASS のインスタンスであるとは限らないので,★ の部分は問題がありますけど,他に継承をサポートするメタクラスがないとしておきます.

実行例

クラス POINT と,それを継承したクラス COLOR-POINT を作ります.

(define POINT
  (=> INHERITABLE-CLASS 'new 'slots '(x y)))

(=> POINT 'add-method 'x
  (lambda (self) (cdr (assq 'x (cdr self)))))
(=> POINT 'add-method 'y
  (lambda (self) (cdr (assq 'y (cdr self)))))
(=> POINT 'add-method 'x!
  (lambda (self v) (set-cdr! (assq 'x (cdr self)) v)))
(=> POINT 'add-method 'y!
  (lambda (self v) (set-cdr! (assq 'y (cdr self)) v)))

(define COLOR-POINT
  (=> INHERITABLE-CLASS 'new
        'superclass POINT
        'slots '(color)))

(=> COLOR-POINT 'add-method 'color
  (lambda (self) (cdr (assq 'color (cdr self)))))
(=> COLOR-POINT 'add-method 'color!
  (lambda (self v) (set-cdr! (assq 'color (cdr self)) v)))

(define pt (=> POINT 'new 'x 1 'y 2))

(=> pt 'x) => 1
(=> pt 'y) => 2
(=> pt 'x! 3)
(=> pt 'y! 4)
(=> pt 'x) => 3
(=> pt 'y) => 4

(define cpt (=> COLOR-POINT 'new 'x 5 'y 6 'color 'green))

(=> cpt 'x) => 5
(=> cpt 'y) => 6
(=> cpt 'color) => green
(=> cpt 'x! 7)
(=> cpt 'y! 8)
(=> cpt 'color! 'red)
(=> cpt 'x) => 7
(=> cpt 'y) => 8
(=> cpt 'color) => red

メソッド,スレッドともに継承されています.スロットは作成されているというだけで,アクセスはちょっとずるいですけどね.

ステップ6. 異なる継承メタクラスを混ぜて使う

INHERITABLE-CLASS の collect-slots や invoke-method では継承ルート上にあるすべてのクラスが INHERITABLE-CLASS のインスタンスであると仮定している点に問題がありました.これを解決したいと思います.

やりたいことは次のようなことです.継承をサポートするメタクラスが INHERITABLE-CLASS とは別にもう1つあるとします.これを INHERITABLE-CLASS2 とします.それぞれのインスタンスであるクラスをお互い継承できるようにしたいということです.

(define A
  (=> INHERITABLE-CLASS 'new 'slots '(x)))
(define B
  (=> INHERITABLE-CLASS2 'new 'superclass A 'slots '(y)))
(define C
  (=> INHERITABLE-CLASS 'new 'superclass B 'slots '(z)))

しかし実際には INHERITABLE-CLASS のメソッドがクラス構造に依存しているのでそのままでは動きません.これを解決するということです.うまくいくことを確認するために,やや作為的でつまらない例ではありますが,INHERITABLE-CLASS2 が決める構造を,次のように,superclass と slots を入れ替えたものだとします.

INHERITABLE-CLASS:  (metaclass method-alist slots superclass)
INHERITABLE-CLASS2: (metaclass method-alist superclass slots)

INHERITABLE-METACLASS(2)

まずメタメタクラスを定義します.INHERITABLE-METACLASS2 では superclass と slots の順序が逆です.

(define INHERITABLE-METACLASS (=> METAMETACLASS 'new))

(=> INHERITABLE-METACLASS 'add-method 'add-method %add-method)
(=> INHERITABLE-METACLASS 'add-method 'invoke-method invoke-method)
(=> INHERITABLE-METACLASS 'add-method
    'new
    (lambda (self . args)
      (list self
            '()
            (getl args 'slots '())
            (getl args 'superclass #f))))
(define INHERITABLE-METACLASS2 (=> METAMETACLASS 'new))

(=> INHERITABLE-METACLASS2 'add-method 'add-method %add-method)
(=> INHERITABLE-METACLASS2 'add-method 'invoke-method invoke-method)
(=> INHERITABLE-METACLASS2 'add-method
    'new
    (lambda (self . args)
      (list self
            '()
            (getl args 'superclass #f)
            (getl args 'slots '()))))

クラスプロトコル

継承階層をたどったときに,異なるメタクラスから生成されたクラスが混在している可能性に対処するために,新たに次のクラスプロトコルを追加します.

これらを使うと,invoke-method を次のように構造に依存しない形で書き直すことができます.

(define (invoke-method-for-inheritable-class
           class object selector args)
  (let loop ((class class))
    (if class
        (let ((method
               (=> class 'get-method object selector args)))
          (if method
              (apply method object args)
              (loop (=> class 'superclass))))
        (error "no method" object selector args))))

関数 collect-slots もクラスプロトコルを使うように書き換えます.

(define (collect-slots class)
  (if class
      (append (=> class 'slots)
              (collect-slots (=> class 'superclass)))
      '()))

new メソッドはクラスプロトコルのおかげで同じになります.

(define (make-instance-for-inheritable-class class . args)
  (cons class
        (map (lambda (slot) (cons slot (getl args slot #f)))
             (collect-slots class))))

メソッドの格納方法は共通なので,関数 get-method を定義しておいて共用します.

(define (get-method class object selector args)
  (let ((method-alist (cadr class)))
    (let ((p (assq selector method-alist)))
      (and p (cdr p)))))

INHERITABLE-CLASS(2)

違いがわかるように,対応する項目を並べて定義します.

(define INHERITABLE-CLASS  (=> INHERITABLE-METACLASS 'new))
(define INHERITABLE-CLASS2 (=> INHERITABLE-METACLASS2 'new))

(=> INHERITABLE-CLASS  'add-method 'add-method %add-method)
(=> INHERITABLE-CLASS2 'add-method 'add-method %add-method)

(=> INHERITABLE-CLASS  'add-method
  'invoke-method invoke-method-for-inheritable-class)
(=> INHERITABLE-CLASS2 'add-method
  'invoke-method invoke-method-for-inheritable-class)

(=> INHERITABLE-CLASS  'add-method 'get-method get-method)
(=> INHERITABLE-CLASS2 'add-method 'get-method get-method)

(=> INHERITABLE-CLASS  'add-method
  'new make-instance-for-inheritable-class)
(=> INHERITABLE-CLASS2 'add-method
  'new make-instance-for-inheritable-class)

(=> INHERITABLE-CLASS  'add-method
  'superclass (lambda (self) (cadddr self)))
(=> INHERITABLE-CLASS2 'add-method
  'superclass (lambda (self) (caddr self)))

(=> INHERITABLE-CLASS  'add-method
  'slots (lambda (self) (caddr self)))
(=> INHERITABLE-CLASS2 'add-method
  'slots (lambda (self) (cadddr self)))

実行例

(define A
  (=> INHERITABLE-CLASS 'new 'slots '(x)))
(=> A 'add-method
  'x (lambda (self) (cdr (assq 'x (cdr self)))))

(define B
  (=> INHERITABLE-CLASS2 'new 'superclass A 'slots '(y)))
(=> B 'add-method
  'y (lambda (self) (cdr (assq 'y (cdr self)))))

(define C
  (=> INHERITABLE-CLASS 'new 'superclass B 'slots '(z)))
(=> C 'add-method
  'z (lambda (self) (cdr (assq 'z (cdr self)))))

(define a (=> A 'new 'x 1))
(=> a 'x) => 1

(define b (=> B 'new 'x 2 'y 3))
(=> b 'x) => 2
(=> b 'y) => 3

(define c (=> C 'new 'x 4 'y 5 'z 6))
(=> c 'x) => 4
(=> c 'y) => 5
(=> c 'z) => 6

まとめと補足

Metaobject Protocol のおいしいところにたどり着く前に力つきた感がありますが,長くなったのでここまでとさせてください.基本的なところから実際に動かしながら機能を実現していったので,以前よりはだいぶわかったような気がします.それでもちょっと油断するとどのクラスで何をすればいいのか混乱しますけど.

継承については最初からしくみを入れた方がたぶんわかりやすいのだと思います.今回はあとから継承を実現できるのかどうか実験してみたかったので,ややこしいことになってしまいました.そもそも継承がないのに MOP かという話もありますが.メタメタクラスで作ったメタクラス継承でカスタマイズすれば MOP ですよね.:P 実際は様々な選択肢の中からある道を1つ(しかもややこしい道を)選んだというだけなのかもしれません.

やり残しとしては次のようなものがあると思います.

Tiny CLOS を拡張する方がずっと有用だとは思いますけど :P

2013/12/14
© 2013,2014,2015 PRINCIPIA Limited