クラスは振舞いを共有するオブジェクトのある集りを 表現するものです。クラスによって表現されたオブジェクトをそのクラスの インスタンスといいます。クラスはそのインスタンスがもつ スロットの名前を指定しますが、これらのスロットに特定の値を もたせるのはインスタンス次第です。クラスはそのインスタンスに適用する ことのできるメソッドも指定します。スロットの値はなんであっても かまいませんが、メソッドの値は手続きでなければなりません。
クラスは階層構造になります。したがって、ひとつのクラスは別のクラスの サブクラスになることができます。このとき、別のクラスのほうは スーパークラスといいます。サブクラスは自分自身の直接の スロットやメソッドをもつだけではなく、スーパークラスのすべての スロットやメソッドを継承します。クラスがスーパークラスのスロットや メソッドと同じ名前のスロットやメソッドをもつ場合にはサブクラスの スロットやメソッドがそのまま使われます。
Scheme で基本的なオブジェクトシステムを実装してみましょう。
クラスひとつについてひとつだけスーパークラスが許されるよう
にします(単一継承)。スーパークラスを指定したくなければ、
「ゼロ」(スロットもメソッドももたない)スーパークラスとして #t
を使いましょう。#t
のスーパークラスは自分自身だと看倣しましょう。
最初の近似として、standard-class
と呼ぶ構造体を使ったクラスつかって、
スロット名、スーパクラス、メソッドのフィールドをもつクラスを定義して
おくと便利です。最初の 2 つのフィールドをそれぞれ slots
、
superclass
と呼ぶことにしましょう。つぎに、メソッド用に2 つの
フィールドを使いましょう。ひとつは、クラスのメソッドの名前のリストを
保持する method-names
、もうひとつは、クラスメソッドの値をもつ
ベクタを保持する method-vector
です1。
standard-class
の定義はこんなふうになります。
(defstruct standard-class slots superclass method-names method-vector)
make-standard-class
という standard-class
の作成手続きを
つかって、新しいクラスを作ることができます。
(define trivial-bike-class (make-standard-class 'superclass #t 'slots '(frame parts size) 'method-names '() 'method-vector #()))
これは、たいへんシンプルなクラスです。より複雑なクラスは
自明ではないスーパクラスやメソッドをもつことになるでしょう。
クラスの生成プロセスのなかに隠蔽したくなるような、標準的な初期化
部分がいろいろと必要になるでしょう。それ故、make-standard-class
を適切に呼ぶ create-class
というマクロを定義しましょう。
(define-macro create-class (lambda (superclass slots . methods) `(create-class-proc ,superclass (list ,@(map (lambda (slot) `',slot) slots)) (list ,@(map (lambda (method) `',(car method)) methods)) (vector ,@(map (lambda (method) `,(cadr method)) methods)))))
create-class-proc
手続きの定義はあとまわしにしましょう。
手続き make-instance
はこのクラス中で正式に記述されている情報に
もとづいて新しいベクタを生成することによってインスタンスを
作りだします。インスタンスベクタのフォーマットはたいへんシンプルな
ものです。最初の要素はクラスへの参照、のこりはスロットの値です。
make-instance
の引数はクラスとそれにつづく、2 つひとくみの
ならびです。それぞれのくみはスロット名とインスタンス中での値です。
(define make-instance (lambda (class . slot-value-twosomes) ;「クラス」中のスロットの数、n を探す。 ;長さ「n + 1」のインスタンスベクタを生成する。 ;インスタンスの中にクラスを含むもうひとつの要素が必要だから。 (let* ((slotlist (standard-class.slots class)) (n (length slotlist)) (instance (make-vector (+ n 1)))) (vector-set! instance 0 class) ;インスタンスの各スロットを「make-instance」の呼び出しで ;指定された値にする (let loop ((slot-value-twosomes slot-value-twosomes)) (if (null? slot-value-twosomes) instance (let ((k (list-position (car slot-value-twosomes) slotlist))) (vector-set! instance (+ k 1) (cadr slot-value-twosomes)) (loop (cddr slot-value-twosomes))))))))
次はクラスのインスタンス化の例です。
(define my-bike (make-instance trivial-bike-class 'frame 'cromoly 'size '18.5 'parts 'alivio))
これは my-bike
を次のインスタンスに束縛します。
#(<trivial-bike-class> cromoly 18.5 alivio)
ここで、<trivial-bike-class>
は Scheme のデータ
(もうひとつのベクタ)で、上で定義された trivial-bike-class
のデータ
です。
手続き class-of
はインスタンスのクラスを返します。
(define class-of (lambda (instance) (vector-ref instance 0)))
これは、class-of
の引数がクラスインスタンスであること、すなわち、
最初の要素が standard-class
のインスタンス化を指すようなベクタで
あることを仮定しています。
class-of
が、送りこんだあらゆる種類の Scheme のオブジェクトに関して
適切な値を返すようしたいとおもいます。
(define class-of (lambda (x) (if (vector? x) (let ((n (vector-length x))) (if (>= n 1) (let ((c (vector-ref x 0))) (if (standard-class? c) c #t)) #t)) #t)))
standard-class
を使用して作成されない Scheme オブジェクトの
クラスは、#t
、つまりゼロクラスと看倣します。
手続き、slot-value
および set!slot-value
はクラスインスタンスの
値にアクセスおよび値を変更します。
(define slot-value (lambda (instance slot) (let* ((class (class-of instance)) (slot-index (list-position slot (standard-class.slots class)))) (vector-ref instance (+ slot-index 1))))) (define set!slot-value (lambda (instance slot new-val) (let* ((class (class-of instance)) (slot-index (list-position slot (standard-class.slots class)))) (vector-set! instance (+ slot-index 1) new-val))))
これで、create-class-proc
の定義にとりかかる準備ができました。
このプロシージャは、スーパクラスとスロットのリスト、メソッド名のリスト、
メソッドのベクタを引数にとり、make-standard-class
を適切な方法で
呼び出します。唯一微妙な部分は、slots
フィールドにあたえられる
値です。create-class
を通じて供給されたスロット引数だけでは
ありません。そのスーパークラスのスロットも同様に含まれていなければ
なりません。スーパークラスのスロット用のスロットを連結しなければ
なりません。これによりスロットの複製をつくらずにすますことができます。
(define create-class-proc (lambda (superclass slots method-names method-vector) (make-standard-class 'superclass superclass 'slots (let ((superclass-slots (if (not (eqv? superclass #t)) (standard-class.slots superclass) '()))) (if (null? superclass-slots) slots (delete-duplicates (append slots superclass-slots)))) 'method-names method-names 'method-vector method-vector)))
手続き delete-duplicates
はリスト s
に対して呼び出され、
リスト s
の各要素の最後に現れたもののみを含む新しいリストを
返します。
(define delete-duplicates (lambda (s) (if (null? s) s (let ((a (car s)) (d (cdr s))) (if (memv a d) (delete-duplicates d) (cons a (delete-duplicates d)))))))
次にメソッドの適用にうつりましょう。手続き send
をつかって
インスタンス上のメソッドを呼び出します。send
の引数は、
メソッド名とインスタンスそのものに加えて、メソッドの引数です。
メソッドは、インスタンスそのものではなく、インスタンスのクラスに
格納されていますから、send
はインスタンスのクラスを検索して
当該のメソッドをみつけなければなりません。もし、メソッドが
そこになければ、そのクラスのスーパークラスのをを探し、さらに
その先のスーパークラスのチェーンを探します。
(define send (lambda (method instance . args) (let ((proc (let loop ((class (class-of instance))) (if (eqv? class #t) (error 'send) (let ((k (list-position method (standard-class.method-names class)))) (if k (vector-ref (standard-class.method-vector class) k) (loop (standard-class.superclass class)))))))) (apply proc instance args))))
さらに興味あるクラスをいくつか定義しましょう。
(define bike-class (create-class #t (frame size parts chain tires) (check-fit (lambda (me inseam) (let ((bike-size (slot-value me 'size)) (ideal-size (* inseam 3/5))) (let ((diff (- bike-size ideal-size))) (cond ((<= -1 diff 1) 'perfect-fit) ((<= -2 diff 2) 'fits-well) ((< diff -2) 'too-small) ((> diff 2) 'too-big))))))))
ここで、bike-class
には メソッド check-fit
が含まれて
います。これは、バイクとその寸法をとり、そのバイクと人の寸法との
適合性を報告します。
では my-bike
を再定義しましょう。
(define my-bike (make-instance bike-class 'frame 'titanium ; I wish 'size 21 'parts 'ultegra 'chain 'sachs 'tires 'continental))
これが、股下 32 の人にフィットするかどうかを確かめるには、 以下のようにします。
(send 'check-fit my-bike 32)
bike-class
のサブクラスも可能です。
(define mtn-bike-class (create-class bike-class (suspension) (check-fit (lambda (me inseam) (let ((bike-size (slot-value me 'size)) (ideal-size (- (* inseam 3/5) 2))) (let ((diff (- bike-size ideal-size))) (cond ((<= -2 diff 2) 'perfect-fit) ((<= -4 diff 4) 'fits-well) ((< diff -4) 'too-small) ((> diff 4) 'too-big))))))))
mtn-bike-class
は suspension
というスロットを追加し、
メソッド check-fit
のすこし別の定義を使います。
賢明な読者なら、クラスそのものがなにかのクラス(メタクラス)の
インスタンスになりうることを見逃がすことはないでしょう。
すべてのクラスはある共通の振舞いをします。それぞれのクラスは
スロット、スーパクラス、メソッド名のリスト、メソッドベクタを
持っています。make-instance
はこれらが共有しているメソッド
のように見えます。このことは、これらの共通した振舞いをもうひとつ
別のクラス(それ自身ももちろんそのクラスのインスタンス)をつかって
指定できることを示唆しています。
具体的には、「鶏が先か、卵が先か」の議論をしないという条件で
クラスの実装を書換えて、オブジェクト指向のアプローチを利用します。
ようするに、class
構造体とそれに付随する手続きというのを止め、
クラスをオブジェクトとして定義する機構の残りの部分に頼るようにする
ということです。
standard-class
を他のクラスがそのインスタンスであるような
クラスであるとしましょう。とくに、standard-class
はそれ自身の
インスタンスでなければなりません。standard-class
はどのようになって
いればよいでしょう。
standard-class
はひとつのインスタンスで、インスタンスは
ベクタで表現しています。それで、最初の要素がそのクラスつまり、
自分自身であるようなベクタとし、のこりの要素は、スロット値であるように
します。すべてのクラスは 4 つのスロットをもたなければならないとしました。
それで、standard-class
は 5 つの要素をもつベクタとします。
(define standard-class (vector 'value-of-standard-class-goes-here (list 'slots 'superclass 'method-names 'method-vector) #t '(make-instance) (vector make-instance)))
standard-class
ベクタはは完全に満されているベクタではないことに
注意してください。シンボル value-of-standard-class-goes-here
は
プレースホルダとして機能します。これで、standard-class
の値を定義
しましたので、これを自分自身のクラスとして使えます。
(vector-set! standard-class 0 standard-class)
もはや、クラス構造体上の手続きにたよることができないということに 注意してください。以下のすべてのフォームの呼び出しを
(standard-class? x) (standard-class.slots c) (standard-class.superclass c) (standard-class.method-names c) (standard-class.method-vector c) (make-standard-class ...)
以下に置き換えなければなりません。
(and (vector? x) (eqv? (vector-ref x 0) standard-class)) (vector-ref c 1) (vector-ref c 2) (vector-ref c 3) (vector-ref c 4) (send 'make-instance standard-class ...)
クラスがふたつ以上のスーパクラスをもてるようオブジェクトシステムを
変更するのはたやすいことです。superclass
のかわりに
class-precedence-list
をというスロットをもつように
standard-class
を再定義します。あるクラスの
class-precedence-list
はそのクラスのすべての
スーパクラスのリストです。create-class
によるクラスの生成時に
直接のスーパクラスとして指定されたものだけではありません。
この名前はスーパクラスがある順番でリストになっており、
前にあるスーパクラスは後にあるものよりも優先順位が高いことを
暗示している。
(define standard-class (vector 'value-of-standard-class-goes-here (list 'slots 'class-precedence-list 'method-names 'method-vector) '() '(make-instance) (vector make-instance)))
スロットのリストを新しいスロットを含むよう変更するだけではなく、
かつての superclass
スロットは #f
の代りに、()
となります。
これは、standard-class
の class-precedence-list
がリストで
なければならないからです。(#t)
とすることもできましたが、
各クラスの class-precedence-list
にあるので、ゼロクラスについて
言及するつもりはありません。
create-class
マクロは単一のスーパクラスのかわりに、直接の
スーパクラスのリストを受け入れるように変更する必要があります。
(define-macro create-class (lambda (direct-superclasses slots . methods) `(create-class-proc (list ,@(map (lambda (su) `,su) direct-superclasses)) (list ,@(map (lambda (slot) `',slot) slots)) (list ,@(map (lambda (method) `',(car method)) methods)) (vector ,@(map (lambda (method) `,(cadr method)) methods)) )))
create-class-proc
は与えられた直接のスーパクラスからクラスの優先
リストを、そのクラスの優先リストからスロットのリストを計算しなければ
なりません。
(define create-class-proc (lambda (direct-superclasses slots method-names method-vector) (let ((class-precedence-list (delete-duplicates (append-map (lambda (c) (vector-ref c 2)) direct-superclasses)))) (send 'make-instance standard-class 'class-precedence-list class-precedence-list 'slots (delete-duplicates (append slots (append-map (lambda (c) (vector-ref c 1)) class-precedence-list))) 'method-names method-names 'method-vector method-vector))))
手続き append-map
は append
と map
の合成です。
(define append-map (lambda (f s) (let loop ((s s)) (if (null? s) '() (append (f (car s)) (loop (cdr s)))))))
手続き send
はメソッドの在処を探すさいに、クラス優先リスト全体を
左から右へ探索する必要があります。
(define send (lambda (method-name instance . args) (let ((proc (let ((class (class-of instance))) (if (eqv? class #t) (error 'send) (let loop ((class class) (superclasses (vector-ref class 2))) (let ((k (list-position method-name (vector-ref class 3)))) (cond (k (vector-ref (vector-ref class 4) k)) ((null? superclasses) (error 'send)) (else (loop (car superclasses) (cdr superclasses)))) )))))) (apply proc instance args))))
1 理論上はメソッドを(たまたま その値が手続きであるような)スロットとして定義できるのですが、そうしない ちゃんとした理由があります。クラスのインスタンスはメソッドを 共有しますが、スロットの値はインスタンスごとに違うのが普通です。 いいかえれば、メソッドはクラスの定義に含めることができますし、 スロットのようにインスタンスごとにメモリにわりあてる必要がありません。