#:g1: MCS(Meta Class System)を動かしてみた

Posted 2013-01-13 15:04:00 GMT

MCS(Meta Class System)とは

 MCSとは、CLOSやヨーロッパ方面で活発に開発されていたEULISPのオブジェクトシステムである、TELOSの流れを汲んだCLのオブジェクトシステムです。1990年代前半にヨーロッパを中心に開発されていたもので、MOPがサポートされているのが特長の様子。

 以前にSBCLで動かそうと試した時には、どうも上手く行かなかった憶えがあるのですが、久々に試してみたら、普通に動いたので、ASDF化してgithubに上げてみました。

 ドキュメントは上記のcmuのレポジトリにあるのですが、大体のところは、CLOS MOPのサブセットになっているようです。defclass等に加えてdefmixinやdefabstract等のユーティリティマクロが追加されていて、プログラミングスタイルを整理しようという試みが感じられます。

 ということで、岩波書店刊の『オブジェクト指向コンピューティング』に載っている例を参考に適当に例を書いてみます。

 MOPでカスタマイズしてスロットの初期化引数に必須であることを指定しようというものですが、MCSだとmake-instanceが総称関数でないので、元の例だと、インスタンスを作成→スロットの未束縛をチェック、というところを、引数の形式をallocate-instanceの際にチェックする、という風に変更してあります。とりあえずインスタンスを作成してから形式をチェックというのも好みが分かれそうなので、これはこれで良いのかもしれません。

(defpackage :mcs-foo
  (:use :mcs))

(in-package :mcs-foo)

(defclass required-slot-class (standard-class) ((required-slots :reader direct-required-slots :initarg required-slots :initform '()) (class-required-slots :accessor class-required-slots)))

(defmethod direct-required-slots ((class class)) (declare (ignore class)) '() )

(defmethod finalize-inheritance :after ((class required-slot-class) direct-superclasses args) (declare (ignore direct-superclasses args)) (setf (class-required-slots class) (remove-duplicates (loop :for c :in (class-precedence-list class) :append (direct-required-slots c)) :test #'equal :from-end T)))

(defmethod required-slot-initarg-missing-using-class ((class required-slot-class) object slot-name) (declare (ignore object)) (error "Required Slot ~A in ~A: No initarg" slot-name class))

(defmethod check-required-slots-using-class ((class required-slot-class) initargs) (dolist (rs (class-required-slots class)) (unless (etypecase rs (symbol (getf initargs rs)) ((cons (eql :or) *) (member-if (lambda (s) (getf initargs s)) (cdr rs)))) (required-slot-initarg-missing-using-class class initargs rs))))

(defmethod allocate-instance ((class required-slot-class) initargs) (check-required-slots-using-class class initargs) (call-next-method))

実行してみる

(defclass zzz () 
  ((a :initarg a)
   (b :initarg b)
   (c :initarg c))
  (required-slots (a b c))
  (:metaclass required-slot-class))

(make-instance 'zzz 'a 1 'b 2 'c 3) ;=> #<Zzz>

(make-instance 'zzz 'a 1 'b 2 'd 3) ;!!! Required Slot C in #<Required-Slot-Class ZZZ>: No initarg

まとめ

 MCSはCLOSと大体同じなのですが、主にスタイル上の制限による制約があるようで、CLOSそのままのコードは結構引っ掛かります。飽く迄、別の物と考えれば良いのですが、かなり似ているので混乱してしまう、というところでしょうか。

comments powered by Disqus