The Art of the Metaobject Protocol を讀む

The Art of the Metaobject Protocol を讀む

はじめに

The Art of MetaObject Protocolといふ本があります。略してAMOPなどと呼ばれることもありますが、西暦1991年に出版されてから、かれこれ30年近く經て、今尚、コンピュータ科學分野上、樣樣な示唆に富んだ良書だとされてゐます。

本書のIntroductionには讀者對象として、 Programming Language Designers, Programmers and software engineers, People working with object-oriented languages, People interested in reflection, The CLOS Community 等が擧げられてをりますが、これを見ても、II部を除けば1140頁にも滿たないこの書が、如何に中身の濃いものであるかは容易に想像できます。

それだけに、なかなか取っ付き難い本でもあって、無目的に讀み始めると、大抵は Chapter 1 の、それも最初の方で返り討ちにされたまま、ツンドクといったことになりかねません。しかし、逆に云ふと、 Chapter 1 それも、 1.3 Representing Class あたりまで讀み進めることができれば、後は、さう苦勞なく讀了まで持っていけるものです。

といふわけで、本稿では、以下、The Art of MetaObject Protocolの第一章 1.3 迄を解説しながら讀んで行かうと思ひます。

1 CLOSの實裝

Metaobject Protocol を理解するためには、先づ、プログラムを書くために使はれてゐるプログラム (この場合CLOSそのもの) が、その舞臺裏にどのやうな構成要素を持ってゐるかを知る必要があります。 CLOSの裏舞臺をなす其其の構成要素が現はになれば、これら構成要素間の取り決めごとが即ち Metaobject Protocol と呼ばれるものとなります。 本章では、CLOS舞臺裏理解の手段として「CLOSでCLOSを實裝」します。 ただし、基本的なアイデアに集中するため、次節に述べるやうに實裝仕樣を簡略化し、Bootstrap問題などは當面無視します。 從って、これから記述するコードを Common Lisp の處理系に喰はせても、そのままでは走りません。 動くコードに興味のある方は、本書の Appendix D に記載されたClosetteを參照してください。

1.1 實裝しようとするサブセットの定義

本章で「實裝」するCLOSはフルスペックのものでなく、そのサブセットとします。即ち、

  • No class redefinition. サブセットに於いては、クラスを動的に再定義することはできません。
  • No method redefinition. メソッドの動的再定義も、サポートされません。
  • No forward-referenced superclasses. Superclassとして現れる祖クラスは、必ず前もって定義されてゐることを必要條件とします。
  • Explicit generic function definitions. 總稱函數定義は省略不可とします。
  • Standard method combination only. メソッド結合は、Standard Method Combination のみを扱ひます。
  • No eql specializers. Eql specializers はサポートしません。
  • No slots with :class allocation. スロットはインスタンス毎に確保されるものとし、クラス間共有スロットはサポートしません。
  • Types and classes notfully integrated. Common Lisp の structure 型をCLOSのクラスとして扱ふことはできません。
  • Minimul syntactic sugar. with-slots, with-accessors などのマクロ定義は省きます。

1.2 裏舞臺の基礎構造

基本的に、CLOSプログラムは、 defclass と defgeneric と defmethod 、それに Common Lisp のformを織り交ぜたものから成ります。これを實行すれば (對象プログラムの) クラスと總稱函數とメソッドが定義されます。

一方、その裏側では、クラス、總稱函數、メソッドといったものが、それ自體の内部表現を形作って記憶されます。處理系は、クラスの内部表現に記憶された情報を使って、クラスのインスタンスを生成したり、スロットへのアクセス手段を與へてくれますし、總稱函數やメソッドの内部表現に記憶された情報を使って、適切なコードを實行することができるわけです。

今、具體的な例として、次を考へます。

(defclass rectangle ()
     ((height :initform 0.0 :initarg :height)
      (width  :initform 0.0 :initarg :width)))

(defclass color-mixin ()
     ((cyan    :initform 0 :initarg :cyan)
      (magenta :initform 0 :initarg :magenta)
      (yellow  :initform 0 :initarg :yellow)))

(defclass color-rectangle (color-mixin rectangle)
     ((clearp :initform (y-or-n-p "But is it transparent?")
              :initarg :clearp :accessor clearp)))

(defgeneric paint (x))

