#:g1: allocate-instanceでメソッド実装の強制

Posted 2020-12-14 15:00:00 GMT

allocate-instance Advent Calendar 2020 15日目の記事です。

Java等では、インスタンス化不可な抽象クラスを定義したり、抽象クラスでメソッドの実装を強制したりできますが、Common Lispだとmixinクラスのインスタンス化はマナーとしてしない程度です。さらに、メソッドの実装を強制については、そもそも総称関数なのでクラスが統治の単位でもありません。

また、オブジェクト指向システムがとても動的なので、チェックがコンパイル時ではなく、実行時によってしまうというのもいま一つなところです。

とはいえ、MOPのインスタンス生成プロトコルにフックを掛けてインスタンス化を抑止することは可能で、そのフックのポイントがallocate-instanceからclass-prototypeあたりになります。

`allocate-instance`でメソッド実装の強制

まあ、allocate-instanceにメソッド実装の強制という責務はないのですが、インスタンスが生成されるポイントなのでフックを掛けるのがこのあたりになってしまいます。

とりあえず:abstract-methodsオプションにメソッドを指定してクラスに該当するメソッドが実装されているかをチェックするのをallocate-instance :beforeに仕掛けます。

(defpackage "0cbdbd51-5be8-57c3-9b14-9473f74c8a61" (:use c2cl))

(cl:in-package "0cbdbd51-5be8-57c3-9b14-9473f74c8a61")

(defclass enforcing-abstract-methods-class (standard-class)
  ((abstract-methods :initform '() :accessor class-abstract-methods)
   (direct-abstract-methods :initform '()
                            :reader class-direct-abstract-methods
                            :initarg :abstract-methods)))

(defmethod finalize-inheritance :after ((class enforcing-abstract-methods-class))
  (setf (class-abstract-methods class)
        (remove-duplicates
         (loop :for c :in (class-precedence-list class)
               :when (typep c 'enforcing-abstract-methods-class)
               :append (mapcar #'eval (class-direct-abstract-methods c)))
         :from-end T)))
(defmethod allocate-instance :before ((class enforcing-abstract-methods-class)
                                      &key &allow-other-keys)
  (dolist (gf (class-abstract-methods class))
    (or (some (lambda (x)
                (find class (method-specializers x)))
              (generic-function-methods gf))
        (error "Can't instantiate abstract class ~S with abstract methods ~S."
               class
               gf))))

ついでに、インスタンス化不可なabstract-classも定義します。
こちらは、以前ブログで紹介したものになります。

#:g1: Common Lispで抽象クラス

一応仕組みを解説すると、abstract-classを:metaclassに指定した場合、class-prototype :aroundとallocate-instanceの組み合わせがエラーになりますが、抽象クラスのサブクラスがstandard-class等を:metaclassに指定すれば、通常ルートでインスタンス生成が実行されるのでエラーにならない、という流れです。

(defclass abstract-class (standard-class) 
  ())

(defmethod validate-superclass ((class abstract-class) (superclass standard-class)) 
  T)

(defmethod validate-superclass ((class standard-class) (superclass abstract-class)) 
  T)

(defvar *outside-abstract-class* nil)

(defmethod allocate-instance ((class abstract-class) &key &allow-other-keys)
  (unless *outside-abstract-class*
    (error "There was an attempt to make an instance of abstract class ~S" (class-name class))))
(defmethod class-prototype :around ((class abstract-class))
  (let ((*outside-abstract-class* T))
    (call-next-method)))

試してみる

;; 抽象クラス
(defclass foo ()
  (a b c)
  (:metaclass abstract-class))

;; インスタンス化できない
(make-instance 'foo)
!!! There was an attempt to make an instance of abstract class foo

;; 実装するメソッド
(defgeneric ztesch (x))
(defgeneric bazola (x y))
;; メソッド実装強制クラス
(defclass bar (foo)
  ()
  (:metaclass enforcing-abstract-methods-class)
  (:abstract-methods #'ztesch #'bazola))
;; インスタンス化できない
(make-instance 'bar)
!!! Can't instantiate abstract class #<enforcing-abstract-methods-class bar 41C00A64F3> with abstract methods #<common-lisp:standard-generic-function ztesch 41E001C3FC>.
;; 抽象クラス+メソッド実装強制メタクラス
(defclass abstract-class-enforcing-abstract-methods-class (abstract-class enforcing-abstract-methods-class)
  ())

;; 抽象クラス+メソッド実装強制クラス(が抽象クラスを継承)
(defclass baz (foo)
  ()
  (:metaclass abstract-class-enforcing-abstract-methods-class)
  (:abstract-methods #'ztesch #'bazola))

;; インスタンス化できない(なお実装を強制されたメソッドが空の場合、抽象クラス側のエラーとなる)
(make-instance 'baz)
!!! Can't instantiate abstract class #<abstract-class-enforcing-abstract-methods-class baz 42205DAC5B> with abstract methods #<common-lisp:standard-generic-function ztesch 424001B494>.
;; 抽象クラス+メソッド実装強制クラス(が抽象クラスを継承)のサブクラス
(defclass quux (baz)
  ()
  (:metaclass enforcing-abstract-methods-class))

(finalize-inheritance (find-class 'quux))

;; 実装が強制されたメソッドの確認
(class-abstract-methods (find-class 'quux))
→ (#<common-lisp:standard-generic-function ztesch 41E001C3FC> #<common-lisp:standard-generic-function bazola 41E001C434>) 
;; メソッドが実装されていないのでエラー
(make-instance 'quux)
!!! Can't instantiate abstract class #<enforcing-abstract-methods-class quux 40201AD06B> with abstract methods #<common-lisp:standard-generic-function ztesch 41E001C3FC>.
;; メソッドの実装
(defmethod ztesch ((q quux))
  (with-slots (a b c) q
    (setq a 0 b 1 c 2))
  q)

(defmethod bazola ((x integer) (y quux))
  (with-slots (a b c) y
    (* x (+ a b c))))
;; インスタンス化できた 
(bazola 10 (ztesch (make-instance 'quux)))
→ 30

まとめ

今回は抽象クラスとメソッド実装の強制を別々に定義してメタクラスのmixinとしました。
メソッド実装が強制されるという感覚にいま一つ馴染がないのですが、Common Lispにどうなるのが正しいのかは色々コードを書いてみないと分からなさそうです……。

■

HTML generated by 3bmd in LispWorks 7.0.0