クラスに必須スロットを設定する - lisp-cookbook-ja/common-lisp GitHub Wiki

MOP c2mop

MOPを利用しない場合

:initformにエラーを発する式を与えることにより、初期化時に明示的に上書きしない場合、エラーを発します。

(defclass foo ()
  ((r1 :initform (error "Required slot unbound R1.") :initarg :r1)
   (r2 :initform (error "Required slot unbound R2.") :initarg :r2)
   (r3 :initform (error "Required slot unbound R3.") :initarg :r3)
   (x :initarg :x)))

動作

(make-instance 'foo)
;>>> Required slot unbound R1.

(describe (make-instance 'foo :r1 1 :r2 2 :r3 3))
;->  #<FOO {104A159393}>
;      [standard-object]
;
;    Slots with :INSTANCE allocation:
;      R1  = 1
;      R2  = 2
;      R3  = 3
;      X   = #<unbound slot>
;
;=>  No value.

MOPを利用した場合

下記では、required-slot-classという必須スロットのメタクラスを作成し、make-instance時にチェックし条件が満されていない場合にエラーを発します。

MOPのコンパチブルレイヤーとしてCLiki:Closer-MOPを利用します

導入方法

(ql:quickload :closer-mop)

(defclass required-slot-class (standard-class)
  ((direct-required-slots
    ;; メタクラスの:initargは、defclassのslot-optionとして利用できる
    :initarg :required-slots
    :initform '()
    :reader direct-required-slots)
   (class-required-slots :accessor class-required-slots)))


(defmethod c2mop:validate-superclass ((class required-slot-class)
                                      (super standard-class))
  ;; standard-class、required-slot-classの異なるメタクラス間で
  ;; クラスが継承できるようにする
  t)


(defmethod direct-required-slots ((class class))
  ;; required-slot-classでない場合は空リストを返す
  '())


(defmethod c2mop:finalize-inheritance :after ((class required-slot-class))
  ;; class-precedence-listを継承順に辿り、direct-required-slotsをマージして
  ;; class-required-slotsを作成する
  (setf (class-required-slots class)
        (remove-duplicates (mapcan (lambda (ds)
                                     (copy-list (direct-required-slots ds)))
                                   (c2mop:class-precedence-list class))
                           :from-end T
                           :test #'equal)))


(defmethod unbound-required-slot-using-class ((class required-slot-class) object slot-name)
  ;; required-slotがunboundの場合エラーを発する
  (error "Required slot unbound ~A." slot-name))


(defmethod check-required-slots-using-class ((class required-slot-class) object)
  ;; required-slotのクラスとインスタンスを用いてrequired-slotがunboundでないかを
  ;; チェックする
  (dolist (rs (class-required-slots class))
    (unless (and (symbolp rs) (slot-boundp object rs))
      (unbound-required-slot-using-class class object rs))))


(defmethod make-instance ((class required-slot-class) &rest args)
  ;; インスタンスを生成し、スロットをcheck-required-slots-using-classでチェックする
  (let ((instance (call-next-method)))
    (check-required-slots-using-class class instance)
    instance))

動作

(defclass required-slots-demo ()
  ((r1 :initarg :r1)                    ;必須1
   (r2 :initarg :r2)                    ;必須2
   (r3 :initarg :r3)                    ;必須3
   (x :initarg :x)
   (y :initarg :y)
   (z :initarg :z))
  (:metaclass required-slot-class)
  (:required-slots r1 r2 r3))           ;必須スロット名を指定


(describe (make-instance 'required-slots-demo :r1 1 :r2 2 :r3 3))
;->  #<REQUIRED-SLOTS-DEMO {104BD22F33}>
;      [standard-object]
;
;    Slots with :INSTANCE allocation:
;      R1  = 1
;      R2  = 2
;      R3  = 3
;      X   = #<unbound slot>
;      Y   = #<unbound slot>
;      Z   = #<unbound slot>
;
;=>  No value


(make-instance 'required-slots-demo :r2 2 :r3 3 :x 4)
;>>> Required slot unbound R1.

参考