Posted 2019-03-04 22:54:25 GMT
今回のMOP vs マクロは、Gaucheのpropagatedスロット再現で比較してみたいと思います。
propagatedスロットについてはブログでの紹介記事に詳しいですが、合成した部品のスロットにアクセスする際に子コンポーネントのスロットが親のスロットとしてアクセスできる、というものです。
そもそもGaucheのpropagatedスロットが想定している利用法からするとマクロで実現してみようというのは色々と無理があるのですが、色々捨てて挙動だけ同じにしました。
(defpackage "6401746F-BD45-5DB6-BD1D-B29A1EFA0494"
(:use :c2cl))(cl:in-package "6401746F-BD45-5DB6-BD1D-B29A1EFA0494")
(defmacro with-slots/propagation ((&rest specs) obj &body body)
(etypecase specs
(null
`(with-slots () ,obj
,@body))
((cons atom null)
(let ((_obj (gensym "_obj")))
`(let ((,_obj ,obj))
(with-slots (,(car specs)) ,_obj
(with-slots/propagation (,@(cdr specs)) ,_obj
,@body)))))
(cons
(destructuring-bind (target-slot slots) (car specs)
(let ((_obj (gensym "_obj")))
`(let ((,_obj ,obj))
(with-slots (,@slots) (slot-value ,_obj ',target-slot)
(with-slots/propagation (,@(cdr specs)) ,_obj
,@body))))))))
(defclass rect ()
((width :initform 0 :initarg :width)
(height :initform 0 :initarg :height)))(defclass viewport ()
((dimension :initform (make-instance 'rect))
(width :initarg :width)
(height :initarg :height)))
(let ((obj (make-instance 'viewport)))
(with-slots/propagation ((dimension (width height))) obj
(setq width 42 height 42))
(describe (slot-value obj 'dimension)))
;>> #<rect 40200074CB> is a rect
;>> width 42
;>> height 42
当初の目的からは外れていますが、局所的にオブジェクトを合成したりするのには使えなくもないかも。
(暗黙の規約が多過ぎますが)
マクロでの実現はやりたいことの中身が全部外側に露出してしまっていますが、これをMOPで内側に収めます。
Gaucheでは、compute-get-n-setという便利なメソッドがあるので圧縮して記述できていますが、AMOP作法だと長くなります。
さらに、standard-instance-accessの利用でアクセス速度向上を狙ってみたので、より長くなりました。
(ql:quickload '(closer-mop))(defpackage "5ADAD164-D620-594D-A9C7-8E192966CA64"
(:use :c2cl))
(cl:in-package "5ADAD164-D620-594D-A9C7-8E192966CA64")
(defclass propagated-slot-class (standard-class)
())
(defmethod validate-superclass ((c propagated-slot-class) (sc standard-class))
T)
(defclass propagated-slot-definition (standard-slot-definition)
((propagate-to :initform nil
:initarg :propagate
:initarg :propagate-to
:accessor propagated-slot-definition-propagate-to)
(propagate-to# :initform nil
:accessor propagated-slot-definition-propagate-to#)))
(defmethod slot-definition-allocation ((slotd propagated-slot-definition))
:propagated)
(defmethod (setf slot-definition-allocation) (allocation (slotd propagated-slot-definition))
(unless (eq allocation :propagated)
(error "Cannot change the allocation of a ~S"
slotd))
allocation)
(defconstant <propagated-direct-slot-definition>
(defclass propagated-direct-slot-definition (standard-direct-slot-definition propagated-slot-definition)
()))
(defmethod direct-slot-definition-class ((class propagated-slot-class) &rest initargs)
(if (eq (getf initargs :allocation) :propagated)
<propagated-direct-slot-definition>
(call-next-method)))
(defconstant <propagated-effective-slot-definition>
(defclass propagated-effective-slot-definition (standard-effective-slot-definition propagated-slot-definition)
()))
(defmethod effective-slot-definition-class ((class propagated-slot-class) &rest initargs)
(if (eq :propagated (getf initargs :allocation))
<propagated-effective-slot-definition>
(call-next-method)))
(defmethod compute-effective-slot-definition ((class propagated-slot-class) name direct-slot-definitions)
(declare (ignore name))
(let ((effective-slotd (call-next-method)))
(dolist (slotd direct-slot-definitions)
(when (typep slotd 'propagated-slot-definition)
(setf (propagated-slot-definition-propagate-to effective-slotd)
(propagated-slot-definition-propagate-to slotd))
(return)))
effective-slotd))
(defmethod finalize-inheritance :after ((class propagated-slot-class))
(let ((slotds (class-slots class)))
(dolist (sd slotds)
(when (typep sd 'propagated-slot-definition)
(setf (propagated-slot-definition-propagate-to# sd)
(slot-definition-location (find (propagated-slot-definition-propagate-to sd)
slotds
:key #'slot-definition-name)))))))
#-lispworks
(defmacro slot-foo (fctn class object slotd)
(declare (ignore class))
`(,fctn
(standard-instance-access ,object
(propagated-slot-definition-propagate-to# slotd))
(slot-definition-name ,slotd)))
#-lispworks
(progn
(defmethod slot-value-using-class
((class propagated-slot-class) object (slotd propagated-slot-definition))
(slot-foo slot-value class object slotd))
(defmethod (setf slot-value-using-class)
(value (class propagated-slot-class) object (slotd propagated-slot-definition))
(setf (slot-foo slot-value class object slotd)
value))
(defmethod slot-boundp-using-class
((class propagated-slot-class) object (slotd propagated-slot-definition))
(slot-foo slot-boundp class object slotd))
(defmethod slot-makunbound-using-class
((class propagated-slot-class) object (slotd propagated-slot-definition))
(slot-foo slot-makunbound class object slotd))
(defmethod slot-exists-p-using-class
((class propagated-slot-class) object (slotd propagated-slot-definition))
(slot-foo slot-exists-p class object slotd))
);;; おまけ:LispWorksの場合
#+lispworks
(defmacro slot-foo (fctn class object slot-name)
`(let ((slotd (find ,slot-name (class-slots ,class) :key #'slot-definition-name)))
(if (typep slotd 'propagated-slot-definition)
(,fctn
(standard-instance-access ,object
(propagated-slot-definition-propagate-to# slotd))
,slot-name)
(call-next-method))))
#+lispworks
(progn
(defmethod slot-value-using-class
((class propagated-slot-class) object slot-name)
(slot-foo slot-value class object slot-name))
(defmethod (setf slot-value-using-class)
(value (class propagated-slot-class) object slot-name)
(let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name)))
(if (typep slotd 'propagated-slot-definition)
(setf (slot-value (standard-instance-access object
(propagated-slot-definition-propagate-to# slotd))
slot-name)
value)
(call-next-method))))
(defmethod slot-boundp-using-class
((class propagated-slot-class) object slot-name)
(slot-foo slot-boundp class object slot-name))
(defmethod slot-makunbound-using-class
((class propagated-slot-class) object slot-name)
(slot-foo slot-makunbound class object slot-name))
(defmethod slot-exists-p-using-class
((class propagated-slot-class) object slot-name)
(slot-foo slot-exists-p class object slot-name)))
(defclass rect ()
((width :initform 0 :initarg :width)
(height :initform 0 :initarg :height)))(defclass viewport ()
((dimension :initform (make-instance <rect>))
(width :allocation :propagated :propagate dimension
:initarg :width)
(height :allocation :propagated :propagate dimension
:initarg :height))
(:metaclass propagated-slot-class))
(let ((vp (make-instance 'viewport' :width 42 :height 42)))
(describe vp)
(describe (slot-value vp 'dimension)))
;>> #<viewport 4020098D8B> is a viewport
;>> dimension #<rect 4020098DBB>
;>> width 42
;>> height 42
;>> #<rect 4020098DBB> is a rect
;>> width 42
;>> height 42
LispWorksだと素のインスタンス生成/スロットアクセスに比較して大体1.5倍程度の遅さで済んでいるようです。
(defclass c000001 ()
((x :initform 0)
(y :initform 0)
(z :initform 0)))(let ((times 1000000)
(ans 0))
(time (dotimes (i times)
(slot-value (make-instance 'viewport) 'width)))
(time (dotimes (i times)
(slot-value (make-instance 'c000001) 'x)))
ans)
Evaluation took:
0.686 seconds of real time
0.680000 seconds of total run time (0.680000 user, 0.000000 system)
99.13% CPU
2,258,481,555 processor cycles
95,986,800 bytes consed
Evaluation took:
0.413 seconds of real time
0.410000 seconds of total run time (0.410000 user, 0.000000 system)
99.27% CPU
1,360,213,671 processor cycles
64,028,672 bytes consed
今回は、マクロ向きのお題ではありませんでしたが、動作の内容はMOPの内側か外側かの違いだけではありました。
MOPで組む前に、マクロで適当に書いてみて動作を考える、というもの場合によっては、悪くないかもしれません。
■
HTML generated by 3bmd in LispWorks 7.0.0