(defmethod paint ((x rectangle))                ;Method #1
  (vertical-stroke (slot-value x 'height)
                   (slot-value x 'width)))

(defmethod paint :before ((x color-mixin))      ;Method #2
  (set-brush-color (slot-value x 'cyan)
                   (slot-value x 'magenta)
                   (slot-value x 'yellow)))

(defmethod paint ((x color-rectangle))          ;Method #3
  (unless (clearp x) (call-next-method)))

(setq door
      (make-instance 'color-rectangle
        :width 38 :height 84 :cyan 60 :yellow 55 :clearp nil))

上プログラムが實際にどういった内部表現を形成するのか眺めてみるために、これから實裝する道具を幾つか先取りして使った例を以下に示します。2

CL-USER(1): #+allegro (in-case-mode :common)
CL-USER(2): (compile-file "closette.lisp")
;;; Compiling file closette.lisp
......
T
CL-USER(3): (load "closette")
; Fast loading C:\Users\KURODA Hisao\project\essay\closette.fasl
Beginning to bootstrap Closette...Class hierarchy created.;
......
Closette is a Knights of the Lambda Calculus production.
T
CL-USER(4): (in-package closette)
#<The CLOSETTE package>
CLOSETTE(5): .......  ; ここに上記プログラムを入力する
CLOSETTE(50): (describe-object door t)    ; オブジェクトdoorの中身を見る
A Closette object
Printed representation: #<Color-Rectangle>
Class: #<Standard-Class COLOR-RECTANGLE>
Structure 
    CLEARP <- NIL
    CYAN <- 60
    MAGENTA <- 0
    YELLOW <- 55
    HEIGHT <- 84
    WIDTH <- 38
CLOSETTE(51): (describe-object (find-class 'rectangle) t)
                                    ; クラスrectangleの中身を見る
A Closette object
Printed representation: #<Standard-Class RECTANGLE>
Class: #<Standard-Class STANDARD-CLASS>
Structure 
    NAME <- RECTANGLE
    DIRECT-SUPERCLASSES <- (#<Standard-Class STANDARD-OBJECT>)
    DIRECT-SLOTS <- ((:NAME HEIGHT ....) (:NAME WIDTH ....))
    CLASS-PRECEDENCE-LIST <- (#<Standard-Class RECTANGLE>
                              #<Standard-Class STANDARD-OBJECT>
                              #<Standard-Class T>)
    EFFECTIVE-SLOTS <- ((:NAME HEIGHT ....) (:NAME WIDTH ....))
    DIRECT-SUBCLASSES <- (#<Standard-Class COLOR-RECTANGLE>)
    DIRECT-METHODS <- (#<Standard-Method PAINT (RECTANGLE)>)
CLOSETTE(52): (describe-object (find-generic-function 'paint) t)
                                    ; 總稱函數paintの中身を見る
A Closette object
Printed representation: #<Standard-Generic-Function PAINT>
Class: #<Standard-Class STANDARD-GENERIC-FUNCTION>
Structure 
    NAME <- PAINT
    LAMBDA-LIST <- (X)
    METHODS <- (#<Standard-Method PAINT (COLOR-RECTANGLE)>
                #<Standard-Method PAINT :BEFORE (COLOR-MIXIN)>
                #<Standard-Method PAINT (RECTANGLE)>)
    METHOD-CLASS <- #<Standard-Class STANDARD-METHOD>
    DISCRIMINATING-FUNCTION <- #<Closure (:INTERNAL
                                          STD-COMPUTE-DISCRIMINATING-FUNCTION
                                          0)>
    CLASSES-TO-EMF-TABLE <- #<EQUAL hash-table with 0 entries>
CLOSETTE(53): (find-method (find-generic-function 'paint)
                           ()
                           `(,(find-class 'rectangle)))
                               ; 總稱函數paintが持つメソッドの一つを取り出して、
#<Standard-Method PAINT (RECTANGLE)>
CLOSETTE(54): (describe-object * t) ; その中身を見る
A Closette object
Printed representation: #<Standard-Method PAINT (RECTANGLE)>
Class: #<Standard-Class STANDARD-METHOD>
Structure 
    LAMBDA-LIST <- (X)
    QUALIFIERS <- NIL
    SPECIALIZERS <- (#<Standard-Class RECTANGLE>)
    BODY <- (BLOCK PAINT
              (VERTICAL-STROKE (SLOT-VALUE X 'HEIGHT)
               (SLOT-VALUE X 'WIDTH)))
    ENVIRONMENT <- NIL
    GENERIC-FUNCTION <- #<Standard-Generic-Function PAINT>
    FUNCTION <- #<Function (:ANONYMOUS-LAMBDA 69)>

color-rectangleのインスタンスdoorは、先に擧げたプログラムを實行することにより得られるオブジェクトですが、その際、doorと同じやうに、クラス、總稱函數、メソッドといったものもまたオブジェクトとしての構造を持ってゐることがわかります。このやうに自身を内省するオブジェクトが metaobject と呼ばれるものです。

これら内省オブジェクト (metaobject) がどのやうに構成されてゐるのかを、以下、CLOSの實裝コードを眺めながら捉へて行かうと思ひます。

より具體的には、defclass, defgeneric, defmethod の三つのマクロを定義していくわけですが、その前に、CLOSの實裝には三つの層があることを確認しておきます。

  • マクロ展開層: defclassなど、ユーザが直接利用し syntactic sugar の役割をはたす層。
  • 膠層: find-classなど、名前とmetaobjectを結び付ける層。
  • 最下層: metaobjectの振舞が實裝されてゐる層。

さて、いよいよ、以下の順番でCLOSを實裝して行きます。

  • クラスの構造を定義する
  • オブジェクトの印字方法
  • インスタンスの構造と、その初期化及びアクセス方法を定義する
  • 總稱函數の構造を定義する
  • メソッドの構造を定義する
  • 總稱函數が呼ばれると何が起こるのか

1.3 クラスの構造を定義する

本節では、defclassを定義實裝しながら、CLOSのクラスがどのやうな構造を持ってゐるかを把握します。

ユーザがdefclassを使ってクラスを定義したときに、クラスそれ自體の構造が裏舞臺で形成されるわけですが、これが class metaobject と呼ばれるものです。例として、先のプログラムでのcolor-rectangleクラスの構造を見てみます。

CLOSETTE(58): (describe-object (find-class 'color-rectangle) t)
A Closette object
Printed representation: #<Standard-Class COLOR-RECTANGLE>
Class: #<Standard-Class STANDARD-CLASS>
Structure 
    NAME <- COLOR-RECTANGLE
    DIRECT-SUPERCLASSES <- (#<Standard-Class COLOR-MIXIN>
                            #<Standard-Class RECTANGLE>)
    DIRECT-SLOTS <- ((:NAME CLEARP ....))
    CLASS-PRECEDENCE-LIST <- (#<Standard-Class COLOR-RECTANGLE>
                              #<Standard-Class COLOR-MIXIN>
                              #<Standard-Class RECTANGLE>
                              #<Standard-Class STANDARD-OBJECT>
                              #<Standard-Class T>)
    EFFECTIVE-SLOTS <- ((:NAME CLEARP ....)
                        (:NAME CYAN ....)
                        (:NAME MAGENTA ....)
                        (:NAME YELLOW ....)
                        (:NAME HEIGHT ....)
                        (:NAME WIDTH ....))
    DIRECT-SUBCLASSES <- NIL
    DIRECT-METHODS <- (#<Standard-Method PAINT (COLOR-RECTANGLE)>
                       #<Standard-Method (SETF CLEARP) (T COLOR-RECTANGLE)>
                       #<Standard-Method CLEARP (COLOR-RECTANGLE)>)

上を一般化すると、 class metaobject には次の要素があることがわかります。

  • NAME: 名前
  • DIRECT-SUPERCLASSES: 親クラス
  • DIRECT-SLOTS: そのクラスが直接持つスロット
  • CLASS-PRECEDENCE-LIST: クラス優先順位
  • EFFECTIVE-SLOTS: 祖クラスから繼承したものも含めそのクラスが實際に持つスロット
  • DIRECT-SUBCLASSES: 子クラス
  • DIRECT-METHODS: そのクラスに特化したメソッド

我々が最初にするべき仕事は、この class metaobject の型、即ち metaclass を定義してやることです。これが standard-class と呼ばれるもので、標準的なクラスは皆、standard-class のインスタンスといふことになります。

(defclass standard-class () 
    ((name :initarg :name :accessor class-name)
     (direct-superclasses :initarg :direct-superclasses
                          :accessor class-direct-superclasses)
     (direct-slots :accessor class-direct-slots)
     (class-precedence-list :accessor class-precedence-list)
     (effective-slots :accessor class-slots)
     (direct-subclasses :initform () :accessor class-direct-subclasses)
     (direct-methods :initform () :accessor class-direct-methods)))

1.3.1 defclassマクロ定義

次にやるべきは defclass の定義です。 マクロ展開層のdefclassは、膠層のensure-classに仕事を引き渡します。その際、canonicalize-… 處理によりパラメータの正規化が行なはれます。

(defmacro defclass (name direct-superclasses direct-slots &rest options)
  `(ensure-class ',name
     :direct-superclasses
       ,(canonicalize-direct-superclasses direct-superclasses)
     :direct-slots
       ,(canonicalize-direct-slots direct-slots)
     ,@(canonicalize-defclass-options options)))

1.3.2 親クラスの正規化

canonicalize-direct-superclassesは、defclassフォームに於いて指示された親クラスの名前を實際のクラスオブジェクトに置換へます。例として以下のマクロ展開を見ます。

CLOSETTE(71): (macroexpand '(defclass color-rectangle (color-mixin rectangle) ...))
(ENSURE-CLASS 'COLOR-RECTANGLE
  :DIRECT-SUPERCLASSES (LIST (FIND-CLASS 'COLOR-MIXIN) (FIND-CLASS 'RECTANGLE))
  :DIRECT-SLOTS (....))
T

この例では、color-mixin と rectangle について其其、 (膠層の) find-class を使って class metaobject を取り出した後、 :direct-superclasses の値として引き渡してゐることがわかります。

1.3.3 スロットの正規化

canonicalize-direct-slotsの仕事はもう少し複雜です。

以下で例を見ます。

CLOSETTE(71): (macroexpand '(defclass color-rectangle (...)
                             ((clearp :initform (y-or-n-p "But is it transparent?")
                                      :initarg :clearp :accessor clearp))))
(ENSURE-CLASS 'COLOR-RECTANGLE
  :DIRECT-SUPERCLASSES (LIST ...)
  :DIRECT-SLOTS (LIST
                  (LIST :NAME 'CLEARP
                        :INITFORM '(Y-OR-N-P "But is it transparent?")
                        :INITFUNCTION #'(LAMBDA ()
                                          (Y-OR-N-P "But is it transparent?"))
                        :INITARGS '(:CLEARP)
                        :READERS '(CLEARP)
                        :WRITERS '((SETF CLEARP)))))
T

:direct-slots に指示された property list は、後で make-direct-slot-definition に渡されて、 direct slot definition metaobject を形成します。 詳細については、ここでは省きますが、direct slot definition metaobject に關して、以下のaccessor函數が與へられることを確認しておきます。

  • slot-definition-name
  • slot-definition-initargs
  • slot-definition-initform
  • slot-definition-initfunction
  • slot-definition-readers
  • slot-definition-writers

1.3.4 Class Options

defclassフォームに於いては class options を指定することが可能で、それらは canonicalize-defclass-options で處理された上で ensure-class に引き渡されます。class options についてここでは省略します。

1.3.5 ensure-class

膠層の函數ensure-classは、名前とキーワードを引數にとって、それを make-instance に渡し、standard-class のインスタンス (即ち class metaobject) を生成します。

(defun ensure-class (name &rest all-keys)
  (if (find-class name nil)
      (error "Can't redefine the class named ~S." name)
      (let ((class (apply #'make-instance
                          'standard-class :name name all-keys)))
        (setf (find-class name) class)
        class)))

上で使はれてゐるもう一つの膠層函數 find-class を以下に定義しておきます。

(let ((class-table (make-hash-table :test #'eq)))

  (defun find-class (symbol &optional (errorp t))
    (let ((class (gethash symbol class-table nil)))
      (if (and (null class) errorp)
          (error "No class named ~S." symbol)
          class)))

  (defun (setf find-class) (new-value symbol)
    (setf (gethash symbol class-table) new-value))
 ) ;end let class-table

1.3.6 Class Metaobjects の初期化

make-instanceは最下層に位置し、class metaobjects に限らず、一般にインスタンスの生成初期化目的で使はれる函數です。class metaobjects の初期化時には、一般の初期化に加へ、以下が必要となります。

上は、CLOSの作法に倣ひ、 standard-class に特化したメソッドを initialize-instance に追加することで實現します。

(defmethod initialize-instance :after
           ((class standard-class) &key direct-superclasses direct-slots)
  (let ((supers
          (or direct-superclasses
              (list (find-class 'standard-object)))))
    (setf (class-direct-superclasses class) supers)
    (dolist (superclass supers)
      (push class (class-direct-subclasses superclass))))
  (let ((slots 
          (mapcar #'(lambda (slot-properties)
                      (apply #'make-direct-slot-definition
                             slot-properties))
                    direct-slots)))
    (setf (class-direct-slots class) slots)
    (dolist (direct-slot slots)
      (dolist (reader (slot-definition-readers direct-slot))
        (add-reader-method
          class reader (slot-definition-name direct-slot)))
      (dolist (writer (slot-definition-writers direct-slot))
        (add-writer-method
          class writer (slot-definition-name direct-slot)))))
    (finalize-inheritance class))

1.3.7 繼承

ここまで、 defclass に始まり ensure-class から make-instance そして initialize-instance と、 class metaobject が生成される過程をほぼ見てきました。 殘りは繼承に關する仕事となります。

  • クラス優先順位 (class precedence list) を計算し保持する。
  • クラス直屬のスロットの他に、祖クラスから繼承するスロットを求め保持する。

これを實現するのが finalize-inheritance です。

(defun finalize-inheritance (class)
  (setf (class-precedence-list class)
        (compute-class-precedence-list class))
  (setf (class-slots class)
        (compute-slots class))
  (values))

class precedence list とは、祖クラスを全てかき集め、それに自身を加へ、それらを most specific なものから least specific なものへ順序づけて竝べたリストのことを云ひます。

先の例で color-rectangle の class precedence list は以下のやうになります。

.....
CLASS-PRECEDENCE-LIST <- (#<Standard-Class COLOR-RECTANGLE>
                          #<Standard-Class COLOR-MIXIN>
                          #<Standard-Class RECTANGLE>
                          #<Standard-Class STANDARD-OBJECT>
                          #<Standard-Class T>)
.....

class precedence list の計算アルゴリズムは、CLOSの仕樣で定められてをり、自身を含めた祖クラス集合を topological sorting することで得られます。

(defun compute-class-precedence-list (class)
  (let ((classes-to-order (collect-superclasses* class)))
    (topological-sort classes-to-order
                      (remove-duplicates
                        (mapappend #'local-precedence-ordering
                                   classes-to-order))
                      #'std-tie-breaker-rule)))

collect-superclasses* は親クラスを再歸的に遡りつつ、自身を含めた全ての祖クラスを囘收してくる函數です。3

(defun collect-superclasses* (class)
  (remove-duplicates
    (cons class
          (mapappend #'collect-superclasses*
                     (class-direct-superclasses class)))))

topological-sortの詳細は省きますが引數として次の三つを取ります。 1) これから竝べ換へようとするクラスリスト、 2) 必ず確保すべき優先順に竝べたクラスペアのリスト (local-precedence-ordergingの結果) 、 3) 同順とされた同士からどれを選ぶかのルール (std-tie-breaker-rule)。

一旦クラス優先順位が求まれば、直屬のスロットをクラス優先順に竝べ、同じ名前を持つスロットを後ろから除いてやれば、クラスに有效なスロットが繼承できたことになります。これを compute-slot で行なひます。この際、其其の direct slot definition metaobject は effective slot definition metaobject に變換されます。

(defun compute-slots (class)
  (mapcar #'(lambda (name)
              (make-effective-slot-definition
                :name (slot-definition-name slot)
                :initform (slot-definition-initform slot)
                :initfunction (slot-definition-initfunction slot)
                :initargs (slot-definition-initargs slot)))
          (remove-duplicates
            (mapappend #'class-direct-slots
                       (class-precedence-list class))
            :key #'slot-definition-name
            :from-end t)))

make-effective-slot-definition は、 effective slot definition metaobject を生成するための函數です。 slot-definition-readers と slot-definition-writers を例外として、 direct slot definition metaobject へのaccesor函數は、全て、 effective slot definition metaobject に對しても有效となります。

ここまでで、class metaobject の構造の全貌を明かにし、 defclass マクロがどのやうに實裝されてゐるかを確認したことになります。

以下略。

Footnotes:

1

本書のII部は、metaobject protocol 仕樣の詳細、演習問題の解答、CLOSと他のOOPとの比較、Bootstrap問題などが取り上げられた後、實裝のソースコード記述に費されてをり、基本的なアイデアは全てI部で述べられてゐると思って差し支へありません。

2

Allegro CL と SBCL で compile&load できるやうにパッチをあてたclosette.lispを用意しておきました

3

mapappend函數を示します。

(defun mapappend (fun seq)
  (apply #'append (mapcar fun seq)))

Author: KURODA Hisao

Created: 2018-02-18 Sun 10:48

Emacs 25.1.1 (Org mode 8.2.10)

Validate

Comments

Popular posts from this blog

Common Lisp コーディングスタイルについて

Hyperspec を讀む