#:g1: 続・mopでstandard-objectとsymbolを融合したい

前回はstandard-objectとsymbolの融合として、symbol-valueにインスタンスを設定するという方法を試しましたが、今回はsymbolオブジェクトのplistをインスタンスのスロットに見立てたらどうなるかを試してみたいと思います。

実装してみた

(defclass foo ()
  ((a :initform 0)
   (b :initform 1)
   (c :initform 2))
  (:metaclass symb-class))

(make-instance 'foo)
→ foo0

(symbol-plist 'foo0)
→ (#<standard-effective-slot-definition c 4020015753> 2 #<standard-effective-slot-definition b 40200156EB> 1 #<standard-effective-slot-definition a 4020015683> 0 class #<symb-class foo 41202C6E8B> clos::class-wrapper #(2445 (a b c) nil #<symb-class foo 41202C6E8B> (#<standard-effective-slot-definition a 4020015683> #<standard-effective-slot-definition b 40200156EB> #<standard-effective-slot-definition c 4020015753>) 3)) 

(with-slots (a b c) 'foo0
  (list a b c))
→ (0 1 2)

(with-slots (a b c) 'foo0
  (incf a 100)
  (incf b 100)
  (incf c 100))
→ 102

(symbol-plist 'foo0)
→ (100 101 102)

オブジェクトシステムのツールがシンボルに対して機能するがの面白いといえば、面白いですが、一連のオブジェクトシステムのツール全部をシンボルオブジェクトに対して有効に使えるようにするのはちょっと難しいのであまり旨味はないですね。

コード

(defpackage "a1a9aa2a-8de2-5040-89dc-acd6b4de23f0" (:use :c2cl))

(in-package "a1a9aa2a-8de2-5040-89dc-acd6b4de23f0")

(defclass slotted-class (standard-class)
  ())

(defclass symb-class (slotted-class)
  ())

(defclass symb-object ()
  ()
  (:metaclass symb-class))

(defmethod validate-superclass ((class symb-class) (super standard-class))
  T)

#+LispWorks
(defmethod allocate-instance ((class symb-class) &rest initargs)
  (let* ((class (clos::ensure-class-finalized class))
         (instance (gentemp (string (class-name class)))))
    (setf (get instance 'clos::class-wrapper)
          (clos::class-wrapper class))
    (setf (get instance 'class)
          class)
    instance))

(defmethod slot-value-using-class
           ((class (eql (find-class 'symbol))) instance (slotd symbol))
  (get instance (find slotd (class-slots (get instance 'class)) :key #'slot-definition-name)))

(let ((lw:*handle-warn-on-redefinition* nil))
  (defmethod slot-value-using-class
             ((class (eql (find-class 'symbol))) instance (slotd slot-definition))
    (get instance slotd))

  (defmethod slot-value-using-class
             ((class (eql (find-class 'symbol))) instance (slotd symbol))
    (get instance (find slotd (class-slots (get instance 'class)) :key #'slot-definition-name)))

  (defmethod (setf slot-value-using-class)
             (val (class (eql (find-class 'symbol))) instance (slotd slot-definition))
    (setf (get instance slotd) val))

  (defmethod (setf slot-value-using-class)
             (val (class (eql (find-class 'symbol))) instance (slotd symbol))
    (setf (get instance (find slotd (class-slots (get instance 'class)) :key #'slot-definition-name)) val))

  (defmethod shared-initialize ((instance symbol) slot-names &rest initargs)
    (flet ((initialize-slot-from-initarg (class instance slotd)
             (let ((slot-initargs (slot-definition-initargs slotd))
                   (name slotd))
               (loop :for (initarg value) :on initargs :by #'cddr
                     :do (when (member initarg slot-initargs)
                           (setf (get instance name)
                                 value)
                           (return t)))))
           (initialize-slot-from-initfunction (class instance slotd)
             (let ((initfun (slot-definition-initfunction slotd))
                   (name slotd))
               (unless (not initfun)
                 (setf (get instance name)
                       (funcall initfun))))))
      (let ((class (get instance 'class)))
        (dolist (slotd (class-slots class))
          (unless (initialize-slot-from-initarg class instance slotd)
            (when (or (eq t slot-names)
                      (member (slot-definition-name slotd) slot-names))
              (initialize-slot-from-initfunction class instance slotd)))))
      instance)))

まとめ

今回は、シンボルをそのままオブジェクトに見立ててみたのですが、オブジェクトシステムは、コンテナとしてのインスタンスでディスパッチするのが便利というところがあるので、コンテナはそのままにしつつストレージの方を配列からハッシュテーブルにしてみたり、シンボルにしてみたり、という方が発展させ甲斐がありそう、という当たり前の結論に到達しました……。

■

HTML generated by 3bmd in LispWorks Personal Edition 7.1.2