Scheme:TinyCLOS

Scheme:TinyCLOS

Tiny CLOS

参考


tinyclos.tgzを引っ張って来て読んでみよう。
コードは tiny-clos.scm がわずか 869 行だ。 その内、30%がコメント行で実質 609 行しかないんだ。読むしかあるまい。

support.scm は汎用的な utility が定義されているファイルなので無視。 ざっと見た感じではトポロジカルソート位は見ることになりそうだけど、 基本的には tiny-clos.scm を中心に読んでみましょう。

ある程度整理したいので、コメントや指摘事項などは末尾にお願いします。



ライセンスなど

一応ざっとライセンス条項に目を通す。 いわゆるフリーなコードである。 最後のはtiny-closのバージョンとEmacsのためのインデント用なので本筋には関係なし。

; Mode: Scheme
;
;
; **********************************************************************
; Copyright (c) 1992 Xerox Corporation.  
; All Rights Reserved.  
;
; Use, reproduction, and preparation of derivative works are permitted.
; Any copy of this software or of any derivative work must include the
; above copyright notice of Xerox Corporation, this paragraph and the
; one after it.  Any distribution of this software or derivative works
; must comply with all applicable United States export control laws.
;
; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS
; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE
; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY
; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS
; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING
; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED
; OF THE POSSIBILITY OF SUCH DAMAGES.
; **********************************************************************
;
; EDIT HISTORY:
;
;      10/**/92  Gregor  Originally Written
; 1.0  11/10/92  Gregor  Changed names of generic invocation generics.
;                        Changed compute-getters-and-setters protocol.
;                        Made comments match the code.
;                        Changed maximum line width to 72.
; 1.1  11/24/92  Gregor  Fixed bug in compute-method-more-specific?,
;                        wrt the use of for-each.
;                        Both methods on allocate instance failed to
;                        initialize fields properly.
;                        The specializers and procedure initargs are
;                        now required when creating a method, that is,
;                        they no longer default.  No working program
;                        should notice this change.
; 1.2  12/02/92  Gregor  Fix minor things that improve portability:
;                          DEFINE needs 2 args in R4Rs
;                          Conditionalize printer hooks.
;                          () doesn't evaluate to ()
;
;       
(define tiny-clos-version "1.2")

'(;Stuff to make emacs more reasonable.

  (put 'letrec 'lisp-indent-hook 1)

  (put 'make-method  'lisp-indent-hook 1)
  (put 'add-method   'lisp-indent-hook 'defun)

 )

解説およびユーティリティのload

Scheme上に組み上げられた、 簡易なMOPを伴うCLOSライクな(オブジェクト指向)言語実装。 デフォルトのベース言語の特徴は次の通りだ。

  • インスタンスのスロット(インスタンス変数)を有するクラスがある。 但し、スロットオプションは無し。
  • 多重継承
  • 多重定義可能なメソッドとクラス特定化子のみを有する総称関数
  • Primary method と call-next-method のみ。他のメソッド結合は無し。
  • クラスと総称関数の名前空間は Scheme自身のレキシカルスコープの機能を使って実現している。 言いかえるとクラス、総称関数およびメソッドは第一級の(メタ)オブジェクトである。

ここで実装するMOPは簡単なものではあるが、 そのパワーにおいてはAMOPに記された二つのMOPと本質的になんら変わらないものだ。 この実装はまったく最適化されてはいないが、 MOPの方は最適化可能な様に設計されている。 実際、このMOPはAMOPに記述されたいずれのものよりもスロットアクセスの拡張 については、よりよい最適化が可能である。

;
; A very simple CLOS-like language, embedded in Scheme, with a simple
; MOP.  The features of the default base language are:
;
;   * Classes, with instance slots, but no slot options.
;   * Multiple-inheritance.
;   * Generic functions with multi-methods and class specializers only.
;   * Primary methods and call-next-method; no other method combination.
;   * Uses Scheme's lexical scoping facilities as the class and generic
;     function naming mechanism.  Another way of saying this is that
;     class, generic function and methods are first-class (meta)objects.
;
; While the MOP is simple, it is essentially equal in power to both MOPs
; in AMOP.  This implementation is not at all optimized, but the MOP is
; designed so that it can be optimized.  In fact, this MOP allows better
; optimization of slot access extenstions than those in AMOP.
; 
;

総称関数の呼び出しについて付け加えると、 デフォルトのベース言語へのエントリポイントは以下の通りである。

訳文自信無し

;
; In addition to calling a generic, the entry points to the default base
; language are:
;
;   (MAKE-CLASS list-of-superclasses list-of-slot-names)
;   (MAKE-GENERIC)
;   (MAKE-METHOD list-of-specializers procedure)
;   (ADD-METHOD generic method)
;
;   (MAKE class . initargs)
;   (INITIALIZE instance initargs)            ;Add methods to this,
;                                             ;don't call it directly.
;   
;   (SLOT-REF  object slot-name)
;   (SLOT-SET! object slot-name new-value)
;

そうだな、一例をあげようか。

この例を見て(list <object>)などが冗長に見えるだろうが、 構文を関数で実装しているので、こうなる。 なぜdefine-macroやdefine-syntaxを使わなかったのかは分からないが、 とりあえず、全体を通してこうなっている。 本質的な部分ではないので、大きな問題ではないだろう。

