オブジェクトとクラス

クラスは振舞いを共有するオブジェクトのある集りを 表現するものです。クラスによって表現されたオブジェクトをそのクラスの インスタンスといいます。クラスはそのインスタンスがもつ スロットの名前を指定しますが、これらのスロットに特定の値を もたせるのはインスタンス次第です。クラスはそのインスタンスに適用する ことのできるメソッドも指定します。スロットの値はなんであっても かまいませんが、メソッドの値は手続きでなければなりません。

クラスは階層構造になります。したがって、ひとつのクラスは別のクラスの サブクラスになることができます。このとき、別のクラスのほうは スーパークラスといいます。サブクラスは自分自身の直接の スロットやメソッドをもつだけではなく、スーパークラスのすべての スロットやメソッドを継承します。クラスがスーパークラスのスロットや メソッドと同じ名前のスロットやメソッドをもつ場合にはサブクラスの スロットやメソッドがそのまま使われます。

12.1  単純なオブジェクトシステム

Scheme で基本的なオブジェクトシステムを実装してみましょう。 クラスひとつについてひとつだけスーパークラスが許されるよう にします(単一継承)。スーパークラスを指定したくなければ、 「ゼロ」(スロットもメソッドももたない)スーパークラスとして #t を使いましょう。#t のスーパークラスは自分自身だと看倣しましょう。

最初の近似として、standard-class と呼ぶ構造体を使ったクラスつかって、 スロット名、スーパクラス、メソッドのフィールドをもつクラスを定義して おくと便利です。最初の 2 つのフィールドをそれぞれ slotssuperclass と呼ぶことにしましょう。つぎに、メソッド用に2 つの フィールドを使いましょう。ひとつは、クラスのメソッドの名前のリストを 保持する method-names、もうひとつは、クラスメソッドの値をもつ ベクタを保持する method-vector です1standard-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-classsuspension というスロットを追加し、 メソッド check-fit のすこし別の定義を使います。

12.2  クラスはインスタンスでもある

賢明な読者なら、クラスそのものがなにかのクラス(メタクラス)の インスタンスになりうることを見逃がすことはないでしょう。 すべてのクラスはある共通の振舞いをします。それぞれのクラスは スロット、スーパクラス、メソッド名のリスト、メソッドベクタを 持っています。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 ...)

12.3  多重継承

クラスがふたつ以上のスーパクラスをもてるようオブジェクトシステムを 変更するのはたやすいことです。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-classclass-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-mapappendmap の合成です。

(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 理論上はメソッドを(たまたま その値が手続きであるような)スロットとして定義できるのですが、そうしない ちゃんとした理由があります。クラスのインスタンスはメソッドを 共有しますが、スロットの値はインスタンスごとに違うのが普通です。 いいかえれば、メソッドはクラスの定義に含めることができますし、 スロットのようにインスタンスごとにメモリにわりあてる必要がありません。