#:g1: リードオンリーなスロット

allocate-instance Advent Calendar 2020 16日目の記事です。

何かallocate-instanceネタがないか、隠しスロットの応用がないか、と探しまわっていますが、そういえば、defstructにはスロットの:read-onlyオプションがあるのに、defclassにはないなと思ったので、隠しスロットで実装してみました。

動作

(defclass foo (acl-slots-object)
  ((a :initform 0 :read-only T :accessor foo-a)
   (b :initform 1 :read-only nil)
   (c :initform 2 :read-only T))
  (:metaclass acl-slots-class))

(mapcar #'slot-definition-read-only-p (class-slots (find-class 'foo)))
→ (t nil t)

(let ((obj (make-instance 'foo)))
  (with-slots (a b c) obj
    (list a b c)))
→ (0 1 2)

(let ((obj (make-instance 'foo)))
  (with-slots (a b c) obj
    (setq b 100)
    (list a b c)))
→ (0 100 2)

(let ((obj (make-instance 'foo)))
  (with-slots (a b c) obj
    (setq a 100)
    (list a b c)))
!!! Cannot assign to read only slot a of #<foo 40201234EB>

(let ((obj (make-instance 'foo)))
  (setf (foo-a obj) 8))
!!! Cannot assign to read only slot a of #<foo 402020F6C3>

ここまで書いて試してみて、クラスの属性としてスロットにリードオンリー属性を付けるだけならインスタンスに隠しスロットを付ける意味がないという致命的なことに気付いてしまったので、インスタンス生成時にも個別に指定できるようにしてみました。

(make-instance 'bar :read-onlys '(:b))のように:read-onlys引数で該当するスロットの:initargを指定します。

(defclass bar (acl-slots-object)
  ((a :read-only T :initform 0 :initarg :a :reader bar-a)
   (b :read-only nil :initform 1 :initarg :b :accessor bar-b)
   (c :read-only T :initform 2 :initarg :c))
  (:metaclass acl-slots-class))

(let ((obj (make-instance 'bar)))
  (setf (bar-b obj) 42))
→ 42

(let ((obj (make-instance 'bar :read-onlys '(:b))))
  (setf (bar-b obj) 42))
!!! Cannot assign to read only slot b of #<bar 402009983B>

まとめ

あと九個もネタが捻り出せない。

実装

(defpackage "3d5973f5-7755-5daf-a825-d623a03a4d53" (:use c2cl slotted-objects))

(cl:in-package "3d5973f5-7755-5daf-a825-d623a03a4d53")

(defconstant slot-dim 0)

(defconstant acl-dim 1)

(defclass acl-slots-class (slotted-class)
  ()
  (:metaclass standard-class))

(defmethod allocate-instance ((class acl-slots-class) &rest initargs)
  (allocate-slotted-instance (class-wrapper class)
                          (make-array `(2 ,(length (class-slots class)))
                                      :initial-element (make-unbound-marker))))

(defclass acl-slots-object (slotted-object)
  ()
  (:metaclass acl-slots-class))

(defmethod slot-value-using-class ((class acl-slots-class) instance (slotd slot-definition))
  (aref (instance-slots instance)
        slot-dim
        (slot-definition-location slotd)))

(defmethod (setf slot-value-using-class) (value (class acl-slots-class) instance (slotd slot-definition))
  (let* ((slots (instance-slots instance))
         (loc (slot-definition-location slotd)))
    (when (aref slots acl-dim loc)
      (error "Cannot assign to read only slot ~S of ~S" (slot-definition-name slotd) instance))
    (setf (aref slots slot-dim loc) value)))

(defun slot-read-only-p (instance slot-name)
  (aref (instance-slots instance)
        acl-dim
        (slot-definition-location
         (find slot-name (class-slots (class-of instance))
               :key #'slot-definition-name))))

(defclass acl-slots-slot-definition (standard-slot-definition)
  ((attributes :initform nil
               :initarg :read-only 
               :accessor slot-definition-read-only-p)))

(defclass direct-acl-slots-slot-definition (standard-direct-slot-definition acl-slots-slot-definition)
  ())

(defmethod direct-slot-definition-class ((class acl-slots-class) &rest initargs)
  (find-class 'direct-acl-slots-slot-definition))

(defclass effective-acl-slots-slot-definition (standard-effective-slot-definition acl-slots-slot-definition)
  ())

(defmethod effective-slot-definition-class ((class acl-slots-class) &rest initargs)
  (find-class 'effective-acl-slots-slot-definition))

(defmethod compute-effective-slot-definition ((class acl-slots-class)
                                              name
                                              direct-slot-definitions)
  (let ((effective-slotd (call-next-method)))
    (dolist (slotd direct-slot-definitions)
      (when (typep slotd 'acl-slots-slot-definition)
        (setf (slot-definition-read-only-p effective-slotd) 
              (slot-definition-read-only-p slotd))
        (return)))
    effective-slotd))

(defmethod initialize-slot-from-initarg ((class acl-slots-class) instance slotd initargs)
  (let ((slot-initargs (slot-definition-initargs slotd)))
    (loop :for (initarg value) :on initargs :by #'cddr
          :do (when (member initarg slot-initargs)
                (setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
                      value)
                (return T)))))

(defmethod initialize-slot-from-initfunction ((class acl-slots-class) instance slotd)
  (let ((initfun (slot-definition-initfunction slotd)))
    (unless (not initfun)
      (setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
            (funcall initfun)))))

(defmethod shared-initialize :after ((instance acl-slots-object) slot-names &key read-onlys &allow-other-keys)
  (let* ((class (class-of instance))
         (slots (class-slots class)))
    (dolist (s slots)
      (setf (aref (instance-slots instance) acl-dim (slot-definition-location s))
            (slot-definition-read-only-p s))
      (when (intersection read-onlys (slot-definition-initargs s))
        (setf (aref (instance-slots instance) acl-dim (slot-definition-location s))
              T)))))

■

HTML generated by 3bmd in LispWorks 7.0.0