GaucheNight(2007/5/9)でのcut-seaのネタでした。
プレゼンで説明したけど、元ネタはACLセミナー2006の黒田寿男氏によるセッションです。
こいつを私がカッコイイと思うのは、他の言語ではちょっとマネできないでしょう？ってこと。 オブジェクトシステムの仕様を変更しちゃうわけだから、MOPのない言語じゃダメだよね。 当時このセミナーで薫陶を受けた私が以下のような感想を書いてます。
結局ね、最近個人的にキレイかどうかの議論に没入しがちなんだけど、 こういう、無理そうなものを可能にする泥臭い処理をやってみせることこそが Lispを認めさせる道なんだろうなぁ。
(中略)
でもSchemeも同じはず。多分Practicalだということを証明するためには、 どうであれ動作するものを見せるしかないんだなぁと。 11/23は早速同じようなMOPいじり倒しのメタクラスをGaucheで書いてみる。 実際そうしてるんだから当然なんだけど、動くと感動モノ。 やっぱMOP最高だわ～と陶酔しちゃってへろへろになる。 cut-sea:2006/11/23 19:37:13 PST
つまり、短く書けるかどうか、ライブラリにあるかどうかじゃないの。
他の多くの言語じゃ書けねーだろ？ってことを
黒田さんはACLセミナーでもおっしゃたのだけど、
多分そこなんだろうと思う。
ま、私のは所詮マネっこですがね。
でも、そのマネっこを実現させてくれるGaucheとKahuaに感謝するわけですよ。cut-sea:2007/05/10 00:53:28 PDT
;; PARTITIONING SIZE
(define-constant *partitioning-n* 5)
;; for vclass select
(define (get-hash str)
(modulo (fold (lambda (c r)
(+ (char->integer c)
(* 137 r)))
0 str)
*partitioning-n*))
;; CLASS PARTITIONING META CLASS
(define-class <class-partitioning-meta> (<class>)
((%vclasses :accessor vclasses-of :init-keyword :vclasses
:init-form '())
(%virtual? :allocation :virtual :getter virtual?
:slot-ref (lambda (c) (slot-ref c '%parent)))
(%parent :accessor parent-of :init-keyword :parent
:init-value #f)))
;; MAKE - select virtual class by :key value, and make.
(define-method make ((class <class-partitioning-meta>) . initargs)
;; This contition test is supported by knowledge of make method
;; which is specialized for <kahua-persistent-meta>
;; used at reader macro as kahua-object2-read.
(if (and (virtual? class) (memq :%kahua-persistent-base::id initargs))
(next-method) ;; case of kahua-object2-read call this make.
(let ((part-key (get-keyword :key initargs)))
(unless part-key
(error "couldn't find :key value."))
(or (find-kahua-instance class part-key)
(let* ((key (get-hash part-key))
(klass (list-ref (slot-ref class '%vclasses) key)))
(apply next-method klass initargs))))))
;; INITIALIZE - make virtual class.
(define-method initialize ((class <class-partitioning-meta>) initargs)
(next-method)
(unless (virtual? class)
(do ((n (- *partitioning-n* 1) (- n 1)))
((< n 0))
(let* ((name (string->symbol #`"<,(ref class 'name)-,|n|>"))
(klass (make (class-of class)
:name name
:parent class
:supers (list class))))
(push! (vclasses-of class) klass)))))
(define-class <class-partitioning-mixin> ()
()
:metaclass <class-partitioning-meta>)
;; marry with <kahua-persistent-base>
(define-class <partitioning-base> (<class-partitioning-mixin>
<kahua-persistent-base>)
((%key :allocation :persistent :accessor partitioning-key
:init-keyword :key)))
;; FIND-KAHUA-INSTANCE by :key value.
;; This method is defined generics on Kahua persistent system.
(define-method find-kahua-instance ((class <class-partitioning-meta>)
(key <string>) . args)
(if (virtual? class)
(next-method)
(let1 k (get-hash key)
(find-kahua-instance (list-ref (vclasses-of class) k) key))))
;; MAKE-KAHUA-COLLECTION
;; This method is defined generics on Kahua persistent system.
(define-method make-kahua-collection ((class <class-partitioning-meta>) . args)
(if (virtual? class)
(next-method)
(make <kahua-collection>
:instances (fold (lambda (c s)
;; not append because of a case of subclasses opt.
(lset-union eq?
(coerce-to <list>
(apply make-kahua-collection c args)) s))
(coerce-to <list> (next-method))
(vclasses-of class)))))
;; KEY-OF
;; This method is defined generics on Kahua persistent system.
(define-method key-of ((obj <partitioning-base>))
(ref obj '%key))
いろいろとコードには、仕掛けがあって、不要そうにみえるけど、
実はKahuaの現在の実装も影響して必要なもののみ書いてるつもり。
あと大きいのは:afterやら:aroundなどのメソッド結合がGaucheのCLOSにはないのと、
generic functionにメソッドを追加するってところが、
Gaucheのdefine-classマクロ中では
内部定義的なもの(?)で書かれてて、MOPになってないから、オーバーライドできない。
(generic functionに追加するMOPなメソッドがないワケじゃないのです。
あくまでdefine-macroの実装で使われてないということです。)
そのために、実クラスに適用可能なスロットアクセサメソッドを
仮想クラスにも適用可能にするために、継承関係をいじってるところ。
あとは、Kahua persistenceのリーダマクロに依存した細かな分岐が入っている。
クラス再定義機構が問題なく動作してるのもウソじゃないけど、
実はこまかな所で問題がある。
Gaucheのクラス再定義機構によるクラスのアップデートと、
vclassesスロットに格納されている仮想クラスのリストとを同期させるには、
私が自分で書かなくちゃならないハズなのだけど、書いてない。
その意味では完全に正しく動いていると言えない。
Kahua内部の話で言えば、こいつはインデックスキャッシュと呼ばれる機構に
影響があり、実はKahua内部の期待される動作とは若干違う。
表に現れないのと、ワーカーを再起動すれば、それも闇の中に葬られるので、
プレゼンでは黙ってた。(5minに収まらないってのもあるけど)
そもそもそれに気付くにはKahuaの低レイヤーの実装だけでなく、
私のCPC実装の両方を説明しなきゃならないので、
仮にコードを出しても5minで気付く人間はいないだろうということでスットボケ。
;; 普通の永続クラス (define-class <Normal> (<kahua-persistent-base>) ()) (make <Normal>) ;; MAKE-KAHUA-COLLECTION (coerce-to <list> (make-kahua-collection <Normal>)) ;; CPCな永続クラス (define-class <CPC> (<partitioning-base>) ()) ;; インスタンス生成 (make <CPC> :key "cpc-one") (make <CPC> :key "cpc-two") (make <CPC> :key "cpc-three") ;; MAKE-KAHUA-COLLECTION (coerce-to <list> (make-kahua-collection <CPC>)) (map key-of (make-kahua-collection <CPC>)) ;; CPCな永続クラスのサブクラス (define-class <subCPC> (<CPC>) ()) ;; インスタンス生成 (make <subCPC> :key "Sub1") (make <subCPC> :key "Sub2") (make <subCPC> :key "Sub3") ;; MAKE-KAHUA-COLLECTION (coerce-to <list> (make-kahua-collection <subCPC>)) (coerce-to <list> (make-kahua-collection <CPC> :subclasses #t))
;; CLASS PARTITIONING CLASS on Kahua Test
;; DEFINE <part-a> : This class is 'class partitioning class'.
(define-class <part-a> (<partitioning-base>)
((name :allocation :persistent :init-keyword :name
:init-value "" :accessor name-of :index :unique)))
;; MAKE instances of <part-a>
(make <part-a> :key "bizenn@kahua.org"
:name "Tatsuya Bizenn")
(make <part-a> :key "yasuyuki@kahua.org"
:name "Yasuyuki Endo")
(make <part-a> :key "nobsun@kahua.org"
:name "Nobuo Yamashita")
;; FIND-KAHUA-INSTANCE and apply name-of method.
(name-of (find-kahua-instance <part-a>
"bizenn@kahua.org"))
(name-of (find-kahua-instance <part-a>
"yasuyuki@kahua.org"))
(name-of (find-kahua-instance <part-a>
"nobsun@kahua.org"))
;; MAKE-KAHUA-COLLECTION for <part-a>
(coerce-to <list> (make-kahua-collection <part-a>))
(map name-of (make-kahua-collection <part-a>))
;; DEFINE <part-b> : This is subclass of <part-a>.
;; Of cource, this is 'class-partitioning-class' too.
(define-class <part-b> (<part-a>)
((address :allocation :persistent
:init-keyword :address
:init-value ""
:accessor address-of :index :any)))
;; MAKE instances of <part-b>
(make <part-b> :key "shiro@kahua.org"
:name "Shiro Kawai" :address "Hawaii")
(make <part-b> :key "bizenn@kahua.org"
:name "Tatsuya Bizenn" :address "Tokyo")
(make <part-b> :key "cut-sea@kahua.org"
:name "Katsutoshi Itoh" :address "Tokyo")
;; FIND-KAHUA-INSTANCE and apply name-of,address-of method.
(let1 s (find-kahua-instance <part-b> "shiro@kahua.org")
(map (cut <> s) `(,name-of ,address-of)))
(let1 n (find-kahua-instance <part-b> "bizenn@kahua.org")
(map (cut <> n) `(,name-of ,address-of)))
(let1 c (find-kahua-instance <part-b> "cut-sea@kahua.org")
(map (cut <> c) `(,name-of ,address-of)))
;; MAKE-KAHUA-COLLECTION for <part-b>
(coerce-to <list> (make-kahua-collection <part-b>))
(map name-of (make-kahua-collection <part-b>))
(map address-of (make-kahua-collection <part-b>))
;; MAKE-KAHUA-COLLECTION with :subclasses option
(coerce-to <list> (make-kahua-collection
<part-a> :subclasses #t))
(map name-of (make-kahua-collection
<part-a> :subclasses #t))
;; MAKE-KAHUA-COLLECTION with :index option
(map key-of (make-kahua-collection
<part-a>
:index '(name . "Tatsuya Bizenn")))
(coerce-to <list>
(make-kahua-collection
<part-a>
:subclasses #t
:index '(name . "Tatsuya Bizenn")))
(map key-of (make-kahua-collection
<part-a>
:subclasses #t
:index '(name . "Nobuo Yamashita")))
(coerce-to <list>
(make-kahua-collection
<part-b>
:index '(address . "Tokyo")))
(map name-of (make-kahua-collection
<part-b>
:index '(address . "Tokyo")))
;; Test change class.
(define-class <part-human> (<partitioning-base>)
((sex :allocation :persistent :init-keyword :address
:init-value 'male :accessor sex-of)
(age :allocation :persistent :init-keyword :age
:init-value 0 :accessor age-of)))
;; save old class
(define <old-a> <part-a>)
;; New <part-a> class definition
;; Change: <part-human> as super class
;; new slot fname as first name add
;; new slot lname as last name add
(define-class <part-a> (<part-human>)
((fname :allocation :persistent :init-keyword :fname
:init-value "" :accessor fname-of :index :any)
(lname :allocation :persistent :init-keyword :lname
:init-value "" :accessor lname-of :index :any)
(name :allocation :virtual :getter name-of
:slot-ref
(lambda (o)
#`",(ref o 'fname) ,(ref o 'lname)"))))
;; CHANGE-CLASS - auto update new slots
(define-method change-class ((obj <old-a>)
(new-class <class>))
(let* ((old-class (current-class-of obj))
(old-name (slot-ref-using-class old-class obj 'name))
(f&l (string-split old-name #\space))
(part-key (slot-ref-using-class old-class obj '%key)))
(next-method)
(slot-set-using-class! new-class obj 'fname (car f&l))
(slot-set-using-class! new-class obj 'lname (cadr f&l))))
(coerce-to <list> (make-kahua-collection <part-a> :subclasses #t))
;; update protocol running...
(map (cut ref <> 'fname) (make-kahua-collection <part-a> :subclasses #t))
(map lname-of (make-kahua-collection <part-a> :subclasses #t))
(map lname-of (make-kahua-collection <part-a> :index '(fname . "Nobuo")))
(map fname-of (make-kahua-collection <part-a> :index '(lname . "Yamashita")))
(map fname-of (make-kahua-collection <part-b> :index '(lname . "Itoh")))
(map lname-of (make-kahua-collection <part-b> :index '(fname . "Shiro")))
(map fname-of (make-kahua-collection <part-b> :index '(address . "Tokyo")))
Tag: gauche.night