2013/12/06

STkのMOP

Metaobject Protocol(MOP) Advent Calendar 2013参加エントリ (12/7分)

SchemeからTkが使えるという(Tcl/TkのTcl部分をSchemeで置き換えた)、 STkというScheme処理系があった。 Gaucheが大きな影響を受けた処理系のひとつだ。

TinyCLOSベースのオブジェクトシステムを持っていて、 Tkウィジェットが自然にオブジェクトシステムに統合されている。 (このオブジェクトシステムをSTklosと称していた。後に作者のEric Gallesioは STkを完全に書き直してstklosという処理系を作る。)

例えば以下の、フレームを作って配置する簡単なtclスクリプト：

frame .f
button .f.b1 -text "Button1" -command { puts "clicked!" }
pack .f.b1
pack .f

STkだとこんな感じになる:

(require "Tk-classes")
(define f (make <frame>))
(define b (make <button> :parent f :text "Button1"
                         :command (lambda () (display "clicked!\n"))))
(pack b)
(pack f)

この例だと少し冗長になってるけど、実際にコード書くときは 以下のような点でむしろ簡潔になった。

• Tkにもともと備わってるオブジェクトをカスタマイズしたり、複数のウィジェットを まとめて扱いたい時に継承やcompsitingなどで書けて、新たなウィジェットも 組み込みウィジェットと同様のインタフェースで扱える。
• Tkではcanvasに描かれた図形オブジェクトやメニューアイテム等、 通常のオブジェクトと微妙に異なるインタフェースを持つオブジェクトがあるのだけれど、 それらもSTkレベルでは通常のウィジェットと全く同じように扱える。
• ウィジェットの階層がTcl/Tkのように名前に密に結びつけられていないので 再利用しやすい。

で、これをどうやって実装しているんだろうとソースを覗いてみたら、 MOPが使われていたわけだ。

基本的な発想は、Tkのクラスを定義する時に、Tkのプロパティに対応する スロットを :allocation :tk-virtual でマークしておく。

;; from STklos/Tk/Basics.stklos
(define-class <Tk-simple-widget> (<Tk-widget>)
  ((background           :accessor     background   
                         :init-keyword :background   
                         :allocation   :tk-virtual)
   (border-width         :accessor     border-width 
                         :init-keyword :border-width
                         :tk-name      bd     
                         :allocation   :tk-virtual)
   (cursor               :accessor     cursor
                         :init-keyword :cursor  
                         :allocation   :tk-virtual)
   (highlight-background :accessor     highlight-background  
                         :init-keyword :highlight-background
                         :tk-name      highlightback
                         :allocation   :tk-virtual)
   (highlight-color      :accessor     highlight-color  
                         :init-keyword :highlight-color
                         :tk-name      highlightcolor
                         :allocation   :tk-virtual)
   (highlight-thickness  :accessor     highlight-thickness  
                         :init-keyword :highlight-thickness
                         :tk-name      highlightthick
                         :allocation   :tk-virtual)
   (relief               :accessor     relief   
                         :init-keyword :relief       
                         :allocation   :tk-virtual)
   (take-focus           :accessor     take-focus
                         :init-keyword :take-focus
                         :tk-name      takefocus
                         :allocation   :tk-virtual)))

で、メタクラスの compute-get-n-set でスロットオプションをチェックして、 スロットのアクセサを、Tkへの問い合わせ/プロパティ変更コマンドへとマップしている。 (canvas itemやmenu itemなどTkのインタフェースにいくつかバリエーションが あるので、<With-Tk-virtual-slots-metaclass> で大元のcompute-get-n-set をオーバライドして、バリエーションの方は compute-tk-virtual-get-n-set というメソッドで処理している。)

;; from STklos/Tk/Tk-meta.stklos
(define-class <With-Tk-virtual-slots-metaclass> (<class>)
  ())

(define-method compute-get-n-set ((class <With-Tk-virtual-slots-metaclass>) slot)
  (if (memv (slot-definition-allocation slot) '(:tk-virtual :pseudo))
      [let ((tk-name (make-keyword (get-keyword :tk-name (cdr slot) (car slot)))))
        (compute-tk-virtual-get-n-set class tk-name)]
      [next-method]))

(define-class <Tk-metaclass> (<With-Tk-virtual-slots-metaclass>)
  ())

(define-method compute-tk-virtual-get-n-set ((class <Tk-metaclass>) tk-name)
  (list
   (lambda (o)   ((slot-ref o 'Id) 'cget tk-name))
   (lambda (o v) ([slot-ref o 'Id] 'configure tk-name v))))

わかってしまえば素直な実装なのだけれど、このコードを読んだ時は目から鱗だった。

各ウィジェットのプロパティの共通部分はベースクラスにまとめて 多重継承で具体的なウィジェットを定義するなど、他にも参考にしたテクニックは多い。

また、Tk側でウィジェットを破棄すると、対応するSTklosのオブジェクトを <Destroyed-object> にchange classするのもCLOSっぽいテクニックで おもしろい。 (change classの無いOOシステムだと、破棄されたウィジェットは フラグか何かを立てておくことになるけれど、 それだとインスタンスに使われているメモリは 以降使われない無駄メモリとなる。change classするとインスタンスのメモリレイアウト 自体が変更されたクラスのものになる。 <Destroyed-object> はスロットを持たないので、インスタンスが「縮む」ことになる。)

★ ★ ★

ところで上で、「複数のウィジェットをまとめて扱いたい時にcompsiting」と 書いたけれど、複数のオブジェクトをあたかもひとつのオブジェクトであるかのように 見せるのにもMOPが使われている。これについては時間があれば別エントリで書いてみる。

この記事を読んでSTkを試してみ たくなった人へ。STkの最終リリースはSTk-4.0.1で、 検索すれば出てくるだろう。1998年のコードなので今コンパイルすると warningがいっぱい出るが、ビルドはできる。ただし、Linuxでは一ヶ所 configure に 修正が必要だった。多分当時のautoconfのバグで、当時はたまたま通っていたのだろう。

*** Tcl/configure.orig  Sat Jan  3 02:46:25 1998
--- Tcl/configure       Fri Dec  6 01:16:21 2013
***************
*** 3219,3225 ****
        # results, and the version is kept in special file).
      
        if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then
!           system=MP-RAS-`awk '{print $3}' /etc/.relid'`
        fi
        if test "`uname -s`" = "AIX" ; then
            system=AIX-`uname -v`.`uname -r`
--- 3219,3225 ----
        # results, and the version is kept in special file).
      
        if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then
!           system=MP-RAS-`awk '{print $3}' /etc/.relid`
        fi
        if test "`uname -s`" = "AIX" ; then
            system=AIX-`uname -v`.`uname -r`

Tags: Programming, Gauche, CLOS, STk