unacowa

継承時にスーパークラスのslot option をマージするメタクラス

Gauche のリファレンスに、

たとえば、同じスロット名のスロットオプションはどれかが他のものをシャドウしますが、これをマージすることができるようにメタクラスを書くことができます。

とあるので、書いてみた。が、わからなかった。

Lingr で、compute-slots を定義する。とアドバイスをいただいたので、

(use util.list)
(use srfi-1)

(define-class <append-slot-options-meta> (<class>)
  ())

(define-method compute-slots ((class <append-slot-options-meta>))
  (letrec ((cpl (slot-ref class 'cpl))
           (slots '())
           (delete-keyword* (lambda (keys kv-list)
                              (if (null? keys)
                                  kv-list
                                  (delete-keyword* (cdr keys) (delete-keyword (car keys) kv-list)))))
           (slot-marge (lambda (old new)
                         (append new (delete-keyword* (filter keyword? new) (cdr old))))))
    (for-each (lambda (c)
                (for-each (lambda (slot)
                            (if (assq (car slot) slots)
                                (assq-set! slots (car slot) (cdr (slot-marge slot (assq (car slot) slots))))
                                (set! slots (cons slot slots))))
                          (slot-ref c 'direct-slots)))
              cpl)
    (reverse slots)))

(define-class <append-slot-options-mixin> ()
  ()
  :metaclass <append-slot-options-meta>)

としてみたが、

(use gauche.mop.validator)
(define-class <v> (<validator-mixin>)
  ((a :accessor a-of
      :validator (lambda (obj value) (x->string value)))
   (b :accessor vb-of)))

(define-class <w> (<v> <append-slot-options-mixin>)
  ((b :accessor wb-of
      :validator (lambda (obj value) (x->string value)))))

(define test (make <v>))
(slot-set! test 'a 'foo)
(slot-ref test 'a)
(slot-set! test 'b 'bar)
(wb-of test) ;; returns ERROR ... OK
(vb-of test) ;; returns 'bar ... OK

(define test (make <w>))
(slot-set! test 'a 'foo)
(slot-ref test 'a)
(slot-set! test 'b 'bar)
(wb-of test) ;; returns "bar" ... OK
(vb-of test) ;; returns "bar" ... ERROR.  I hope return ERROR.
(set! (wb-of test) 'hoge)
(set! (vb-of test) 'fuga)
(wb-of test) ;; return "fuga"
(vb-of test) ;; return "fuga"

(class-slots <v>) ;; ((a :accessor a-of :validator #<closure #f>) (b :accessor vb-of)) ...OK
(class-slots <w>) ;; ((b :accessor wb-of :validator #<closure #f>) (a :accessor a-of :validator #<closure #f>)) ...OK

となって、うまくいかなかった。

正直、煮詰まってきているので、だれかヒントください。

• Shiro(2008/06/27 05:50:43 PDT): うーん、ちゃんと動いているように見えるのですが、 どういう動作を想定しているのでしょう? もしかしてvb-ofを使った時は <w>のbのスロットオプションを無視するように動作してほしいとか?
  アクセサはあくまで (slot-ref obj 'slot-name) の短縮形でしかないので vb-ofを<w>のインスタンスに適用しても(slot-ref <w>のインスタンス 'b)という 動作にしかならない(したがってvalidator経由になる)のです。 多態性の意味を考えれば自然な動作だと思います。
  意図としてはvalidatorを経由しないパスを残しておきたいという ことかと思うのですが、validatorはそもそもそういうパスを完全に隠すのが 目的なので、今回の用途にはふさわしくないのではないかと。 virtualかpropagateスロットを使う方が設計としては自然だと思います。 何らかの事情でどうしてもvalidatorを使わなければならないのだとしたら、 validator-mixinの定義の方をサブクラスしていじくればできそうな 気もしますが、やってみないとはっきりとはわかりません。
• unacowaわかってきました。
  実はもっとくだらない話で、*** ERROR: no applicable method for #<generic vb-of (1)>を期待していました。
  (vb-of test) が、総称関数だということに気がついていませんでした。であれば、確かにこの結果は正しいですね。だんだんclosがわかってきました。ありがとうございます。

意図としてはvalidatorを経由しないパスを残しておきたいということかと思うのですが、....は、
cplで決定されるメソッドの適応先オブジェクトは、cplでマッチしたクラスに対してではなく、cplでマッチすれば、あくまでそのメソッドが引数の束縛されているインスタンスに対して適応されるという事ですよね。(もっと高次元な話なのだとは思うけど)

(define-class <v> ()
  ((a :accessor a-of)
   (b :accessor vb-of)))

(define-class <w> (<append-slot-options-mixin> <validator-mixin> <v>)
  ((b :accessor wb-of
      :validator (lambda (obj value) (x->string value)))))

(d vb-of) ;;   methods   : (#<method (vb-of <v>)>)

(class-precedence-list <w>) ;; returns (#<class <w>> #<class <append-slot-options-mixin>> 
                            ;; #<class <validator-mixin>> #<class <v>> #<class <object>> #<class <top>>)

としたとき、総称関数 vb-of は、cplに従って、<v>のインスタンスであるtestに適応される。これも当然。でもなんか勉強になった気がするので書いておこうっと。