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

CLOS のスロットは値を持ちます。
defclass の中で :documentation を指定することによりドキュメントを持つこともできます。
これを defclass の中で :label を指定して、スロットがラベルを持つように MOP で拡張してみようと思います。
ソースは次のとおり（処理系は SBCL です）。
standard-direct-slot-definition と standard-effective-slot-definition をまだよく理解していませんが、何とか動くようにできました。

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

(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 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)
                                              name
                                              dslotds)
  "call-next-method で通常のスロット定義を行った後、ラベルを設定します。"
  (let ((slot-definition (call-next-method)))
    (setf (label slot-definition) (label (car dslotds)))
    slot-definition))

(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)))

いや、ほんとうにらき☆すたはおもしろいです。