#:g1: スロットのアクセス時まで初期化を遅らせる

Posted 2019-11-24 20:54:15 GMT

ECLOSのlazy-classというのを再現してみようかなと思っているのですが、このlazy-slotには初期化のタイミングが、通常の初期化時と、スロット読み取り時直前とで二通りで選択可能です。
lazy-classには、他にも初期化の依存関係を記述する機能があるのですが、とりあえずそれは置いて、初期化タイミングだけ切り出して実現方法を考えてみました。
上手く行けば、初期化の依存関係を記述する機能と、初期化タイミングの指定は後でmixinできるでしょう。

あれこれ考えて作成してみましたが、下記のように動作します。

(defconstant <i@robj>
  (defclass i@robj (initialize-at-read-object)
    ((a :initform 'a :initialize-at-read-p T)
     (b :initform 'b :accessor b)
     (c :initform 'c :accessor c))
    (:metaclass initialize-at-read-class)))

(class-slots <i@robj>)(#<initialize-at-read-effective-slot-definition a 402023D19B> #<initialize-at-read-effective-slot-definition b 402023D37B> #<initialize-at-read-effective-slot-definition c 402023D3EB>)

(class-initialize-at-read-slots <i@robj>)(#<initialize-at-read-effective-slot-definition a 4020235393>)

(let ((o (make-instance <i@robj>))) (list (slot-boundp o 'a) (slot-value o 'a) (slot-value o 'b) (slot-value o 'c)))(nil a b c)

実装した内容としては、

位です。

実現したいことは単純なので、どうにかコードを圧縮したいところですが、MOPのコードはどうも長くなってしまいますね。
まあ、そんなに頻繁に書くものでもないので長くても良いのか……。

今回の場合は、slot-unboundを使ってスロットの初期化をすれば良いので、クラスごとに定義することにはなるもののMOPをカスタマイズしなくてもslot-unboundの定義だけすれば、正味五六行の追加で済みそうではあります。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :closer-mop))

(defpackage "a86f7ecc-112d-5ccb-9280-20798a2e36b4" (:use :c2cl))

(in-package "a86f7ecc-112d-5ccb-9280-20798a2e36b4")

;; utils (eval-when (:compile-toplevel :load-toplevel :execute) (defun package-symbolconc (package-spec &rest frobs) (values (intern (with-standard-io-syntax (with-output-to-string (out) (dolist (elt frobs) (unless (typep elt '(or symbol string fixnum character)) (error "The value ~A is not of type (OR SYMBOL STRING FIXNUM CHARACTER)." elt)) (princ elt out)))) package-spec))) (defun symbolconc (&rest frobs) (declare (dynamic-extent frobs)) (apply #'package-symbolconc *package* frobs)))

(defclass initialize-at-read-class (standard-class) ((initialize-at-read-slots :initform nil :accessor class-initialize-at-read-slots)) (:metaclass standard-class))

(defclass initialize-at-read-object (standard-object) () (:metaclass initialize-at-read-class))

(defmethod validate-superclass ((c initialize-at-read-class) (s standard-class)) T)

(macrolet ((defslotd (name) (let ((class (symbolconc name '-class)) (slotd (symbolconc name '-slot-definition)) (dslotd (symbolconc name '-direct-slot-definition)) (eslotd (symbolconc name '-effective-slot-definition)) (slotp (symbolconc 'slot-definition- name '-p))) `(progn (defclass ,slotd (standard-slot-definition) ((,(symbolconc name '-p) :initform nil :accessor ,slotp :initarg ,(package-symbolconc :keyword name '-p)))) (defclass ,dslotd (,slotd standard-direct-slot-definition) ()) (defclass ,eslotd (,slotd standard-effective-slot-definition) ()) (defmethod direct-slot-definition-class ((class ,class) &rest initargs) (declare (ignore initargs)) (find-class ',dslotd)) (defmethod effective-slot-definition-class ((class ,class) &rest initargs) (declare (ignore initargs)) (find-class ',eslotd)) (defmethod compute-effective-slot-definition ((class ,class) name direct-slot-definitions) (declare (ignore name)) (let ((eslotd (call-next-method))) (dolist (dslotd direct-slot-definitions) (when (typep dslotd (find-class ',slotd)) (setf (,slotp eslotd) (,slotp dslotd)) (return))) eslotd)) (defmethod slot-unbound ((class ,class) (instance ,(symbolconc name '-object)) name) (let ((slotd (find name (,(symbolconc 'class- name '-slots) class) :key #'slot-definition-name))) (let ((result (funcall (slot-definition-initfunction slotd)))) (setf (slot-value instance name) result) result))) (defmethod compute-slots :around ((class ,class)) (let ((slots (call-next-method))) (setf (,(symbolconc 'class- name '-slots) class) (remove-if-not #',slotp slots)) slots)))))) (defslotd initialize-at-read))

(defun initialize-slot-from-initarg (class instance slotd initargs) (let ((slot-initargs (slot-definition-initargs slotd))) (loop :for (initarg value) :on initargs :by #'cddr :do (when (and (member initarg slot-initargs) (not (slot-definition-initialize-at-read-p slotd))) (setf (slot-value-using-class class instance slotd) value) (return t)))))

(defun initialize-slot-from-initfunction (class instance slotd) (let ((initfun (slot-definition-initfunction slotd))) (unless (or (not initfun) (slot-boundp-using-class class instance slotd)) (unless (slot-definition-initialize-at-read-p slotd) (setf (slot-value-using-class class instance slotd) (funcall initfun))))))

(defmethod shared-initialize ((instance initialize-at-read-object) slot-names &rest initargs) (let* ((class (class-of instance))) (dolist (slotd (class-slots class)) (unless (initialize-slot-from-initarg class instance slotd initargs) (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 7.0.0

comments powered by Disqus