#:g1: ECLOSのメタクラス継承

Posted 2019-11-16 21:47:29 GMT

うまいタイトルが考えつかなかったので、「ECLOSのメタクラス継承」というタイトルになりましたが、ECLOSが提供するdefclassの:metaclassオプション省略時のメタクラスの自動算出についてです。

なお、ECLOSについては、

に詳しいので参照してください。

ECLOSのメタクラスの自動算出アルゴリズム

Common Lispでは、カスタマイズしたメタクラスをdefclassで利用する際には明示的に:metaclassを指定しないといけないのですが、結構めんどうです。
上記文献によれば、ECLOSは、

  1. defclassに:metaclassがあればそれを使う
  2. 指定がなければ、

    • ダイレクトスーパークラスの集合をSとする。
    • それらのメタクラスの集合をM(S)とする。
    • Sの要素のサブクラス関係の推移閉包の集合をM*(S)とする。
    • M*(S)の要素の共通部分をTとする。
    • Tがサブクラス関係の木を成していれば、その根を、さもなくば、standard-classをメタクラスとする

というアルゴリズムでこの問題を解決します。

いまいち解釈に自信がありませんが、とりあえずそのままコードにしてみました。
推移閉包を求めるコードは、Tiny CLOSのものが手頃だったので、これを利用しています。

(defpackage "31f04d2f-2dc5-523c-a129-1478406e4677" 
  (:use :c2cl))

(in-package "31f04d2f-2dc5-523c-a129-1478406e4677")

(defun build-transitive-closure (get-follow-ons)
  (lambda (x)
    (labels ((track (result pending)
               (if (endp pending)
                   result
                   (let ((next (car pending)))
                     (if (member next result)
                         (track result (cdr pending))
                         (track (cons next result)
                                (append (funcall get-follow-ons next)
                                        (cdr pending))))))))
      (track '() (list x)))))
  
(defun compute-metaclass (dsupers &key (default-metaclass-name nil))
  (block nil
    ;;Let C be a class, if
    ;;a) the definition of C includes a (:metaclass M) option then M is the metaclass of C.
    (when default-metaclass-name
      (return (find-class default-metaclass-name)))
    (when (endp dsupers)
      (return (find-class 'standard-class)))
    ;;b) let S be the set of direct superclasses of C 
    (let* ((| S | dsupers)
           (| M(S) | (mapcar #'class-of | S |))
           ;;and let M*(S) be the set of transitive closures of the subclass relation applied to the elements of M(S)
           (| M*(S) | (mapcar (build-transitive-closure #'class-direct-subclasses) | M(S) |))
           ;;and let T be the intersection of the sets composing M*(S)
           (| T | (reduce #'intersection | M*(S) |)))
      ;;then if T forms a tree according to the subclass relation 
      (if (and (not (null | T |))
               (every #'subtypep | T | (cdr | T |)))
          ;;then the root of T is the metaclass of C
          (car (reverse | T |))
          ;;otherwise STANDARD-CLASS is the metaclass of C.
          (find-class 'standard-class)))))

(defpackage eclos 
  (:use)
  (:export defclass))

(defun ensure-class-soft (name)
  (or (find-class name nil)
      (make-instance 'standard-class :name name)))

#+lispworks
(defmacro eclos:defclass (name superclasses slots &rest class-options)
  (let* ((metaclass-name (cadr (find :metaclass class-options :key #'car)))
         (metaclass (compute-metaclass (mapcar #'ensure-class-soft superclasses)
                                       :default-metaclass-name  metaclass-name))
         (metaclass (case (class-name metaclass)
                      (forward-referenced-class (find-class 'standard-class))
                      (otherwise metaclass))))
    (clos::expand-defclass (class-prototype metaclass)
                           (class-name metaclass)
                           name
                           superclasses
                           slots
                           class-options)))

動作確認

さて、定義できたので動作を確認していきます。

(defclass a-class (standard-class) ())
(defclass b-class (standard-class) ())
(defclass c-class (a-class b-class) ())
(defmethod validate-superclass ((c a-class) (s standard-class)) T)
(defmethod validate-superclass ((c b-class) (s standard-class)) T)
(defconstant <a>
  (defclass a ()
    ()
    (:metaclass a-class)))
(defconstant <b>
  (defclass b ()
    ()
    (:metaclass b-class)))

a-class、b-class、c-classとメタクラスを定義し、a-classをメタクラスとしたa、b-classをメタクラスとしたbを作成します。

ここで、

(defclass c (a b)
  ())

とした場合に、cのメタクラスが適切に求まれば良いのですが、上記で定義したcompute-metaclassで確認してみます。

(compute-metaclass (list <a> <b>))
→ #<lisp:standard-class c-class 4160314BC3> 
;; c-classを削除
(progn
  (reinitialize-instance (find-class 'c-class) :direct-superclasses nil)
  (setf (find-class 'c-class) nil))
;; メタクラスが求まらなかったので、デフォルト値のstandard-classを返す
(compute-metaclass (list <a> <b>))
→ #<lisp:standard-class standard-class 41A0997013> 
;; メタクラス再作成
(defclass c-class (b-class a-class) ())
→ #<lisp:standard-class c-class 40202BE5AB> 
(compute-metaclass (list <a> <b>))
→ #<lisp:standard-class c-class 40202BE5AB>

とりあえず大丈夫そうなので、eclos:defclassを使ってcを定義してみます。

(eclos:defclass c (a b)
  ())
→ #<c-class c 402072C593>

まとめ

以上の動作をみて分かるように、メタクラスを多重継承する場合は、予め多重継承したメタクラスを用意しておく必要がありますが、用意さえしておけば勝手に見付けてくれるのが便利といえば便利かもしれません。
メタクラス継承の自動算出は、STklos、Guile、Gauche等のSTklos系OOPSでも行なわれています。
ECLOSとは異なったアルゴリズムが使われているので、次回はそちらを眺めたりCommon Lispで実装してみます。

■

HTML generated by 3bmd in LispWorks 7.0.0

comments powered by Disqus