KMRCLを眺める(236) attrib-class.lisp — #:g1

Posted 2011-11-10 19:57:00 GMT

今回眺める attrib-class.lisp は、スロットに属性が付いたクラスの定義です。 AMOP(The Art of the Metaobject Protocol)でも例題になっていますが、定盤の拡張のようです。 クラスのメンバーは、CLOSではスロットと呼びますが、そのスロットごとに対応するalistが付ける、というものです。 とりあえず、上から順に眺めていきます。 いきなりですが、

;; Disable attrib class until understand changes in sbcl/cmucl
;; using COMPUTE-SLOT-ACCESSOR-INFO and defining method
;; for slot access of ALL-ATTRIBUTES. Does this work on Allegro/LW?
ということで、現在このファイルはライブラリとしては読み込まれていないようです。 asdのファイルもコメントアウトしてありました。 COMPUTE-SLOT-ACCESSOR-INFO が〜とありますが、ちょっとこの辺りは分かりません。とりあえずは、ちょっとした例は動いているようなので、動かしてみます。 とりあえず、札付きのメタクラスの定義
(in-package #:kmrcl)

(defclass attributes-class (kmr-mop:standard-class) () (:documentation "metaclass that implements attributes on slots. Based on example from AMOP"))

次にスロットの定義 ヒョージュン直接スロット定義=サン(ややこしいので日本語にします)を継承した、札付きの直接スロット定義=サンを定義 ヒョージュンと比べてみます。
(describe (make-instance 'kmr-mop:standard-direct-slot-definition))
;>>  #<SB-MOP:STANDARD-DIRECT-SLOT-DEFINITION NIL {1007FCB7F3}>
;>>    [standard-object]
;>>
;>>  Slots with :INSTANCE allocation:
;>>    NAME              = NIL
;>>    INITFORM          = NIL
;>>    INITFUNCTION      = NIL
;>>    READERS           = NIL
;>>    WRITERS           = NIL
;>>    INITARGS          = NIL
;>>    %TYPE             = T
;>>    %DOCUMENTATION    = NIL
;>>    %CLASS            = NIL
;>>    ALLOCATION        = :INSTANCE
;>>    ALLOCATION-CLASS  = NIL
;>>
;=>  <no values>

(describe (make-instance 'attributes-dsd))
;>>  #<ATTRIBUTES-DSD NIL {1007E4D433}>
;>>    [standard-object]
;>>
;>>  Slots with :INSTANCE allocation:
;>>    NAME              = NIL
;>>    INITFORM          = NIL
;>>    INITFUNCTION      = NIL
;>>    READERS           = NIL
;>>    WRITERS           = NIL
;>>    INITARGS          = NIL
;>>    %TYPE             = T
;>>    %DOCUMENTATION    = NIL
;>>    %CLASS            = NIL
;>>    ALLOCATION        = :INSTANCE
;>>    ALLOCATION-CLASS  = NIL
;>>    ATTRIBUTES        = NIL
;>>
;=>  <no values>
あたりまえですが、
;>>    ATTRIBUTES        = NIL
が追加されています。 ヒョージュン実効スロット定義=サンのクラスを継承して、attributesを追加した、 札付きの実効スロット定義=サンを定義
(defclass attributes-esd (kmr-mop:standard-effective-slot-definition)
  ((attributes :initarg :attributes :initform nil
               :accessor esd-attributes)))
LispWorksだけに関わる謎のネンブツ
;; encapsulating macro for Lispworks
(kmr-mop:process-slot-option attributes-class :attributes)
attributes-classは、standard-classのサブクラスであるように、スーパークラス検見奉行=サン(ややこしいので日本語にします)にレイギを教える
#+(or cmu scl sbcl ccl)
(defmethod kmr-mop:validate-superclass ((class attributes-class)
                                        (superclass kmr-mop:standard-class))
  t)

直接スロット定義クラス奉行=サンを定義。上記で定義した、札付きの直接スロット定義クラス=サンを返すようにします。
(defmethod kmr-mop:direct-slot-definition-class ((cl attributes-class) #+kmrcl::normal-dsdc &rest initargs)
  (declare (ignore initargs))
  (kmr-mop:find-class 'attributes-dsd))
※kmrcl::normal-dsdcが*features*にはいってないと&restが評価されないようなので、追加しておく必要があります。
(pushnew 'kmrcl::normal-dsdc *features*)
(kmr-mop:direct-slot-definition-class (make-instance 'attributes-class))
;=>  #<STANDARD-CLASS ATTRIBUTES-DSD>
実効スロット定義クラス奉行=サン(ややこしいので日本語にします)をユビキリ。上記で定義した、札付きの実効スロット定義クラス=サンを返すようなレイギ。
(defmethod kmr-mop:effective-slot-definition-class ((cl attributes-class) #+kmrcl::normal-dsdc &rest initargs)
  (declare (ignore initargs))
  (kmr-mop:find-class 'attributes-esd))
(kmr-mop:effective-slot-definition-class (make-instance 'attributes-class))
;=>  #<STANDARD-CLASS ATTRIBUTES-ESD>
実効スロット勘定奉行=サンの働きを定義 ※kmrcl::normal-cesdが*features*にはいってないと&restが評価されないようなので追加
(pushnew 'kmrcl::normal-cesd *features*)
(defmethod kmr-mop:compute-effective-slot-definition
    ((cl attributes-class) #+kmrcl::normal-cesd name dsds)
  #+kmrcl::normal-cesd (declare (ignore name))
  (let ((esd (call-next-method)))
    (setf (esd-attributes esd) (remove-duplicates (mapappend #'dsd-attributes dsds)))
    esd))
スロット勘定奉行=サンの働きを定義。 札付き実効スロット定義=サンから、札付き実効スロット=サンを作ってギンミします。
;; This does not work in Lispworks prior to version 4.3

(defmethod kmr-mop:compute-slots ((class attributes-class))
  (let* ((normal-slots (call-next-method))
         (alist (mapcar
                 #'(lambda (slot)
                     (cons (kmr-mop:slot-definition-name slot)
                           (mapcar #'(lambda (attr) (list attr))
                                   (esd-attributes slot))))
                 normal-slots)))

(cons (make-instance 'attributes-esd :name 'all-attributes :initform `',alist :initfunction #'(lambda () alist) :allocation :instance :documentation "Attribute bucket" :type t ) normal-slots)))

動かしてみます。 ■札付きスロットクラス
(defclass foo ()
  (a b c)
  (:metaclass kl:attributes-class))

(kmr-mop:finalize-inheritance (find-class 'foo))

(kmr-mop:compute-slots (find-class 'foo)) ;=> (#<ATTRIBUTES-ESD ALL-ATTRIBUTES> #<ATTRIBUTES-ESD A> #<ATTRIBUTES-ESD B> ; #<ATTRIBUTES-ESD C>)

■ヒョージュン
(defclass std ()
  (a b c)
  ;; (:metaclass standard-class)
  )
(kmr-mop:finalize-inheritance (find-class 'std))

(kmr-mop:compute-slots (find-class 'std)) ;=> (#<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION A> ; #<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION B> ; #<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION C>)

札付きスロット係=サンを定義します。結果は、
(defun slot-attribute (instance slot-name attribute)
  (cdr (slot-attribute-bucket instance slot-name attribute)))
結果は、
(let ((foo (make-instance 'foo)))
  (setf (cdr (assoc 'a (slot-value foo 'all-attributes)))
        (acons :memo2 "メモその2"
               (list (cons :memo "aのメモ"))))
  (slot-value foo 'all-attributes))
という定義だとすると、
(let ((foo (make-instance 'foo)))
  (slot-value foo 'all-attributes))
;=>  ((A (:MEMO2 . "メモその2") (:MEMO . "aのメモ")) (B) (C))
という風に、入れ子のalistが返るオキテになっています。 札付きスロット係=サンの書き込みの方法をユビキリします。
(defun (setf slot-attribute) (new-value instance slot-name attribute)
  (setf (cdr (slot-attribute-bucket instance slot-name attribute))
    new-value))
札付きスロット籠係=サンを定義します。
(defun slot-attribute-bucket (instance slot-name attribute)
  (let* ((all-buckets (slot-value instance 'all-attributes))
         (slot-bucket (assoc slot-name all-buckets)))
    (unless slot-bucket
      (error "The slot named ~S of ~S has no attributes."
             slot-name instance))
    (let ((attr-bucket (assoc attribute (cdr slot-bucket))))
      (unless attr-bucket
        (error "The slot named ~S of ~S has no attributes named ~S."
               slot-name instance attribute))
      attr-bucket)))
動作
(let ((foo (make-instance 'foo)))
  (slot-attribute-bucket foo 'a :memo))
;=>  (:MEMO . "aのメモ")
attributes-classでは、、定義したfooのクラス内で属性は共用されますが、そのサブクラスとは共用されないようになっています。
(defclass bar (foo)
  (d)
  (:metaclass kl:attributes-class))

(let ((bar (make-instance 'bar))) (slot-value bar 'all-attributes)) ;=> ((A) (B) (C) (D)) (let ((bar (make-instance 'bar))) (setf (cdr (assoc 'a (slot-value bar 'all-attributes))) (acons :memo2 "bar a メモその2" (list (cons :memo "aのメモ")))) (slot-value bar 'all-attributes)) ;=> ((A (:MEMO2 . "bar a メモその2") (:MEMO . "aのメモ")) (B) (C) (D))

■ という感じにざっと眺めましたが、あまり良く分かっていないので、記述も怪しい感じにしてみました。 ちなみに、ニンジャスレイヤーは、まだ呼んだことがないので、そのうち読んでみたいと思います。 ■

comments powered by Disqus