[Common Lisp][MOP] 再 ラベル付きのスロットを作成してみる

何か違う。もしくは何かたりない。

もう一度 MOP でラベル付きのスロット作成です。
compute-effective-slot-definition のかわりに compute-effective-slot-definition-initargsを再定義して defclass の :label がスロットに設定さるようにしました。
labeled-slot-mixin の label のアクセサも slot-definition-label に変更しました。

direct-slot-definition と effective-slot-definition の件ですが、direct は defclass でのスロット定義を保持し、effective は親クラスのスロットを含めてそのインスタンスが持っているスロットになるような気がします。
あれ？ direct はクラスで effective はインスタンス？
あとはラベルのアクセサが欲しいです。

;;;; スロットは値を持ちますが、値の他にラベルも持つようなメタクラスを定
;;;; 義してみます。

(eval-when (:load-toplevel :compile-toplevel :execute)
  #+sbcl (use-package :sb-mop))

(defclass labeled-slot-class (standard-class)
  ()
  (:documentation "standard-class を継承してメタクラスを作ります。"))

(defmethod validate-superclass ((class labeled-slot-class)
                                (super standard-class))
  "standard-class が有効なスーパークラスです。"
  t)

(defclass labeled-slot-mixin ()
  ((label :accessor slot-definition-label
          :initarg :label
          :initform nil
          :documentation "スロットのラベルです。"))
  (:documentation "ラベルを持つスロットのためのミクスインです。"))

(defclass labeled-direct-slot-definition
    (labeled-slot-mixin standard-direct-slot-definition)
  ()
  (:documentation "labeled-slot-mixin を継承しラベルを持てるようにします。
このクラスは defclass によるスロット定義で使用されるクラスでしょうか。"))

(defclass labeled-effective-slot-definition
    (labeled-slot-mixin standard-effective-slot-definition)
  ()
  (:documentation "labeled-slot-mixin を継承しラベルを持てるようにします。
このクラスは定義済のクラスがスロットの情報を保持するためのクラスでしょうか。"))


(defmethod direct-slot-definition-class ((class labeled-slot-class)
                                         &rest initargs)
  "defclass で :label キーワードを使えるように
labeled-direct-slot-definition を返します。"
  (declare (ignore initargs))
  (find-class 'labeled-direct-slot-definition))

(defmethod effective-slot-definition-class ((class labeled-slot-class)
                                            &rest initargs)
  "スロットがラベルを保持できるように
labeled-effective-slot-definition を返します。"
  (declare (ignore initargs))
  (find-class 'labeled-effective-slot-definition))

(defmethod compute-effective-slot-definition-initargs
    ((class labeled-slot-class) direct-slotds)
  "スロットの初期化引数を求めます。"
  (let ((std-initargs (call-next-method))
        (label nil)
        (labelp nil))
    (dolist (slotd direct-slotds)
      (when slotd
        (unless labelp
          (when (slot-definition-label slotd)
            (setf label (slot-definition-label slotd)
                  labelp t)))))
    (append std-initargs
            `(,@(if labelp `(:label ,label))))))
    
(defun get-slot-definition (class slot-name)
  "スロットを取得します。class が labeled-slot-class を継承していれば
labeled-direct-slot-definition のインスタンスが返ってきます。"
  (loop for slot in (class-direct-slots class)
     if (eq slot-name
            (slot-definition-name slot))
     do (return slot)))

(defun slot-label (object slot-name)
  "スロットのラベルを取得します。"
  (let* ((class (class-of object))
         (slot-definition (get-slot-definition class slot-name)))
    (if (null slot-definition)
        (values (slot-missing class object slot-name 'slot-label))
        (slot-value slot-definition 'label))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; こんな感じで、使います。
(defclass labeled ()
  ((slot1 :accessor slot1 :initform "スロット1の値"
          :label "スロット1のラベル"))
  (:metaclass labeled-slot-class))

(let ((x (make-instance 'labeled)))
  (format t "スロットの値: ~a, ラベル: ~a~%"
          (slot1 x)
          (slot-label x 'slot1)))