[Common Lisp][MOP] (制服セーラーふくだからです)結論 ラベル付きのスロットを作成してみる

compute-effective-slot-definition-initargs は AMOP にはないようです。OpenMCL にもありませんでした。なので、compute-effective-slot-definition-initargs はやめにして compute-effective-slot-definition を使うように戻します。
ごめんなさい。
direct-slot-definition と effective-slot-definition の件ですが、結局は次のようなことろです。
direct-slot-definition は defclass のスロット定義でスーパークラスのスロットは含まず、class-direct-slots で取得できる。
effective-slot-definition はスーパークラスのスロットを含めたそのクラスで使用できるスロットの定義で、compute-effective-slot-definition で作成され class-slots で取得できる。

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

(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
    ((class labeled-slot-class) slot-name direct-slot-definitions)
  (declare (ignore slot-name))
  (let ((effective-definition (call-next-method))
        (labelp nil))
    (dolist (definition direct-slot-definitions)
      (when definition
        (unless labelp
          (when (slot-definition-label definition)
            (setf (slot-definition-label effective-definition)
                  (slot-definition-label definition)
                  labelp t)))))
    effective-definition))
#| OpenMCL では compute-effective-slot-definition-initargs は使われない。
AMOP にもない。
(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-effective-slot-definition (class slot-name)
  "effective slot definition を取得します。"
  (loop for slot in (class-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-effective-slot-definition class slot-name)))
    (if (null slot-definition)
        (values (slot-missing class object slot-name 'slot-label))
        (slot-definition-label slot-definition))))

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

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