LISPUSER

Lisp に興味のある方ならば，MOP : Meta Object Protocol を聞いた事がある と思います．最近は CLISP でも実装されており，ほぼ全ての Common Lisp 処 理系で利用可能になっています．一ユーザーとしてどのようなメリットがある かを考えてみます．

cs-user> (defclss node () ((title :initarg :title) (data :initarg :data)))
; Evaluation aborted
cs-user> (defclass node () ((title :initarg :title) (data :initarg :data)))
#<standard-class node>
cs-user> (defvar a)
a
cs-user> (defvar b)
b
cs-user> (setq b (make-instance 'node :title "Data 1 - COPY" :data '(1 2 3)))
#<node #x20EA5A56>
cs-user> a
#<node #x20E9053E>
cs-user> b
#<node #x20EA5A56>
cs-user> 

さて，A の中身を表示したいと思いませんか？あるいは，データのコピーを簡 単に作りたいという要望もあるでしょう．真っ先に考えつくのは以下のような ものです．

(defmethod show ((obj node))
  (with-slots (title data)
     node
     (format t "TITLE: ~A~&DATA: ~A~&" title data)))  

(defmethod shallow-copy ((obj node))
  (make-instance 'node
                 :title (if (slot-boundp obj 'title) (slot-value obj 'title) nil)
                 :data  (if (slot-boundp obj 'data) (slot-value obj 'data) nil)))

しかし，これは node クラスの定義が変更されるたびにメンテナンスが必要に なります．スロットが追加されたら？名前がわったら？そう，メソッドも変更 が必要になるのです．この問題を Meta Object Protocol を使って解決してみ たいと思います．

まず，メソッドの機能を自然言語で記述してみます．

1. show - node クラスのオブジェクトのスロット title, スロット data の値を表示する
2. shallow-copy - node クラスのオブジェクトのスロット title, スロット data の値を再利用してオブジェクトを作成する

となりますが，ここで問題となるのはスロット名や数が変更になる可能性があ るという事です．たとでば title スロットの名前が label にかわったとした らどうでしょうか？上記の記述には変更が必要になります．

変更の必要がないように一段抽象化してみます．

1. show - node クラスのオブジェクトで定義されているスロットの名前と値を表示する
2. shallow-copy - node クラスのオブジェクトで定義されているスロットの値を再利用してオブジェクトを作成する

このような定義に修正すると，（効率を気にしないかぎり）オブジェクトの定 義が変更されてもメソッドに手を入れる必要がありません．

ここで，登場するのが Meta Object Protocol です．

class-of オブジェクトのクラスを取得する

class-name クラス名を取得する

class-slots クラスで定義されているスロット定義を取得する (MOP)

slot-definition-name スロットの定義名を取得する (MOP)

これらの MOP の機能を使えば，show や shallow-copy メソッドは以下のように定義できます．

(defpackage :example (:use :cl #+clisp :mop #+sbcl :sb-mop))
(in-package :example)

(defmethod show ((obj standard-object))
  (let* ((class (class-of obj))
        (slots (class-slots class)))
    ;; class property
    (format t "====================================~&")
    (format t "CLASS: ~A~&" (class-name class))
    (format t "PARENTS: ~A~&" (class-direct-superclasses class))
    ;; slots
    (format t "------------------------------------~&")
    (dolist (def slots)
      (let ((name (slot-definition-name def)))
       (format t "~A: ~S~&"
               name
               (if (slot-boundp obj name) (slot-value obj name) "#<UNBOUND>"))))))

(defmethod clone ((obj standard-object) &rest rest)
  (let* ((class (class-of obj))
        (slots (class-slots class))
        (pairs nil))
    (dolist (def slots)
      (let ((slotname (slot-definition-name def))
           (initargs (slot-definition-initargs def)))
       (when (car initargs)
         (cond ((getf rest (car initargs))
                (push (getf rest (car initargs)) pairs)
                (push (car initargs) pairs))
               ((slot-boundp obj slotname)
                (push (slot-value obj slotname) pairs)
                (push (car initargs) pairs))))))
    (apply #'make-instance `(,(class-name class) ,@pairs))))