picrin-call-next-method.scm

まず、nominalな継承関係はないので、ここでの継承関係とはクラス<A>と<B>の包含関係が

  A \subset B

であることします。ようするに

  (instanceof? x A) => (instanceof? x B)

みたいな感じですね。これを実現するためにクラス間の継承関係を*あとづけ*できるようにします。

  (define-record-type class (make-class membership) class?
    (membership class-membership)
    (inclusions class-inclusions set-class-inclusions!))

inclusionsはそのクラスが何に含まれるかを表します。型はクラスのリストです。そして

  (define-inclusion <A> <B>)

と書けば<A> \subset <B>を定義できるようにします。

  (define (define-inclusion sub super)
    (set-class-inclusions! sub (cons super (class-inclusions sub))))

これでクラスをノードとする継承グラフが出来ました。そうなるとメソッド間にも包含関係ができます
(たとえばある引数群がmethodAにapplicativeならmethodBにもapplicativeである、のような)。
メソッドを新たに登録する際にはこのグラフを作成しておき、さらにメソッド達を特定的な順に
トポロジカルソートしてジェネリクスに登録しておくことになります。

  (define (add-method generic method types)
     ; 今までは単にgenericにmethodをpushしてたが
     ; 特定度でグラフを作成したあと、
     ; トポロジカルソートしたリストも追加する
     ...)

メソッドディスパッチの際にはより特定的なメソッドから順にapplicative?かどうかを調べていきます。

  (define (find-methods generic args)
    ; genericからメソッドテーブルを引いてきて
    ; 順番にapplicative?かどうか調べる
    ; あるメソッドがヒットしたら、メソッド継承グラフを見て
    ; 適用可能なメソッドリストを返す
    ...)

実際にディスパッチするmake-genericの中の高階関数はfind-methodsの結果を加工します。call-next-methodを
利用できるようにパラメータの状態を切替えます。

  (define *methods-on-going* (make-parameter '()))
  (define *arguments-on-going* (make-parameter '()))

  (define make-generic
    (lambda ()
      (letrec ((self (lambda args
                       (let ((ms (find-methods self args)))
                         (if ms
                             (parameterize ((*methods-on-going* (cdr ms))
                                            (*arguments-on-going* args))      ; <- ココ
                                (apply (car ms) args))
                             (error "method not found"))))))
        (add-generic self)
        self)))

これで、call-next-methodが作れるようになりました。

   (define (call-next-method)
     (let ((ms (*methods-on-going*)))
       (if (null? ms)
           (error "no more next method")
           (parameterize ((*methods-on-going* (cdr ms)))
             (apply (car ms) (*arguments-on-going*))))))

実際に追加するならcall-next-methodと全く同じインターフェイスは採用しないしパフォーマンスを出すために
もうちょいチューニングしますが、だいたいイメージ的にはこんな感じです。