;
; So, for example, one might do:
;
;   (define <position> (make-class (list <object>) (list 'x 'y)))
;   (add-method initialize
;       (make-method (list <position>)
;         (lambda (call-next-method pos initargs)
;           (for-each (lambda (initarg-name slot-name)
;                       (slot-set! pos
;                                  slot-name
;                                  (getl initargs initarg-name 0)))
;                     '(x y)
;                     '(x y)))))
;
;   (set! p1 (make <position> 'x 1 'y 3))
;
;

注意! オブジェクト同士の比較に EQUAL? を使わないこと。 EQ?、あるいは、なにか自分で書いたプロシージャを使うこと。 オブジェクトは自身のクラスへのポインタを持ってて、だから、 クラスは循環構造だったりするわけで...

;
; NOTE!  Do not use EQUAL? to compare objects!  Use EQ? or some hand
;        written procedure.  Objects have a pointer to their class,
;        and classes are circular structures, and ...
;

このMOPの内観は次の様な感じだ。 これらはごく普通のプロシージャであって、 総称関数では無いことに注意してもらいたい。

;
;
; The introspective part of the MOP looks like the following.  Note that
; these are ordinary procedures, not generics.
;
;   CLASS-OF
;
;   CLASS-DIRECT-SUPERS
;   CLASS-DIRECT-SLOTS
;   CLASS-CPL
;   CLASS-SLOTS
;
;   GENERIC-METHODS
;
;   METHOD-SPECIALIZERS
;   METHOD-PROCEDURE
;

intercessory プロトコルは次の様なものだ。 (総称関数は大文字で書かれている)

ここだ。どうやら、makeやmakeしたときの初期化のロジック、 そしてメソッドを追加したときの内部での処理を取り決めており、 これが規約として詠われている。
さらにこれが、隠されずに公開されており、CLOSを使うユーザから 弄くり倒せるってのが その振る舞いを自由にカスタマイズできるオブジェクトシステム の力の根源なのだろう。
逆に言えば、この内部動作(規約)を把握しておかないと CLOSを自由には弄くり倒せないってことでもある。
したがって私たちのゴールは下の各関数がいつ動作して、 何をしているのかをきっちり理解することになる、と思われる。

;
; The intercessory protocol looks like (generics in uppercase):
;
;   make                        
;     ALLOCATE-INSTANCE
;     INITIALIZE                   (really a base-level generic)
;
;   class initialization
;     COMPUTE-CPL
;     COMPUTE-SLOTS
;     COMPUTE-GETTER-AND-SETTER
;
;   add-method                     (Notice this is not a generic!)
;     COMPUTE-APPLY-GENERIC
;       COMPUTE-METHODS
;         COMPUTE-METHOD-MORE-SPECIFIC?
;       COMPUTE-APPLY-METHODS
;

いいかな。じゃあ取りかかろうか。 おっと、何かおもしろいことを始める前に、 例によって最初にちょっといじらなきゃならないね。 まずはsupportライブラリをロードする必要がある。

support.scm にはいくつかのユーティリティ関数群が定義されている。 srfi-1にありそうなものから、CPLを計算するのに使われると思われる ソーティングのルーチンまで色々。

;
; OK, now let's get going.  But, as usual, before we can do anything
; interesting, we have to muck around for a bit first.  First, we need  
; to load the support library.
;
;
(load "support")

instancesとentity

さて、実際の実装において、組み上げなきゃならないのは インスタンスとエンティティのメモリサブシステムのインターフェースだ。 インスタンスは<class>のインスタンスのインスタンスのために使われ、 エンティティの方は<entity-class>のインスタンスのインスタンスのために使われる。 このMOPにおいては、ベースのあるいはMOPレベルでプログラムを組む人には このどちらも見えないようになっている。

だれかがdefine-recordだとかそんなものを使って インスタンスの定義を書きなおすかもしれない。 でも結果的にはそうシンプルにはならないだろう。 少なくとも私はそう思っている。 また、そうするとエンティティとの対句性もぶち壊しにしてしまうだろうしね。

現段階で全体像は掴めてないが、インスタンスはクラスやメソッドのインスタンスを 生成する際に使われるようだ。 そして、総称関数のみがエンティティとしてメモリアロケートされる様だ。 この辺は後で出てくると思うのでざっくりとした認識に留めておこう。

;
; Then, we need to build what, in a more real implementation, would be
; the interface to the memory subsystem: instances and entities.  The
; former are used for instances of instances of <class>; the latter
; are used for instances of instances of <entity-class>.  In this MOP,
; none of this is visible to base- or MOP-level programmers.
;
; (One might consider rewriting the definition of instances using
; define-record or something.  It doesn't turn out to make it much
; simpler, at least not to me.  It also breaks the nice parallelism
; with entities.)
;

instances

ここで出現する???は#<undef>だと思って良い。 すぐ後で再定義されるので暫定的なもの。

;
; instances
;
;
(define %allocate-instance   ???)
(define %instance?           ???)
(define %instance-class      ???)
(define %set-instance-class! ???)              ;This is used only once
                                               ;as part of bootstrapping
                                               ;the braid.
(define %instance-ref        ???)
(define %instance-set!       ???)

実体の定義はクロージャになっており、上記の%-prefixな関数群の実体がある。 クロージャにして共有しているのはタグのみで、instanceであることを示すのみ。

instance-tag

(%instance-tag) として局所環境に作られたタグ。

続く case what-scheme-implementation 式は無視しよう。実装依存だ。

(let ((instance-tag (list '%instance-tag)))

  (case what-scheme-implementation
    ((mit)
     (unparser/set-tagged-vector-method!      ;Make objects print a bit
      instance-tag                            ;more reasonably.  Scheme
      (unparser/standard-method 'object)))    ;is pretty feeble in this
    ((chez)))                                 ;regard.
%allocate-instance

instanceのメモリアロケートを行う関数。 実体となるベクタは以下の構造で、引数nfieldsはクラスのスロット数。 スロット数に加えてtagとclassを代入するための場所を確保している。 返り値はinstanceなので、ベクタ自体が返されることになる。

ベクタのサイズはクラスのスロット数(インスタンス変数の数)+2
   +-----+-----+-----+     +-----+-----+
   |  0  |  1  |  2    ... |  n  | n+1 |
   | TAG |CLASS|  #f       |  #f |  #f |
   +-----+-----+-----+     +-----+-----+
  (set! %allocate-instance
        (lambda (class nfields)
          (let ((instance (make-vector (+ nfields 2) #f)))
            (vector-set! instance 0 instance-tag)
            (vector-set! instance 1 class)
            instance)))
%instance?

instanceの述語。 xには正しくはinstanceの返り値であるベクタが渡されるはず。 ただし、何が渡されても良い様にvecter?かどうかを最初にチェック。 %allocate-instanceで保証された様にベクタのサイズは2以上。 その上で安心して0番目の要素にinstance-tagがあるかどうかをeq?でチェックしている。 ここは(%instance-tag)といったリストなのでeq?である必要がある。 equal?だと、クロージャ外部で作られたものでも#tになってしまう。

  (set! %instance?
        (lambda (x)
          (and (vector? x)
               (>= (vector-length x) 2)
               (eq? (vector-ref x 0) instance-tag))))
%instance-class

instanceのクラスを取得する関数。 内部的にはベクタの1番目の要素をアクセスしている。

  (set! %instance-class 
        (lambda (instance)
          (vector-ref instance 1)))
%set-instance-class!

上記%instance-classに対応するsetter。 内部的にはベクタの1番目の要素にnew-valueを代入する。

  (set! %set-instance-class!
        (lambda (instance new-value)
          (vector-set! instance 1 new-value)))
%instance-ref

instanceのタグ・クラス以外のスロットへアクセスするrefer。 オフセットとして+2しているので、呼び出しの際には内部構造は気にしなくて良い。 ただし、indexはスロット名ではなく数値でスロットを指定することになる。 こいつは低水準の関数なので、そうなっている。

  (set! %instance-ref
        (lambda (instance index)
          (vector-ref instance (+ index 2))))
%instance-set!

上記%instance-refに対応するsetter。 同じくindexはスロット名ではなく、数値でスロットを指定する。

  (set! %instance-set!
        (lambda (instance index new-value)
          (vector-set! instance (+ index 2) new-value)))
  )

entity

このエンティティの実装はもうほとんど笑えるくらいひどい。 いや、実際笑えるくらいひどいでしょうね。 でも、こいつは動きますよ。 そしてこの層の関数は学生とかに理解されるためのものであるよりもむしろ、 その存在が仮定されるからってだけのものだってことを心に留めてもらいたい。

いや、ここの訳文も笑えるほどにひどい。自信無し。

;
; This implementation of entities is almost laughably bad.   Maybe in
; fact it is laughably bad.  But, it works, and keep in mind that this
; level of the stuff should just be assumbed as existing, rather than
; having to be understood by students and the like.
;
(define %allocate-entity   ???)
(define %entity?           ???)
(define %set-entity-proc!  ???)
(define %entity-class      ???)
(define %entity-ref        ???)
(define %entity-set!       ???)

エンティティのインターフェースもクロージャを使って実装される。 instanceではタグのみだったが、entityでは局所変数は次のものがある。

entities

エンティティのインスタンスプールで内部的にはベクタとベクタへアクセスするためのインターフェースとなるクロージャのペアとなっている。 内部では連想リスト的に扱われており、クロージャが呼び出し側へ返されるので、 そのクロージャを使って対応するベクタを取得して各要素にアクセスする様になる。

get-vector

エンティティへは外部からクロージャを渡して、 それを元にベクタの各要素にアクセスする様にしている。 クロージャとベクタはペアとして連想リスト的にentitiesというインスタンスプールに 格納されており、ここから対応するベクタを取り出すための関数。

default-proc

entityのベクタの第0番目の要素に格納されるプロシージャの初期値。 但し、単にエラーを発生させるもの。

この辺りは、分かり難ければ先に後述する%allocate-entityを見ておいた方が 良いかもしれない。

(letrec ((entities ())
         (get-vector
          (lambda (closure)
            (let ((cell (assq closure entities)))
              (if (null? cell) #f (cdr cell)))))
         (default-proc
             (lambda args
               (error "Called entity without first setting proc."))))
%allocate-entity

ベクタを生成し、第0番目の要素にprocを、第1番目の要素には classを入れる。スロットの各要素は#fで初期化。 classと違って、ベクタを直接返さず、 ベクタと対になるclosureを生成して、そいつを返り値にする。 外部からは、このclosureを使って、ベクタを引っ張り出す仕組み。 そのため、エンティティは全体を管理するインスタンスプールを有しており、 ここに各ベクタとクロージャのペアが連想リスト的にプールされている。 なお、このインスタンスプールは上で出てきたentitiesという局所変数がそうだ。

ベクタのサイズはクラスのスロット数(インスタンス変数の数)+2
   +-----+-----+-----+     +-----+-----+
   |  0  |  1  |  2    ... |  n  | n+1 |
   |PROC |CLASS|  #f       |  #f |  #f |
   +-----+-----+-----+     +-----+-----+

クロージャはベクタの0番目の要素をプロシージャとして呼び出し、
自身が呼び出されたときの引数argsを適用するしろもの。
デフォルトではdefault-procが呼ばれるが、こいつはエラーを発する。
%allocate-entityを呼び出す側から見ると、ベクタではなくクロージャが
entityになると思っていいだろう。
  (set! %allocate-entity
        (lambda (class nfields)
          (letrec ((vector (make-vector (+ nfields 2) #f))
                   (closure (lambda args
                              (apply (vector-ref vector 0) args))))
            (vector-set! vector 0 default-proc)
            (vector-set! vector 1 class)
            (set! entities (cons (cons closure vector) entities))
            closure)))
%entity?

entityの述語。だが、これって正しいか? %allocate-entityからすると、 これは単に (lambda (x) (not (get-vector x)))で良さそうだが。 この定義だとクロージャは見つかったが、ペアになるベクタが無いということになり、 これは%allocate-entityを見る限り無さそうだが。

  (set! %entity?
        (lambda (x) (not (null? (get-vector x)))))
%entity-class

entityのクラスを取得する関数。 内部的には引数としてもらったクロージャをエンティティのインスタンスプール (entities)から探し出してベクタを取得し、その第1番目の要素を返している。

  (set! %entity-class
        (lambda (closure)
          (let ((vector (get-vector closure)))
            (vector-ref vector 1))))
%set-entity-proc!

entityの第0番目の要素であるprocへのsetter。 同じくインスタンスプール(entities)からクロージャを元に探し出して、 対応するベクタの0番目の要素にprocを代入している。

  (set! %set-entity-proc!
        (lambda (closure proc)
          (let ((vector (get-vector closure)))
            (vector-set! vector 0 proc))))
%entity-ref

entityのプロシージャ・クラス以外のスロットへアクセスするrefer。 オフセットとして+2しているので、呼び出しの際には内部構造は気にしなくて良い。 ただし、indexはスロット名ではなく数値でスロットを指定することになる。 やはり、クロージャを元にインスタンスプール(entities)から対応するベクタを探して その中から対応するスロットの値を返す。

  (set! %entity-ref
        (lambda (closure index)
          (let ((vector (get-vector closure)))
            (vector-ref vector (+ index 2)))))
%entity-set!

上記%entity-refに対応するsetter。 同じくindexはスロット名ではなく、数値でスロットを指定する。 やはり、クロージャを元にインスタンスプール(entities)から対応するベクタを探して その中から対応するスロットにnew-valueを代入する。

  (set! %entity-set!
        (lambda (closure index new-value)
          (let ((vector (get-vector closure)))
            (vector-set! vector (+ index 2) new-value))))
  )

次の三つと%allocate-instanceと%allocate-entityは残りのコードから 低水準のメモリシステムへの通常のインターフェースだ。 注目すべき点は、このプロトコルはユーザが低水準のインスタンスの表現 を追加するのを許してはいないということだ。 私はこれまでそんなことしてるのを見たことないけどね。

この実装でのclass-of関数は、 最後に設定するプリミティブクラスの名前を仮定しちゃってます。

;
; These next three, plus %allocate-instance and %allocate-entity, are
; the normal interface, from the rest of the code, to the low-level
; memory system.  One thing to take note of is that the protocol does
; not allow the user to add low-level instance representations.  I
; have never seen a way to make that work.
;
; Note that this implementation of class-of assumes the name of a the
; primitive classes that are set up later.
; 
class-of

標準インターフェースとなるclass-of関数。 プリミティブクラスとして<boolean>、<symbol>、<char>、<vector>、 <pair>、<number>、<string>、<procedure>があるが、 これはまさに実装の基盤となるschemeの各データ型の述語を用いて判定されている。 ユーザ定義のクラスについては%instance?と%entity?を使って、 各ベクタの第1要素に格納されたclassを使って返り値としている。

(define class-of
    (lambda (x)
      (cond ((%instance? x)  (%instance-class x))
            ((%entity? x)    (%entity-class x))

            ((boolean? x)    <boolean>)
            ((symbol? x)     <symbol>)
            ((char? x)       <char>)
            ((vector? x)     <vector>)
            ((pair? x)       <pair>)
            ((number? x)     <number>)
            ((string? x)     <string>)
            ((procedure? x)  <procedure>))))
get-field

instanceとentityのみを対象とするスロットのアクセッサ。 fieldにはスロット名ではなく、ベクタのindexに相当する値を渡す。 内部構造、すなわちベクタの最初にタグがあるとか クラスが入っているとかは気にしなくてもいい。 それ以外のオブジェクトが渡されればエラーだ。

(define get-field
    (lambda (object field)
      (cond ((%instance? object) (%instance-ref object field))
            ((%entity?   object) (%entity-ref   object field))
            (else
             (error "Can only get-field of instances and entities.")))))
set-field!

上記のget-fieldに対応するsetter。 同じく、instanceとentityのみを対象とする。

これらのラッパーにより、ユーザには<class>と<entity-class>が低位では 別の実装になっていることを意識させないつくりにしていると思われる。

(define set-field!
    (lambda (object field new-value)
      (cond ((%instance? object) (%instance-set! object field new-value))
            ((%entity?   object) (%entity-set!   object field new-value))
            (else
             (error "Can only set-field! of instances and entities.")))))

make(bootstrap)

システム立ち上げ時におけるmake。おそらく前半のキモ。

これで具体的な話に入ることができる。 まず、初期化する。

ブートストラップには、初期バージョンの MAKE を定義する。 これは後に本物のバージョンに置き換えられる。 ``set! make''で文字列検索してみたまえ。

;
; Now we can get down to business.  First, we initialize the braid.
;
; For Bootstrapping, we define an early version of MAKE.  It will be
; changed to the real version later on.  String search for ``set! make''.
;

このmakeは<class>、<entity-class>、<generic>および<method>のみを生成する。 それ以外は含まれてない。 そして、<generic>のみが%allocate-entityを使っており、 残りは全部%allocate-instanceだって事を覚えておこう。 その前に<class>の構造をある程度見ておいた方が分かり易そうなので、 下の方のコードを先走って読み込んでおこう。

(define the-slots-of-a-class     ;
    '(direct-supers              ;(class ...)        
      direct-slots               ;((name . options) ...)
      cpl                        ;(class ...) 
      slots                      ;((name . options) ...) 
      nfields                    ;an integer
      field-initializers         ;(proc ...)
      getters-n-setters))        ;((slot-name getter setter) ...)

これからすると、<class>はこんな感じになる。 なお、上のコメント部分の構造は実際の取り扱いをイメージする上で有用だ。

direct-supers

直接スーパークラスのリスト。

direct-slots

直接スロット(インスタンス変数)。 実体は変数名とスロットオプションのペアのリストになっている。

cpl

クラス優先度リスト。

slots

継承されたスロットを含めた全スロット。 構造はdirect-slotsと同じ。

nfields

スロットの数。整数で、%allocate-instanceに渡す値。

field-initializers

各スロットの初期化関数。

getters-n-setters

getters and setters の略。 各スロットへのgetterとsetterのリスト。 構造としては、スロット名(インスタンス変数名)とgetter/setterのリストのリスト。

<class>の構造
 +-------+-------+-------+-------+-------+-------+-------+-------+-------+
 |   0   |   1   |   2   |   3   |   4   |   5   |   6   |   7   |   8   |
 |  TAG  |   +   |   +   |   +   |   +   |   +   |   +   |   +   |   +   |
 +-------+---|---+---|---+---|---+---|---+---|---+---|---+---|---+---|---+
          <class>    |       |       |       |       |       |       |
                   direct    |      cpl      |    nfields    |  getters-n-setters
                   supers    |  (class ...)  |    N:Integer  |  ((slot-name getter setter) ...)
                 (class ...) |               |               |
                             |             slots             | 
                           direct   ((name .options) ...)    |
                           slots                             |
                    ((name . options) ...)           field-initializers
                                                         (proc ...)

それではbootstrap版のmakeを見てく。 makeの引数はclassとinitargs。 あとの方で出てくる<top>や<object>の定義を参照すれば、どんなものが渡るが分かる。 classには<class>や<entity-class>、あとで出てくる<generic>、<method>がくる。 initargsは(direct-supers () direct-slots ()) の様なニ個一組のリストがくる。
特にクラスの場合にはthe-slots-of-a-classに定義された7種類のスロットと、 その値とのリストがせいぜいといったところだ。

まずは、make <class>もしくはmake <entity-class>とした場合。
newには<class>もしくは<entity-class>のインスタンス(実体はベクタ)が渡される。 こいつはthe-slots-of-a-classのスロットを持つべくベクタが確保されるので、 内実は<class>と同じものってことだろう。 現時点では<class>の実体はまだ定義されていない。(後で出てくる)

(define make
    (lambda (class . initargs)
      (cond ((or (eq? class <class>)
                 (eq? class <entity-class>))
             (let* ((new (%allocate-instance
                          class
                          (length the-slots-of-a-class)))
dsupers

直接スーパークラス。 initargs中からdirect-supersの対になっている要素を取得してdsupersに束縛。

                    (dsupers (getl initargs 'direct-supers '()))

ここで一応getlを見ておく。support.scm中にある。 引数はinitargsとinitargs中の探し出すスロット名nameおよび、 オプショナルな引数not-found。 基本的にはinitargsがスロット名と対応する値の二つ一組のリストになっている ってのを意識していれば、carを見て、eq?ならcadrを返し、 無ければcddrに対して同じように探し続けるだけ。 not-foundは最後まで探したけど、見付からなかったときに返す値。 いわばデフォルト値になる。 ()を与えた場合にはnot-found自体は'(())になるのに一応注意されたし。 errorが発生するのは、あくまでデフォルト値not-foundも与えられず、 スロット名が見付からなかった場合だ。

割り込みでsupport.scmからutility関数getlを紹介。

(define getl
    (lambda (initargs name . not-found)
      (letrec ((scan (lambda (tail)  
                       (cond ((null? tail)
                              (if (pair? not-found)
                                  (car not-found)
                                  (error "GETL couldn't find" name)))
                             ((eq? (car tail) name) (cadr tail))
                             (else (scan (cddr tail)))))))
        (scan initargs))))
dslots

直接スロット。 initargs中からdirect-slotsと対になっている要素を取得してdslotsに束縛。

                    (dslots  (map list
                                  (getl initargs 'direct-slots  '())))
cpl

クラス優先度リスト。 上で取得したdsupersを順番にスキャンして、各スーパークラスのスーパークラスを 遡りつつ深さ優先で再帰的にso-farに累積していく。 なお、so-farの初期化にはnewを含めているので、自分自身を含む。 つまり、cplの最初のメンバは自身のクラスだ。

                    (cpl     (let loop ((sups dsupers)
                                        (so-far (list new)))
                                  (if (null? sups)
                                      (reverse so-far)
                                      (loop (class-direct-supers
                                             (car sups))
                                            (cons (car sups)
                                                  so-far)))))
slots

スロット。直接スロット、つまりこのクラス固有のスロットに加えて、 スーパークラスのスロットをかき集めたものを合わせたもの。 要は、親のスロットを継承するっていうメカニズム部分を実現している。

                    (slots (apply append
                                  (cons dslots
                                        (map class-direct-slots
                                             (cdr cpl)))))
nfields

スロット数(インスタンス変数の数)。初期値は0にしているが、 後続の部分で順次インクリメントされて、最後にはスロット数に到達する。

field-initializers

スロットの初期化関数。初期値は()にしているが、 これも後続の部分で順次インクリされつつそれなりのものが代入される。 初期化関数はこの()にコンシングされる。

                    (nfields 0)
                    (field-initializers '())
allocator

この後でgetters-n-settersの初期化に使われるユーティリティ。 ただし、get-fieldとset-field!を使っているので、 ちゃんと各スロットのgetter、setterにはなっている。 (lambda (o) (get-field o f))は(lambda (object) (get-field object field))、 (lambda (o n) (set-field! o f n))は (lambda (object) (set-field! object field new-value))だと思えばいいだろう。
ちなみにgetters-n-settersに出てくるが、 initにはとりあえず(lambda () ())が渡されて初期化される。

                    (allocator
                      (lambda (init)
                        (let ((f nfields))
                          (set! nfields (+ nfields 1))
                          (set! field-initializers
                                (cons init field-initializers))
                          (list (lambda (o)   (get-field  o f))
                                (lambda (o n) (set-field! o f n))))))
getters-n-setters

スロット名とgetterとsetterのリストのリストに束縛される。 ただし、初期化関数は(lambda () ())。

                    (getters-n-setters
                      (map (lambda (s)
                             (cons (car s)
                                   (allocator (lambda () '()))))
                           slots)))

ここまでで計算した各スロット変数の値を実際に各ベクタに代入する。 返り値はnewなので、ベクタが返される。

               (slot-set! new 'direct-supers      dsupers)
               (slot-set! new 'direct-slots       dslots)
               (slot-set! new 'cpl                cpl)
               (slot-set! new 'slots              slots)
               (slot-set! new 'nfields            nfields)
               (slot-set! new 'field-initializers (reverse
                                                   field-initializers))
               (slot-set! new 'getters-n-setters  getters-n-setters)
               new))

続いてmake <generic>とした場合のコード。
newには%allocate-entityされたものが返る。 ここでは<class>の場合と違って、ちゃんと<generic>のスロットの長さを取得している。 こいつは、後で決定されるので、現時点では不明。 スロットmethodには()で初期化される。 <generic>はこれだけで返される。 ここで返るnewはクロージャであってベクタではない。 ベクタはインスタンスプール中にクロージャと共に格納されている。

<generic>の初期化の時に分かるが、基本的にdirect-supersとdirect-slotsのみを持ち、 direct-slotsにはmethodスロットを有するのみ。 methodスロットには定義されたmethodがリストで管理されている。

            ((eq? class <generic>)
             (let ((new (%allocate-entity class
                                          (length (class-slots class)))))
               (slot-set! new 'methods ())
               new))

最後にmake <method>とした場合のコード。
newには%allocate-instanceしたベクタが束縛される。 初期化されるスロットはspecializersとprocedureだ。 specializerは特定化子、procedureはメソッドの手続き本体だ。 ここではgetlを使っており、initargs中から探しているんだが、 not-foundが無いので、initargsに無ければエラーとなる。 つまり、必須でmake時に指定しないといけない。

<method>の初期化の時に分かるが、基本的にdirect-supersとdirect-slotsのみを持ち、 direct-slotsにはspecializersスロットとprocedureスロットがあるだけ。

            ((eq? class <method>)
             (let ((new (%allocate-instance
                         class
                         (length (class-slots class)))))
               (slot-set! new
                          'specializers
                          (getl initargs 'specializers))
               (slot-set! new
                          'procedure
                          (getl initargs 'procedure))
               new)))))

以下は実質的なバージョンのslot-refとslot-set!だ。 いかなる総称関数の呼び出しも準備してない状況で、 新しいスロットアクセスプロトコルを起動させるというやり方のために、 この様に事前に定義できるんだ。クールだろ?

ここも訳文自信ないな。 最後がクールだろ?ってなってるから、利点ぽい言いまわしなんだろうけど、 最初ネガティブな説明に見えるし。 ただ、slot-ref、slot-set!は内部でlookup-slot-infoを使用しているのだが、 このlookup-slot-info自体もslot-refを使用しており、相互参照になっている。 それでうまく動いてるんだよ、ってのを主張しているんだと思うんだが。

;
; These are the real versions of slot-ref and slot-set!.  Because of the
; way the new slot access protocol works, with no generic call in line,
; they can be defined up front like this.  Cool eh?
;
;
slot-ref

オブジェクトの、引数で与えられたスロット名の値を取得するrefer。 オブジェクトのクラスを取りだして、そこからスロット名でアクセスする。 infoにはgetters-n-settersのcdrが渡ってくるので、0番目のリスト要素はgetterとなり、 そのgetterを使って、オブジェクトのスロット値を取得している。

(define slot-ref
    (lambda (object slot-name)
      (let* ((info   (lookup-slot-info (class-of object) slot-name))
             (getter (list-ref info 0)))
        (getter object))))
slot-set!

上記slot-refに対応するsetter。 同じく、オブジェクトのクラスを取りだして、そこからスロット名でアクセスする。 infoにはgetters-n-settersのcdrが渡ってくるので、1番目のリスト要素はsetterとなり、 そのsetterを使って、オブジェクトのスロット値にnew-valueを代入している。

(define slot-set!
    (lambda (object slot-name new-value)
      (let* ((info   (lookup-slot-info (class-of object) slot-name))
             (setter (list-ref info 1)))
        (setter object new-value))))
lookup-slot-info

上記slot-ref、slot-set!で使用されているユーティリティ関数。 クラスとスロット名を取得して、getters-n-settersを取得する。 こいつは((slot-name getter setter) ...)な形式の連想リストなので、 assqによりスロット名をキーにチェックしてentryに束縛。 返り値はentryのcdr、つまり(getter setter)が返る。 故にslot-ref、slot-set!ではlist-refにより0番目、1番目のリスト要素にアクセスして getterとsetterがそれぞれ取得できるのだ。

(define lookup-slot-info
    (lambda (class slot-name)
      (let* ((getters-n-setters
               (if (eq? class <class>)           ;* This grounds out
                   getters-n-setters-for-class   ;* the slot-ref tower.
                   (slot-ref class 'getters-n-setters)))
             (entry (assq slot-name getters-n-setters)))
        (if (null? entry)
            (error "No slot" slot-name "in instances of" class)
            (cdr entry)))))

ちょっとだけここまででアクセッサの階層を確認しておくと、こんな感じ。 最下層はメモリサブシステムのレベルで、中間層がクラスの実体中で getterやsetterを実装する時に使っているレベル。 最上位がユーザ向けと思われる。

クラス スロットgetter スロットsetter
最上位 class-of slot-ref slot-set!
中間層 get-field set-field!
最下層 %instance-class,%entity-class %instance-ref,%entity-ref %instance-set!,%entity-set!

そのうち出てくる実質的なクラス定義の前に、 初期版のMAKEを与えることで、ここに示すように、 クラスメタオブジェクトのアクセッサを生成することが出来る。

;
; Given that the early version of MAKE is allowed to call accessors on
; class metaobjects, the definitions for them come here, before the
; actual class definitions, which are coming up right afterwards.
;
;

<class>および<entity-class>用

ここにはスロット数、各スロットの初期化関数、 getterやsetterへのアクセス関数は定義されていない。

class-direct-slots

<class>クラスまたは<entity-class>クラスの direct-slotsスロットの値を返す。

(define class-direct-slots
    (lambda (class) (slot-ref class 'direct-slots)))
class-direct-supers

<class>クラスまたは<entity-class>クラスの direct-supersスロットの値を返す。

(define class-direct-supers
    (lambda (class) (slot-ref class 'direct-supers)))
class-slots

<class>クラスまたは<entity-class>クラスの slotsスロットの値を返す。

(define class-slots
    (lambda (class) (slot-ref class 'slots)))
class-cpl

<class>クラスまたは<entity-class>クラスのcplスロットの値を返す。

(define class-cpl
    (lambda (class) (slot-ref class 'cpl)))

<generic>用

generic-methods

<generic>クラスのmethodスロットの値を返す。 つまり、この総称関数にてディスパッチされうるメソッドの全てを返す。

(define generic-methods
    (lambda (generic) (slot-ref generic 'methods)))

<method>用

method-specializers

<method>クラスのspecializersスロットの値を返す。 つまり、このメソッドが適用可能な引数の特定化子を返す。

(define method-specializers
    (lambda (method) (slot-ref method 'specializers)))
method-procedure

<method>クラスのprocedureスロットの値を返す。

(define method-procedure
    (lambda (method) (slot-ref method 'procedure)))

次の7つのかたまりは6つの初期クラスを定義する。 1つ目のと4つ目のが<class>クラスの定義になっているので、 7つで6つのクラスを定義することになっている。

説明が分かり難いけど、要は<class>クラスが無いと、<top>や<object>クラスの実体を 生成することが出来ない。 なぜならこれらもまた<class>のインスタンスだからね。
一方、<class>クラスは、そのスーパークラスとして<object>クラスを有するし、 クラス優先度リストには自身の<class>はおろか<top>や<object>も含む。 このため、<class>自体はmakeを使って一撃実装はできない。 というわけで低水準の関数を使いながらちょこちょこ実装しないといけない。 結果として最初と<top>および<obejct>を定義した後とに分かれてしまったのだ。 これはクラス階層構築のところで出てくる。

;
; The next 7 clusters define the 6 initial classes.  It takes 7 to 6
; because the first and fourth both contribute to <class>.
;
the-slots-of-a-class

<class>クラスおよび<entity-class>クラス専用のスロット。 これらのクラスについては元が無いために手で作ってやらなければならず、 そのための雛型だ。

(define the-slots-of-a-class     ;
    '(direct-supers              ;(class ...)        
      direct-slots               ;((name . options) ...)
      cpl                        ;(class ...) 
      slots                      ;((name . options) ...) 
      nfields                    ;an integer
      field-initializers         ;(proc ...)
      getters-n-setters))        ;((slot-name getter setter) ...)
                                 ;
getters-n-setters-for-class

<class>クラスおよび<entity-class>クラス専用の getterとsetterのリスト。 positions-ofはsupport.scmに定義されていて、 この場合にはthe-slots-of-a-classのリストの中からsというスロット名のスロットが 何番目のリスト要素かを返す。 こいつは低水準のアクセス関数%instance-refや%instance-set!がスロット名ではなく ベクタのインデックス(要素番号)でもってアクセスしているためだ。

この書き方はばかばかしく思える。 問題はなにかというと、わかりやすい書き方をしたら、 MIT Schemeのバグをつついちゃうみたいなんだよね。

(define getters-n-setters-for-class      ;see lookup-slot-info
    ;
    ; I know this seems like a silly way to write this.  The
    ; problem is that the obvious way to write it seems to
    ; tickle a bug in MIT Scheme!
    ;
    (let ((make-em (lambda (s f)
                     (list s
                           (lambda (o)   (%instance-ref  o f))
                           (lambda (o n) (%instance-set! o f n))))))
      (map (lambda (s)
             (make-em s (position-of s the-slots-of-a-class)))
           the-slots-of-a-class)))

class階層構築

ここで、初期クラス<top>、<object>、<class>、<procedure-class>、<entity-class>、 <generic>そして<method>を定義している。 これらはクラスだから<class>のインスタンスであり、 そのため、make <class>のように始めたいのだが、 <class>がないから仕方ない。<class>については低水準の関数を用いて ちまちま実装することになる。

<class>クラスの生成

まず、<class>の実体をアロケートしてしまう。 この時点では<class>クラスが無いので、アロケートされたベクタのクラス要素には#f は設定されている。ベクタ自体は必要なサイズを取得しているけどね。

(define <class> (%allocate-instance #f (length the-slots-of-a-class)))

次に、アロケートした<class>クラスのベクタのクラス要素に自身を代入する。

(%set-instance-class! <class> <class>)

ここまでが最初のかたまり(cluster)ってやつ。

<top>クラス構築

中身はともかく、<class>の実体だけは存在するようになったので、 あらゆるクラスの最上位に君臨する<top>クラスを作る。 (make class . initargs)の形で言えば、 (make <class> (direct-supers () direct-slots ()))となる。 すでに見たbootstrap版のmakeに当てはめてみると、 <class>と同じ構造でdirect-supersとdirect-slotsが()になる。

(define <top>          (make <class>
                             'direct-supers (list)
                             'direct-slots  (list)))

後続のものは書かないが、一応<top>だけ書いておく。

<top>の構造
 +-------+-------+-------+-------+-------+-------+-------+-------+-------+
 |   0   |   1   |   2   |   3   |   4   |   5   |   6   |   7   |   8   |
 |  TAG  |   +   |   +   |   +   |   +   |   +   |   +   |   +   |   +   |
 +-------+---|---+---|---+---|---+---|---+---|---+---|---+---|---+---|---+
          <class>    |       |       |       |       |       |       |
                   direct    |      cpl      |    nfields    |  getters-n-setters
                   supers    |    (<top>)    |    N:0        |       ()
                     ()      |               |               |
                             |             slots             | 
                           direct            ()              |
                           slots                             |
                            ()                      field-initializers
                                                             ()

<object>クラス構築

<top>クラスのサブクラスである<object>クラスを作る。 こいつは直接スーパークラスに<top>を含めることで継承関係を作る。 スロットは持たない。さらにスーパークラスにもスロットはないので、 slotsも同じく空だ。

(define <object>       (make <class>
                             'direct-supers (list <top>)
                             'direct-slots  (list)))

<class>クラスの構築

このかたまりは上で<class>を定義して<class>のクラス要素を代入した、 あの最初のかたまりとあわせて、次のmake式の処理と同じことをしている。

くどいけど<class>は卵が先か鶏が先かな状態なので、直接make <class>出来ない。 で、こうなっちゃうんだよってことですね。
<class>は自身のインスタンスでもあるクラスで、直接スーパークラスは<object>。 こいつのスロットはthe-slots-of-a-classだけ存在し、 スーパークラスにスロットが無いのでslotsも同じものになる。

;
; This cluster, together with the first cluster above that defines
; <class> and sets its class, have the effect of:
;
;   (define <class>
;     (make <class>
;           'direct-supers (list <object>)
;           'direct-slots  (list 'direct-supers ...)))
;

<class>の実体となるベクタの各要素へ、直接書きこんで<class>を完成させる。 スロットの初期化関数と6番目の要素であるgetters-n-settersは適当にあしらわれてる。

(%instance-set! <class> 0 (list <object>))                  ;d supers
(%instance-set! <class> 1 (map list the-slots-of-a-class))  ;d slots
(%instance-set! <class> 2 (list <class> <object> <top>))    ;cpl
(%instance-set! <class> 3 (map list the-slots-of-a-class))  ;slots
(%instance-set! <class> 4 (length the-slots-of-a-class))    ;nfields
(%instance-set! <class> 5 (map (lambda (s)                  ;field-ini..
                                 (lambda () '()))
                               the-slots-of-a-class))
(%instance-set! <class> 6 '())                              ;not needed

<procedure-class>クラスの構築

<class>クラスのサブクラスである<procedure-class>クラスを作る。 こいつは直接スーパークラスに<class>を含めることで継承関係を作る。 スロットは持たない。直接スーパークラスがthe-slots-of-a-class分だけ スロットを有するので、こいつも同じだけslotsを持つ。

(define <procedure-class> (make <class>
                                'direct-supers (list <class>)
                                'direct-slots  (list)))

<entity-class>クラスの構築

<procedure-class>クラスのサブクラスである<entity-class>クラスを作る。 entity-classという名前から実体クラスと思ったら、procedure-classのサブクラス ということで、プロシージャの一種であることが分かる。 genericはプロシージャの仲間なんだから正しいだろう。

(define <entity-class>    (make <class>
                                'direct-supers (list <procedure-class>)
                                'direct-slots  (list)))

<generic>クラスの構築

<generic>クラスは少しパターンが違う。 <object>クラスのサブクラスだが、<entity-class>のインスタンスとして生成される。 <class>のインスタンスとは別になっているので、initializerなどの総称関数の 動作の仕方とかが違ってくるということになろう。 おそらくこの辺もメモリサブシステムの違いから来ていると思うが、 逆に違った振るまいをさせたいために、 メモリサブシステムが違った形で実装されているとも言える。
直接スロットとしてはmethodを持つ。

(define <generic>         (make <entity-class>
                                'direct-supers (list <object>)
                                'direct-slots  (list 'methods)))

<method>クラスの構築

<object>クラスのサブクラスとして<method>クラスを作る。 直接スロットにはspecializersとprocedureを持つ。

(define <method>          (make <class>
                                'direct-supers (list <object>)
                                'direct-slots  (list 'specializers
                                                     'procedure)))

ここまでの初期クラスの継承関係をまとめるとこんな感じだ。

                              metaclass: <class>
                         ..................................
                         :                                :
                         :        <top>                   :
      metaclass:         :          |                     :
      <entity-class>     :       <object>                 :
       ................  :       /  |  \                  :
       :      +-----------------+   |   +-------------+   :
       :      |       :  :          |                 |   :
       :   <generic>  :  :       <class>         <method> :
       :              :  :          |                     :
       :..............:  :   <procedure-class>            :
                         :          |                     :
                         :     <entity-class>             :
                         :                                :
                         :                                :
                         :................................:

構文導入

ここに書くのはベースレベルのユーザに見える様にしている便利な構文である。

構文といいつつ、プロシージャなので実際使う時にはちょっと扱いが違う。

;
; These are the convenient syntax we expose to the base-level user.
;
;
make-class

make <class> ... のための構文。

(define make-class
    (lambda (direct-supers direct-slots)
      (make <class>
            'direct-supers direct-supers
            'direct-slots  direct-slots)))
make-generic

make <generic> のための構文。 こいつは引数なしで生成されて、 内部のmethodスロットは後述するadd-methodで順次追加されていく。

(define make-generic
    (lambda ()
      (make <generic>)))
make-method

make <method> ... のための構文。 メソッドの本体であるprocedureと、 メソッドの引数の型を指定するspecializersを引数にとる。 あくまで総称関数が呼ばれ、総称関数がspecializerを元に、 実際に呼ばれた時の型から、どのメソッドを適用するかを計算して 対応するメソッドを呼び出すことになる。

(define make-method
    (lambda (specializers procedure)
      (make <method>
            'specializers specializers
            'procedure    procedure)))

initialization protocol

初期化プロトコル

;
; The initialization protocol
;
initialize

総称関数initializeを生成。

(define initialize (make-generic))

インスタンス構造プロトコル

;
; The instance structure protocol.
;
allocate-instance

インスタンスの生成。

compute-getter-and-setter

インスタンスのスロットのgetterとsetterを生成するロジック。

(define allocate-instance (make-generic))
(define compute-getter-and-setter (make-generic))

クラス初期化プロトコル

;
; The class initialization protocol.
;
compute-cpl

クラス優先度リストを計算するロジック。

compute-slots

スーパークラスから継承するスロットを含めて全スロットを計算するロジック。

(define compute-cpl (make-generic))
(define compute-slots (make-generic))

総称関数呼び出しプロトコル

;
; The generic invocation protocol.
;
compute-apply-generic

基本的にはメソッド結合により 組み合わされた手続きが生成されて引数に適用される。 この手続きは、その時点で総称関数に登録済みのメソッド群と、 適用された引数の特定化子(クラスの組み合わせ)により動的に計算されて生成される。

compute-methods

総称関数に登録済みのメソッドについて、 その総称関数に実際に引数を適用した場合に、 適用が可能と判断されるメソッドをより特定的な順にソートして返す関数を生成する。

compute-method-more-specific?

総称関数に登録済みのメソッドについて、 その総称関数に実際に引数を適用した場合に、 より特定的なメソッドを判定するための関数を生成する。

compute-apply-methods

総称関数に登録済みのメソッドについて、 その総称関数に実際に引数を適用した場合に、 どういうメソッド適用がされるかの表す関数を生成する。

(define compute-apply-generic         (make-generic))
(define compute-methods               (make-generic))
(define compute-method-more-specific? (make-generic))
(define compute-apply-methods         (make-generic))

続いてやることはと言えば、総称関数の立ち上げだね。

;
; The next thing to do is bootstrap generic functions.
; 
add-method

総称関数にメソッドを追加する関数。 add-method自体は総称関数ではない。 引数で与えられた総称関数genericのmethodスロットに、 やはり引数で与えられたmethodをコンシングする。 この時、メソッド特定化子を定義済みメソッドのそれと比較して 同じ特定化子のメソッドが定義済みで見付かれば取り除き、 そうでなければ残留して、新しいメソッドを取り込む。
このフィルタリングはfilter-inで実現しており、support.scmに定義されている。 新しいメソッドを追加した上で、compute-apply-genericを計算し、 総称関数の本体のベクタ0番目の要素procに登録する。

(define generic-invocation-generics (list compute-apply-generic
                                          compute-methods
                                          compute-method-more-specific?
                                          compute-apply-methods))

(define add-method
    (lambda (generic method)
      (slot-set! generic
                 'methods
                 (cons method
                       (filter-in
                        (lambda (m)
                          (not (every eq?
                                      (method-specializers m)
                                      (method-specializers method))))
                        (slot-ref generic 'methods))))
      (%set-entity-proc! generic (compute-apply-generic generic))))

method

後半の山場というか全体でもクライマックスのところ。

COMPUTE-APPLY-GENERICに最初のメソッドを追加しようとすると、 結果として総称関数呼び出しプロトコル中の他の総称関数を呼び出そうとする。 関連する二つの問題が浮上する。 鶏が先か卵が先か問題と無限後退の問題だ。

最初のメソッドをCOMPUTE-APPLY-GENERICに追加しようとすると、 そこに何か呼び出し可能なものが既になきゃならない。 下にある最初の定義はこれをやっている。

それから、二つ目の定義が無限後退の問題や それ自身を構築するのに十分な周辺のプロトコルがまだ無いという問題を解決する。 この解決手段は総称関数呼び出しプロトコルにおける、 特殊なケースの総称関数呼び出しであるような方法と同じである。

最後の訳文自信なし。

;
; Adding a method calls COMPUTE-APPLY-GENERIC, the result of which calls
; the other generics in the generic invocation protocol.  Two, related,
; problems come up.  A chicken and egg problem and a infinite regress
; problem.
;
; In order to add our first method to COMPUTE-APPLY-GENERIC, we need
; something sitting there, so it can be called.  The first definition
; below does that.
; 
; Then, the second definition solves both the infinite regress and the
; not having enough of the protocol around to build itself problem the
; same way: it special cases invocation of generics in the invocation
; protocol.
;
;

%set-entity-proc!式によるcompute-apply-genericへのprocの追加はこんな感じ。 ただし、点線部分の参照関係は一般には別の<generic>への参照になる。 つまり(compute-apply-generic generic)と実際に呼び出されたときのgenericへの 参照になるのだ。 結局現時点の設定では、(compute-apply-generic generic)とするとgenericの 最初のメソッドの実体であるprocが呼び出されるようだ。 しかしコードのコメントにもあるようにこれが走るのは一回こっきりだ。 コメントのcnmはcall-next-methodの略。 おいおい分かるが、メソッドの実体であるprocの第一引数には常にcall-next-methodに 相当するプロシージャが来る。 ここではダミー値として#fを使っている。

         エンティティのインスタンスプールでペアになっている
                  /              \
 compute-apply-generic            \
          |     /                  \
 +--------|------------+  +---------+---------+---------+---------+
 |PROCをcallするclosure|・|  PROC   |<generic>| D  SUPS | METHODS |
 +---------------------+  +----|----+---------+---------+----|----+
          :                    |                             |
          :       .............|..........            (m1 m2 m3 ...)
          :       : (lambda (generic)    :             | (*)現時点のcompute-apply-generic
          :       :     (lambda args     :             |    のMETHODSは()だ
          :.......:          (apply ...  :     +-----+---------+------+-------+
                  : m1の実体のprocを     :     | TAG | <method>| spec |  proc |
                  :     callするclosure  :     +-----+---------+------+----:--+
                  :......................:                                 :
                                :..........................................:
                                  この点線は構造であって必ずしも自身の
                                  m1のprocをcallするわけじゃない。
                                  引数で渡されたgenericのm1のprocをcallする。
(%set-entity-proc! compute-apply-generic
     (lambda (generic)             ;The ONE time this is called
                                   ;it doesn't get cnm.
       (lambda args
         (apply (method-procedure (car (generic-methods generic)))
                (cons #f args))))) ;But, the ONE time it is run,
                                   ;it needs to pass a dummy
                                   ;value for cnm!

続くadd-methodによりcompute-apply-genericはこんな感じ。

         エンティティのインスタンスプールでペアになっている
                  /              \
 compute-apply-generic            \
          |     /                  \
 +--------|------------+  +---------+---------+---------+---------+
 |PROCをcallするclosure|・|  PROC   |<generic>| D  SUPS | METHODS |
 +---------------------+  +----|----+---------+---------+----|----+
          :                    |                             |
          :       .............|..........                  (m1)
          :       : (lambda (generic)    :             +-----+
          :       :     (lambda args     :             |
          :.......:          (apply ...  :     +-----+--------+---------+-------+
                  : m1の実体のprocを     :     | TAG |<method>|<generic>|  proc |
                  :     callするclosure  :     +-----+--------+---------+--|----+
                  :......................:                                 |
                              :            ................................|.....
                              :            : (lambda (call-next-method generic) :
                              :............:    (lambda args                    :
  この点線は構造であって必ずしも自身の     :      (if (and (memq ...            :
  m1のprocをcallするわけじゃない。         :....................................:
  引数で渡されたgenericのm1のprocをcallする。
  (*)一方、上の点線のPROCのcallは自身のベクタへ直結だ。

さて、このprocに格納された手続きは何をやるかを見てみよう。 基底条件と一般条件とに分ける。

(add-method compute-apply-generic
    (make-method (list <generic>)
      (lambda (call-next-method generic)
        (lambda args
          (if (and (memq generic generic-invocation-generics)     ;* G  c
                   (memq (car args) generic-invocation-generics)) ;* r  a
              (apply (method-procedure                            ;* o  s
                      (car (last-pair (generic-methods generic))));* u  e
                     (cons #f args))                              ;* n
                                                                  ;* d
              ((compute-apply-methods generic)
               ((compute-methods generic) args)
               args))))))

一般条件の第一引数((compute-methods generic) args)から見てみる。 この式は結果としてargs引数(これは複数あり得る)のクラスの組み合わせと genericに多重に定義されているメソッドの各々のクラス特定化子とから 適用可能なメソッドのリストを返すんだ。 しかもこのメソッドのリストは、より特定的なものからそうでないものへ 順にソートされている。 では(compute-apply-methods generic)は何を返すだろうか。

((compute-apply-method generic) (m1 m2 m3 m4 ...) args)

と引数の評価が済んだとしよう。

(lambda ()
  (apply m1のproc (*** . args)))

という形のthunkを返す。 ちなみに、***部分をもう一度だけ展開すると、

(lambda ()
  (apply m1のproc ((lambda ()
                      (apply m2のproc (*** . args))) . args))

以降、***の部分を展開し続けるとm3のproc、m4のproc...となる。 ちなみに、(apply m1のproc (*** . args)) ってのは (m1のproc *** args)と等価だね。 この***がm1のproc中においてはcall-next-methodというλ変数に束縛されるんだ。 つまり、m1メソッドの手続き実体にcall-next-methodなんてのが呼び出されてたら、 (m2のproc *** args)な感じの手続きが呼ばれることになるってことだね。

結局、まとめると一般的には(compute-apply-generic generic)は 引数となった総称関数が誰かから(generic args)なんて感じで呼ばれた時に、 どういう風にメソッドの適用をするか、 その決定方法を計算するプログラムを生成している。 上で示したthunkは実際argsが与えられた時に生成される、 メソッド適用の仕方そのものなんだ。

compute-apply-genericのメソッド定義再掲

(add-method compute-apply-generic
    (make-method (list <generic>)
      (lambda (call-next-method generic)
        (lambda args
          (if (and (memq generic generic-invocation-generics)     ;* G  c
                   (memq (car args) generic-invocation-generics)) ;* r  a
              (apply (method-procedure                            ;* o  s
                      (car (last-pair (generic-methods generic))));* u  e
                     (cons #f args))                              ;* n
                                                                  ;* d
              ((compute-apply-methods generic)
               ((compute-methods generic) args)
               args))))))

では次に基底条件の方を見てみる。 generic-invocation-genericはcompute-apply-generic、compute-methods、 compute-method-more-specific?、compute-apply-methodsの4つの総称関数のリストだ。 これらは通常の総称関数だが、その役割は特別でメソッドの適用部分の動作、 つまりTinyCLOSの動作そのものを規定するという立場の総称関数だ。 それらのcompute-apply-genericってのは、TinyCLOSのメソッドの適用が どう振舞うかを決めることになる。 結局、これら4種類の総称関数の振る舞い自体を決定する場合というのが 基底条件であり、その場合には(apply (method-procedure ...))式が評価される。

(apply (method-procedure
         (car (last-pair (generic-methods generic))))
       (cons #f args))

では、この式は何をするだろうか。 一言で言えば、その総称関数genericの最も特定的でないメソッドを評価せよ というプログラムを生成する。 (正しくは基底条件と一般条件をif分岐するプログラムを生成する。 プログラムを生成するという言いまわしをしているのは 全体としてクロージャを返していることを指している)

結局compute-apply-genericは一般的には特定的なものから順にcall-next-methodで 呼び出し可能なようにセッティングした上で メソッド適用の手順を計算するプログラムを生成し、 generic-invocation-genericな総称関数のメソッド適用については 最も特定的でない振る舞いをせよとしているようだ。

この辺は後でinitializeの立上げを行った後でもう一度振りかえることになるだろう。

次にcompute-methodsのメソッド定義だ。 compute-methodsは上記のcompute-apply-genericで使われるが、 引数genericに登録済みのメソッドから適用可能なメソッドを特定的な順に ソートするプログラムを返す。 このプログラムに具体的にargsが与えられると 具体的な適用可能ソート済みメソッドリストが返ってくるわけだ。
filter-inはsupport.scmにあり、(filter-in pred list)という形式で使用される。 list中のpredが真となるもののみのリストを返す。 gsortもsupport.scmにあり、これが特定的なものからそうでないものへ順にソートする。 使用する時の形式は(gsort pred list)だ。

(add-method compute-methods
    (make-method (list <generic>)
      (lambda (call-next-method generic)
        (lambda (args)
          (let ((applicable
                 (filter-in (lambda (method)
                              ;
                              ; Note that every only goes as far as the
                              ; shortest list!
                              ;
                              (every applicable?
                                     (method-specializers method)
                                     args))
                            (generic-methods generic))))
            (gsort (lambda (m1 m2)
                     ((compute-method-more-specific? generic)
                      m1
                      m2
                      args))
                   applicable))))))

compute-method-more-specific?は上記のcompute-methodsで使用され、 ソート時の述語として使われる。 二つのメソッドと呼び出された時の引数argsを伴ってcallされ、 argsのクラスの組から、m1メソッドとm2メソッドのどちらがより特定的かを判定する。 more specific m1 than m2なのでm1の方が引数argsに対して特定的なら#t、 m2の方がより特定的なら#fとなる。 ここで、引数の数などが異なっているとエラーを発生させる様になっているが、 compute-methodsでは適用不可なメソッドをフィルタリングする工程が先なので このエラーは通常発生しない。

(add-method compute-method-more-specific?
    (make-method (list <generic>)
      (lambda (call-next-method generic)
        (lambda (m1 m2 args)
          (let loop ((specls1 (method-specializers m1))
                     (specls2 (method-specializers m2))
                     (args args))
            (cond ((null? specls1) (return #t))     ;*Maybe these two
                  ((null? specls2) (return #f))     ;*should barf?
                  ((null? args)
                   (error "Fewer arguments than specializers."))
                  (else
                   (let ((c1  (car specls1))
                         (c2  (car specls2))
                         (arg (car args)))
                     (if (eq? c1 c2)
                         (loop (cdr specls1)
                               (cdr specls2)
                               (cdr args))
                         (more-specific? c1 c2 arg))))))))))

compute-apply-methodsはcompute-apply-genericの一般条件で使用されており、 適用可能なソート済みメソッドのリストを受取り、 どういうメソッド適用をするかのプログラムを組み上げて返す。 ここでone-step式により組み上げている部分はcall-next-methodに相当する部分だ。

(add-method compute-apply-methods
    (make-method (list <generic>)
      (lambda (call-next-method generic)
        (lambda (methods args)
          (letrec ((one-step (lambda (tail)
                               (lambda ()
                                 (apply (method-procedure (car tail))
                                        (cons (one-step (cdr tail))
                                              args))))))
            ((one-step methods)))))))
applicable?

適用可能かどうかの判定を行う述語。 cにはメソッドの特定化子がくる。argはmethodに渡される引数。 この引数のクラスからクラス優先度リストを取りだし、その中にcがあれば適用可能だ。 つまり、<integer>は<numer>のサブクラスなので、もし<number>に対して適用可能な メソッドがあって、<integer>に対して適用可能かと問われれば#tだ。 もちろん、これは可能かどうかを判断するだけで、適用されるかどうかは別だ。 より、特定的なメソッドが適用され、そうでないものはシャドウされるのが デフォルトの振るまいだからだ。

(define applicable?
    (lambda (c arg)
      (memq c (class-cpl (class-of arg)))))
more-specific?

c2よりc1が特定的かどうかを判定する述語。 引数の順序はmore specific c1 than c2 in which case argument is arg といった感じだろうか。 argが実際の引数。argのクラス優先度リストを取りだすと、自身のクラスから<top> までの全体としては祖先に向かう順序でのクラスリストが得られる。 c1がc2より特定的ならclass-cplは(... c1 ... c2 ...)となっているので、 この式では#f以外となる。 一方c2の方がc1より特定的なら(... c2 ... c1 ...)となっているのでこの式は#fを返す。

(define more-specific?
    (lambda (c1 c2 arg)
      (memq c2 (memq c1 (class-cpl (class-of arg))))))

initializeメソッドの定義がずらずら。 <object>、<class>、<generic>、<method>の4種類のクラスに対して多重定義する。 initializeは最後に定義される正規のmakeにて使われているので、 そちらを先に見ておくと良いだろう。 (もちろん公開された関数である以上、ユーザが自由に呼び出して良いだろう)

<object>クラスの初期化

<object>クラスのインスタンスを初期化しても実際には何もしない。 単に引数となっていたobjectを返すのみだ。 初期化引数initargsが仮に'()でなくても意味を持たない。

(add-method initialize
    (make-method (list <object>)
      (lambda (call-next-method object initargs) object)))

<class>クラスの初期化

<class>クラスのインスタンスの初期化を行う。 まず、call-next-methodをcallしている。

(add-method initialize
    (make-method (list <class>)
      (lambda (call-next-method class initargs)
        (call-next-method)

ここから<class>の直接スロットの初期化処理を行っている。 まずはdirect-supersスロットにinitargs中のdirect-supersと対で 渡された値を代入する。

        (slot-set! class
                   'direct-supers
                   (getl initargs 'direct-supers '()))

引き続きdirect-slotsスロットへの代入。 こちらはinitargsのdirect-slots中の対で渡された値を取りだし、 各要素が各々リストになるようにして取りこんでいる。 (つまり、元がペアならそのまま、ペアでなければリストにしている。)

        (slot-set! class
                   'direct-slots
                   (map (lambda (s)
                          (if (pair? s) s (list s)))
                        (getl initargs 'direct-slots  '())))

さらにcpl、つまりクラス優先度リストだ。 こちらは単純ではなく、compute-cplにてクラス優先度を計算したものを代入。 どんな計算なのかについては後ででてくる。 ざっくり言えば、継承関係を計算して全体的には 子から親方向へのソートをしたものを返してくると思えば良いだろう。

        (slot-set! class 'cpl   (compute-cpl   class))

同じくslotsスロット。こちらもcompute-slotsにより計算される。 継承関係を計算して、自身のクラスの直接スロットだけでなく スーパークラスのスロットを継承して、デフォルトでは全スロットの論理和となる スロットのリストを代入すると思えば良いだろう。

        (slot-set! class 'slots (compute-slots class))

nfields、field-initializersおよびgetters-n-settersを初期化している。 順番にnfieldsを0からインクリメントしつつ、 initargsで渡された各スロットに対応するgetters-n-settersを計算している。

allocatorはちょっと置いておいて、getters-n-settersに目を向けると、 これはclassのslotsスロットの値から得たスロット名と そのスロットのgetterとsetterとをリストにしたものに束縛される。
このgetterとsetterを算出するのにcompute-getter-and-setterを用いており、 この時に先のallocatorが渡されている。 つまり、allocatorはgetterとsetterを生成するロジックの中でのみ使われており、compute-getter-and-setterからはallocator経由で制限的にのみ、 この局所環境にアクセス可能となる。 いかにもクロージャを使ったスマートなやり口だと思う。 ちなみにこのallocator自体は以前も出てきたものと同じなので省略。

        (let* ((nfields 0)
               (field-initializers '())
               (allocator
                (lambda (init)
                  (let ((f nfields))
                    (set! nfields (+ nfields 1))
                    (set! field-initializers
                          (cons init field-initializers))
                    (list (lambda (o)   (get-field  o f))
                          (lambda (o n) (set-field! o f n))))))
               (getters-n-setters
                (map (lambda (slot)
                       (cons (car slot)
                             (compute-getter-and-setter class
                                                        slot
                                                        allocator)))
                     (slot-ref class 'slots))))

ここでnfieldsをインクリしながら計算したnfields、field-initializersおよび getters-n-settersを実際にclassのスロットに格納する。

          (slot-set! class 'nfields nfields)
          (slot-set! class 'field-initializers field-initializers)
          (slot-set! class 'getters-n-setters getters-n-setters)))))

<generic>クラスの初期化

<generic>クラスではこの辺は簡単。 call-next-methodを処理してから、methodsスロットを一旦()で初期化。 それからprocをエラー関数で初期化するだけ。

(add-method initialize
    (make-method (list <generic>)
      (lambda (call-next-method generic initargs)
        (call-next-method)
        (slot-set! generic 'methods '())
        (%set-entity-proc! generic
                           (lambda args (error "Has no methods."))))))

<method>クラスの初期化

<method>クラスも<generic>クラスと同じ。 call-next-methodを処理したら、specializersとprocedureの両スロットに引数にて 与えられた初期値を代入する。

(add-method initialize
    (make-method (list <method>)
      (lambda (call-next-method method initargs)
        (call-next-method)
        (slot-set! method 'specializers (getl initargs 'specializers))
        (slot-set! method 'procedure    (getl initargs 'procedure)))))

<class>のアロケート

この<class>に対するallocate-instanceと 次に出てくる<entity-class>に対するallocate-instanceとが 最初に出てきた%allocate-instanceと%allocate-entityのユーザ向けメソッドになる。 これでユーザからは実体の違いを一切意識しなくて済む。

<class>に対するallocate-instanceの中身は何をやっているだろう。 まずスロットの初期化を行うためのfield-initializerと、 そのスロット数分の実体となるメモリを取得する。 それぞれfield-initializersとnewのことだ。 ここでスロットの初期化のためのロジックはclassが持っている値を使っている。 つまり、クラス自身が自身のクラスのスロットの初期化ロジックを field-initializersスロットに持っているので、それに従うのだ。 この機構ゆえにクラスによって初期化の振る舞いすら変更できるわけだ。 Scheme:MOP:InstancePoolでやってみせているのは、まさにそれだ。

(add-method allocate-instance
    (make-method (list <class>)
      (lambda (call-next-method class)
        (let* ((field-initializers (slot-ref class 'field-initializers))
               (new (%allocate-instance
                      class
                      (length field-initializers))))
          (let loop ((n 0)
                     (inits field-initializers))
            (if (pair? inits)
                (begin
                 (%instance-set! new n ((car inits)))
                 (loop (+ n 1)
                       (cdr inits)))
                new))))))

<entity-class>のアロケート

<entity-class>に対するallocate-instanceだ。 つまり<generic>のコンストラクタということになる。

内部でやっていることを確認しよう。 ここも良く見ると結局上の<class>に対するallocate-instanceと同じだ。 違いは%-prefixな低水準関数のみだ。

(add-method allocate-instance
    (make-method (list <entity-class>)
      (lambda (call-next-method class)
        (let* ((field-initializers (slot-ref class 'field-initializers))
               (new (%allocate-entity
                      class
                      (length field-initializers))))
          (let loop ((n 0)
                     (inits field-initializers))
            (if (pair? inits)
                (begin
                 (%entity-set! new n ((car inits)))
                 (loop (+ n 1)
                       (cdr inits)))
                new))))))

compute-cpl

クラス優先度リストの計算を行うメソッド。 実質compute-std-cplに丸投げしているので、こちらを確認する。 トポロジカルソート自体は この文書 あたりに丁寧な解説があるので参照されたい。
結論だけ知りたければ、およそクラスの(多重の)継承関係を整列させて、 全体を通してどこを見ても子孫と先祖がテレコにならないようにするんだ。 compute-cplの場合、引数のclassのスーパークラスについて、 <top>まで遡る全てのスーパークラスを今説明した様に整列させる。
ただし、これも基本形であり、compute-cpl自体が<class>に対する振る舞いとして 初期的に導入されているにすぎない。

(add-method compute-cpl
    (make-method (list <class>)
      (lambda (call-next-method class)
        (compute-std-cpl class class-direct-supers))))

compute-std-cplはsupport.scmにあり、top-sort、build-transitive-closure、 build-constraintsそしてstd-tie-breakerが呼ばれているので全部確認する。

compute-std-cpl

クラス優先度リストを算出する。 本体はトポロジカルソートしているだけだが、 このロジック自体は汎用性があるもの。 top-sortの三つの引数の計算するものは後で出て来る。

(define compute-std-cpl
    (lambda (c get-direct-supers)
      (top-sort ((build-transitive-closure get-direct-supers) c)
                ((build-constraints get-direct-supers) c)
                (std-tie-breaker get-direct-supers))))

top-sort

トポロジカルソート本体。 elementsには((build-transitive-closure get-direct-supers) c)の結果が来るので cのスーパークラスの<top>まで遡れる全てのクラスのリストがくる。 ((build-constraints get-direct-supers) c)には elements中のクラスのそれぞれの制約(親子関係)ペアが来る。 多重継承してても親としては一つしか来ないことに注意。 つまり、この親クラスより必ず左に来ないとダメなのである。

resultにはよりサブクラスに近いものから順にクラスが蓄積されていく。 <top>が最後にリスト末尾に取り込まれる順だ。

can-go-in-nowにはelementsのクラスの中から、 全ての制約において親クラス側に存在しないものが取り込まれる。 仮に親クラス側にあったとしてもそのサブクラスが既にresultに取り込まれていれば 順序制約を侵さないので一応候補となる。

つまりcan-go-in-nowには、 次にresultに取り込まれる可能性のあるクラスが存在することになる。

(define top-sort
    (lambda (elements constraints tie-breaker)
      (let loop ((elements    elements)
                 (constraints constraints)
                 (result      '()))
        (if (null? elements)
            result
            (let ((can-go-in-now
                    (filter-in
                      (lambda (x)
                        (every (lambda (constraint)
                                 (or (not (eq? (cadr constraint) x))
                                     (memq (car constraint) result)))
                               constraints))
                      elements)))
              (if (null? can-go-in-now)
                  (error 'top-sort "Invalid constraints")
                  (let ((choice (if (null? (cdr can-go-in-now))
                                    (car can-go-in-now)
                                    (tie-breaker result
                                                 can-go-in-now))))
                    (loop
                      (filter-in (lambda (x) (not (eq? x choice)))
                                 elements)
                     ;(filter-in (lambda (x) (not (eq? (cadr x) choice)))
                     ;           constraints)
                      constraints
                      (append result (list choice))))))))))

std-tie-breaker

partial-cplはトポロジカルソートでソート済みのサブクラスのリストが、 min-eltsにはcan-go-in-now、 つまり次にresultに追加される候補クラスのリストが来る。 pcplはpartial-cplのことで、 ds-of-ceはdirect-supers-of-current-eltの略と思われる。 min-eltsの候補クラス内、partial-cplの最も<top>に近い方の スーパークラスの直接スーパークラスだけを抽出してcommonに束縛。 この様にして見付かるcommonの最初の要素を ((std-tie-breaker get-supers) partial-cpl min-elts)の返り値とする。

tie breakというのは同点決勝のことだ。 top-sort中でcan-go-in-nowという、 次にresult(トポロジカルソート済みクラスリスト)に追加される 可能性のあるクラスが複数あった時、同点決勝が行われる。 その同点決勝における勝敗の決定アルゴリズムが このstd-tie-breaker式により決められる事になる。

(define std-tie-breaker
    (lambda (get-supers)
      (lambda (partial-cpl min-elts)
        (let loop ((pcpl (reverse partial-cpl)))
             (let ((current-elt (car pcpl)))
               (let ((ds-of-ce (get-supers current-elt)))
                 (let ((common (filter-in (lambda (x)
                                            (memq x ds-of-ce))
                                          min-elts)))
                   (if (null? common)
                       (if (null? (cdr pcpl))
                           (error 'std-tie-breaker "Nothing valid")
                           (loop (cdr pcpl)))
                       (car common)))))))))

build-transitive-closure

((build-transitive-closure get-direct-supers) class)という形で 呼び出された場合で考えるのが良いだろう。 letループではresultが累積変数として使われている。 pendingには、クラスの一時保管場所の様になっており、 初期は一つのクラスだけがリストに入っている。

pendingからクラスをpopして、それがすでにresultに含まれていれば何もしない。 含まれていなければ、一旦そのクラスのスーパークラスをpendingにpushして、 letループを繰り返す。 結果としてresultにはxとして渡されたclassから遡れる 全スーパークラスのリストを返すことになる。 これは重複するクラスが含まれないようにしている。

(define build-transitive-closure
    (lambda (get-follow-ons)
      (lambda (x)
        (let track ((result '())
                    (pending (list x)))
             (if (null? pending)
                 result
                 (let ((next (car pending)))
                   (if (memq next result)
                       (track result (cdr pending))
                       (track (cons next result)
                              (append (get-follow-ons next)
                                      (cdr pending))))))))))

build-constraints

((build-constraints get-direct-supers) class)という形で 呼び出された場合で考えるのが良いだろう。 やはり、get-follow-onsにはget-direct-supersが渡され、 xにはclassが来ると思えば良い。 ここでもresultがletループ中の累積変数として使われる。 elementsには初期データとしてxからたどれるスーパークラスが全て含まれる。 つまり、ご先祖さまが全員集合状態になっている。 this-oneはクラスとそのクラスの直接スーパークラスとが ペアで一時保管されるための変数だ。 this-oneが空ならelementsから一つクラスを取り出して、 このクラスとその直接スーパークラスとをペアにしたものを this-oneとしてletループをまわす。 this-oneが枯渇したらelementsからまた一つクラスを取り出す。

if式の真の場合の処理はelementsを消化してthis-oneに親子を一つ追加する。 偽の場合の処理はthis-oneを消化して親子をresultに蓄積する。

結局クラスとそのスーパークラスのペアのリストを返すことになる。 ここでペアになるのは最初のスーパークラスのみだ。 多重継承していた場合は、その内のcarになるクラスのみである。 恐らくこれがconstraint、つまり順序制約になるという事だろう。 つまり、クラスの親子関係がまとまっているので、トポロジカルソートでは この制約群を満たす様に並び換えないとならないのだ。

(define build-constraints
  (lambda (get-follow-ons)
    (lambda (x)
      (let loop ((elements ((build-transitive-closure get-follow-ons) x))
                 (this-one '())
                 (result '()))
           (if (or (null? this-one) (null? (cdr this-one)))
               (if (null? elements)
                   result
                   (loop (cdr elements)
                         (cons (car elements)
                               (get-follow-ons (car elements)))
                         result))
               (loop elements
                     (cdr this-one)
                     (cons (list (car this-one) (cadr this-one))
                           result)))))))

compute-slots

クラスのスロットになるものを計算するメソッド。 継承関係を考えてスロットの算出を行う。 最初to-processにはcplに含まれるクラス(つまり自身のクラスを含むクラス)群の 直接スロットを全部まとめたものが束縛される。 これは集合としては重複していたりもするだろうが足りないものはないはずだ。 resultはいわゆる累積変数のような使い方をするので最初は()だ。
最終的にto-processが()になったらresultをreverseして返す。 to-processにスロットの候補があれば、let*部分が評価される。 to-processから先頭要素(スロットの候補)を取り出して、スロット名をnameに束縛。 remaining-to-processにはnameと違うスロット名のスロットをかき集め、 othersには同じスロット名のスロットを集める。 要はスロット名で振り分けている。 これを繰り返すことになるが、 othersからはその都度optionが抽出されてcurrentに抱き合わせられる。

ということで、結局compute-slotsはスロット名の重複を取り除くものの、 スロットオプションについてはスーパークラスのものもかき集めてまとめあげている。

(add-method compute-slots
    (make-method (list <class>)
      (lambda (call-next-method class)
        (let collect ((to-process (apply append
                                         (map class-direct-slots
                                              (class-cpl class))))
                      (result '()))
          (if (null? to-process)
              (reverse result)
              (let* ((current (car to-process))
                     (name (car current))
                     (others '())
                     (remaining-to-process
                      (collect-if (lambda (o)
                                    (if (eq? (car o) name)
                                        (sequence
                                         (set! others (cons o others))
                                         #f)
                                        #t))
                                  (cdr to-process))))
                (collect remaining-to-process
                         (cons (append current
                                       (apply append (map cdr others)))
                               result))))))))

compute-getter-and-setter

getterとsetterを計算して返す。 こいつの振る舞いはallocatorとして渡されたプロシージャ次第。 <class>の場合について言えば<class>の初期化処理initializeにて使われるが、 allocatorの引数のthunkはfield-initializerになる。 これでclassのスロット数をインクリメントして、 スロットの初期化関数として(lambda () '())を登録し、 最後にそのスロットへのgetterとsetterをリストにして返す。 このgetterとsetterはallocator自身が内部に持っている状態でここに登場している。

(add-method compute-getter-and-setter
    (make-method (list <class>)
      (lambda (call-next-method class slot allocator)
        (allocator (lambda () '())))))

make

今や総称関数もクラスも全てが動く様になっている。 というわけで、本当のMAKEに切り替えることができる。

;
; Now everything works, both generic functions and classes, so we can
; turn on the real MAKE.
;
;
make

正式版のmake。 ブート後の正規のmakeでは引数にclassとclass固有の引数initargsを取る。 makeはまず、classのインスタンス実体のメモリアロケーションを行い、 そのインスタンスをinitargsで初期化する。 最後に初期化済みのインスタンスを返す。 一般に初期化処理はクラスにより様々な処理を行うので一概に何をするとは言えない。

(set! make
      (lambda (class . initargs)
        (let ((instance (allocate-instance class)))
          (initialize instance initargs)
          instance)))

primitive class

それでは、CLOSで`組み込み'クラスというものを定義しよう。

;
; Now define what CLOS calls `built in' classes.
;
;
(define <primitive-class>
    (make <class>
          'direct-supers (list <class>)
          'direct-slots  (list)))

(define make-primitive-class
    (lambda class
      (make (if (null? class) <primitive-class> (car class))
            'direct-supers (list <top>)
            'direct-slots  (list))))

(define <boolean>   (make-primitive-class))
(define <symbol>    (make-primitive-class))
(define <char>      (make-primitive-class))
(define <vector>    (make-primitive-class))
(define <pair>      (make-primitive-class))
(define <number>    (make-primitive-class))
(define <string>    (make-primitive-class))
(define <procedure> (make-primitive-class <procedure-class>))

じゃーん。こんな感じのクラス階層になる。

                              metaclass: <class>
 ..............................................................
 :                                                            :
 :                                <top>                       :   metaclass:
 :                                / | \                       :   <procedure-clas>
 :                               /  |  \                      :   ..............
 :    +--------+-------+--------+   |   +-------+--------+--------------+      :
 :    |        |       |        |   |   |       |        |    :   :     |      :
 :<boolean> <symbol> <char> <vector>| <pair> <number> <string>:   :<procedure> :
 :........................          |                         :   :            :
                         :          |                         :   :............:
    metaclass:           :          |                         :
    <entity-class>       :       <object>                     .............
     ................    :       /  |  \                                  :
     :      +-------------------+   |   +-------------+                   :
     :      |       :    :          |                 |                   :
     :   <generic>  :    :       <class>         <method>                 :
     :              :    :          | \                                   :
     :..............:    :          |  +--------------+                   :
                         :          |                 |                   :
                         :   <procedure-class>   <primitive-class>        :
                         :          |                                     :
                         :     <entity-class>                             :
                         :                                                :
                         :                                                :
                         :................................................:

おしまい。

これにてtiny-closが立ち上がり、走っている。

;
; All done.
;
;

'tiny-clos-up-and-running

コメント

teranishi(2005/03/11 14:07:40 PST): 総称関数の説明ですが、compute-apply-generic の呼び出し処理の説明ばかりで、 それ以外の総称関数の呼び出し処理の説明が不十分です。
compute-apply-generic は、あくまで bootstrap のための特殊処理なので、 一般の総称関数とは異なる処理が行われています。 その点をきちんと説明すべきだと思います。
一般の総称関数において、ベクタの0番目の要素(図のPROCにあたる要素)に どんなクロージャが束縛されるかが、説明の手がかりになると思います。
あと、(add-method compute-apply-generic ...) を実行すると、 compute-apply-generic の PROC が 実行前とは別のクロージャに置き換わる事にも注意してください。

cut-sea(2005/03/11 15:23:37 PST): thanx.実は説明調に仕上げたいのでそういう感じで書いてますが、 自分自身よくわからず、読みながら勉強している状況なので、 まだまだこれからって感じです。 まさにご指摘の箇所が今のところ十分イメージ出来てないんですよ。(+_+;)
今、compute-系が呼び出されたときのcompute-系の処理がどうなるかってのが 分からないとダメだと思って読んでるんですが、 全体の関係がなかなか頭の中に整理しきれておらず。orz
この辺は後続のinitializeも読んだりしながら、 何回か戻っては書き直すことになるかなぁと漠然と思ってたんですが、 指針になるようなコメントありがとうございます。 その辺に気をつけてじっくり読み込んでいきます。

teranishi(2005/03/17 05:37:27 PST): Tiny CLOS を Gauche で動かすための patch を作ってみました。 ただし、このコードを正常に動作させるためには、 gosh 起動時に'-fno-inline'オプションをつける必要があります。

diff -u tiny-clos/support.scm tiny-clos-gauche/support.scm
--- tiny-clos/support.scm       Wed Aug 18 08:27:22 1993
+++ tiny-clos-gauche/support.scm        Tue Mar  8 22:53:23 2005
@@ -41,11 +41,12 @@
 ;
 ;
 (define what-scheme-implementation
-  'mit
+ ;'mit
  ;'chez
+  'gauche
   )
 
-(case what-scheme-implementation
+#|(case what-scheme-implementation
   ((mit)
    (syntax-table/define                    ;Kind of like DEFMACRO
      user-initial-syntax-table             ;  lifted from Cornell.
@@ -58,12 +59,12 @@
               (QUOTE ,(car formals))
               ,(append (list 'MACRO (cdr formals)) body)))))
   ((chez)
-   ???))
+   ???))|#
 
 
 (define gsort
   (case what-scheme-implementation
-    ((mit)  (lambda (predicate list) (sort list predicate)))
+    ((mit gauche)  (lambda (predicate list) (sort list predicate)))
     ((chez) (lambda (predicate list) (sort predicate list)))))
 
 (define simple-printer (lambda () barf))
diff -u tiny-clos/tiny-clos.scm tiny-clos-gauche/tiny-clos.scm
--- tiny-clos/tiny-clos.scm     Wed Aug 18 08:27:24 1993
+++ tiny-clos-gauche/tiny-clos.scm      Sat Mar 12 08:50:29 2005
@@ -185,7 +185,7 @@
      (unparser/set-tagged-vector-method!      ;Make objects print a bit
       instance-tag                            ;more reasonably.  Scheme
       (unparser/standard-method 'object)))    ;is pretty feeble in this
-    ((chez)))                                 ;regard.
+    ((chez gauche) #f))                       ;regard.
 
   (set! %allocate-instance
        (lambda (class nfields)
@@ -235,7 +235,7 @@
         (get-vector
          (lambda (closure)
            (let ((cell (assq closure entities)))
-             (if (null? cell) #f (cdr cell)))))
+             (if (not cell) #f (cdr cell)))))
         (default-proc
             (lambda args
               (error "Called entity without first setting proc."))))
@@ -251,7 +251,7 @@
            closure)))
                   
   (set! %entity?
-        (lambda (x) (not (null? (get-vector x)))))
+        (lambda (x) (not (not (get-vector x)))))
 
   (set! %entity-class
        (lambda (closure)
@@ -413,7 +413,7 @@
                   getters-n-setters-for-class   ;* the slot-ref tower.
                   (slot-ref class 'getters-n-setters)))
             (entry (assq slot-name getters-n-setters)))
-       (if (null? entry)
+       (if (not entry)
            (error "No slot" slot-name "in instances of" class)
            (cdr entry)))))
 
@@ -661,8 +661,8 @@
          (let loop ((specls1 (method-specializers m1))
                     (specls2 (method-specializers m2))
                     (args args))
-           (cond ((null? specls1) (return #t))     ;*Maybe these two
-                 ((null? specls2) (return #f))     ;*should barf?
+           (cond ((null? specls1) #t)     ;*Maybe these two
+                 ((null? specls2) #f)     ;*should barf?
                  ((null? args)
                   (error "Fewer arguments than specializers."))
                  (else
@@ -808,7 +808,7 @@
                     (remaining-to-process
                      (collect-if (lambda (o)
                                    (if (eq? (car o) name)
-                                       (sequence
+                                       (begin
                                         (set! others (cons o others))
                                         #f)
                                        #t))
diff -u tiny-clos/tiny-examples.scm tiny-clos-gauche/tiny-examples.scm
--- tiny-clos/tiny-examples.scm Wed Aug 18 08:27:25 1993
+++ tiny-clos-gauche/tiny-examples.scm  Tue Mar  8 22:22:55 2005
@@ -80,7 +80,7 @@
 ;
 ;
 
-(define <pos>)
+(define <pos> #f)
 (define pos-x (make-generic))
 (define pos-y (make-generic))
 (define move  (make-generic))
@@ -213,13 +213,13 @@
                   (alist-setter (cadr g-n-s)))
              (list (lambda (o)
                      (let ((entry (assq name  (alist-getter o))))
-                       (if (null? entry)
+                       (if (not entry)
                            '()
                            (cdr entry))))
                    (lambda (o new)
                      (let* ((alist (alist-getter o))
                             (entry (assq name alist)))
-                       (if (null? entry)
+                       (if (not entry)
                            (alist-setter o
                                          (cons (cons name new) alist))
                            (set-cdr! entry new))

あと、Tiny CLOS 入門というページを見つけました。 こちらは、実装ではなく使い方の説明のようですが。

Tag: CLOS

More ...