Posted 2019-11-16 21:47:29 GMT
うまいタイトルが考えつかなかったので、「ECLOSのメタクラス継承」というタイトルになりましたが、ECLOSが提供するdefclass
の:metaclass
オプション省略時のメタクラスの自動算出についてです。
なお、ECLOSについては、
に詳しいので参照してください。
Common Lispでは、カスタマイズしたメタクラスをdefclass
で利用する際には明示的に:metaclass
を指定しないといけないのですが、結構めんどうです。
上記文献によれば、ECLOSは、
defclass
に:metaclass
があればそれを使う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