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

Posted 2020-12-15 19:11:45 GMT

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



(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

comments powered by Disqus