Scheme:MOP:議論

MOPに関する議論，質問，その他の起点にでも．

generic-applyのカスタマイズ

ねるWiki:ねる2004/05/21 11:03:24 PDT

下のコードのように<generic>のサブクラス<wrapper-generic>を作り，<wrapper-generic>のインスタンスの総称関数に対する適用を特定化したapply-generic methodを定義することにより実現しています．これを読んでいてすこし疑問がわきました．

• apply-generic ((gf <generic>) args)そのものを上書きすることはしないものなんでしょうか．

• 下記のように元からある総称関数を同名の(<test-generic>に所属する)総称関数で上書きすると，元のx->stringが使えなくなります．適宜，他の総称関数に:forwardなんかでforward指定できると良さそうですが，そういうことはしないものなんでしょうか．

  (define-class <test-generic> (<generic>) ())
  (define-generic x->string :class <test-generic>)
  

• apply-genericのカスタマイズをばりばり使ったコードとかはどこかで読めないでしょうか．いまいち応用のしかたがつかめません．

以下，Gauche/test/object.scmより抜粋

;;----------------------------------------------------------------
(test-section "method application customization")

;; The original example of <wrapper-generic> is presented by Alex Shinn.

(define-class <wrapper-generic> (<generic>) ())

(define-method write-object ((obj <wrapper-generic>) port)
  (format port "#<wrapper-generic ~a>" (ref obj 'name)))

(define-method object-unwrap (obj pass fail)
  (fail))

(define-method apply-generic ((gf <wrapper-generic>) args)
  (let ((methods (compute-applicable-methods gf args)))
    (if (pair? methods)
      (apply-methods gf (sort-applicable-methods gf methods args) args)
      (let loop ((ls args) (rev '()))
        (if (null? ls)
          (errorf "no applicable method for ~S with arguments ~S" gf args)
          (object-unwrap
           (car ls)
           (lambda (obj)
             (apply-generic gf (append (reverse rev) (list obj) (cdr ls))))
           (lambda () (loop (cdr ls) (cons (car ls) rev)))))))))

(define-class <ci-string> ()
  ((value :init-keyword :value)))

(define (ci-string str) (make <ci-string> :value str))

(define-method object-unwrap ((obj <ci-string>) pass fail)
  (pass (ref obj 'value)))

(define-generic concat :class <wrapper-generic>)
(define-method concat () "")
(define-method concat ((a <string>)) a)
(define-method concat ((a <string>) (b <string>))
  (string-append a b))
(define-method concat ((a <string>) (b <string>) c . rest)
  (string-append a b (apply concat c rest)))

(test* "<wrapper-generic>" "aBciIiXyZ"
       (concat (ci-string "aBc") "iIi" (ci-string "XyZ")))

--