Posted 2020-12-15 19:11:45 GMT
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