Hi.
My knowledge of MOP is rather weak, so I don't know whether the
following is due to my misunderstanding of MOP concepts or due to a bug
/ feature (?) in CMUCL.
I used to think that shared-initialize which is invoked by
system-supplied primary method for initialize-instance should not
include any additional optimizations so that slot changes it makes can
be intercepted by defining methods on (setf slot-value-using-class).
Seems like this is not always the case, at least with CMUCL 19c.
In example below my (setf slot-value-using-class) method is invoked
when verify-it function is not compiled, but if I compile this function
there seem to be no (setf slot-value-using-class) invocations during
(make-instance ...). I've also checked it with an outdated version of
SBCL (0.9.3) where it behaved as expected, i.e. (setf
slot-value-using-class)
was always called. Is this a problem with my understanding of MOP or
with CMUCL? Can it be fixed?
CL-USER> (lisp-implementation-type)
"CMU Common Lisp"
CL-USER> (lisp-implementation-version)
"19c (19C)"
CL-USER> (use-package :pcl)
T
CL-USER> (defclass tst-class (standard-class) ())
(defmethod validate-superclass ((class tst-class) super) t)
(defmethod (setf slot-value-using-class) (new-value (class tst-class)
object slotd)
(format *debug-io* "~&(setf slot-value-using-class)~%")
(call-next-method))
(defclass tst ()
((a :initarg :a))
(:metaclass tst-class))
; Compiling LAMBDA (.PV-CELL. .NEXT-METHOD-CALL. CLASS SUPER):
; Compiling Top-Level Form:
; Compiling LAMBDA (.PV-CELL. .NEXT-METHOD-CALL. NEW-VALUE CLASS OBJECT
SLOTD):
; Compiling Top-Level Form:
#<TST-CLASS TST {5833E2B5}>
CL-USER> (defun verify-it ()
(make-instance 'tst :a 42))
VERIFY-IT
CL-USER> (verify-it)
(setf slot-value-using-class)
#<TST {5835450D}>
CL-USER> (compile 'verify-it)
; Compiling LAMBDA NIL:
; Compiling Top-Level Form:
VERIFY-IT
NIL
NIL
CL-USER> (verify-it)
#<TST {583C223D}>
CL-USER>
^^^
note that there's no "(setf slot-value-using-class)" message here
Ivan Shvedunov wrote:
> Hi.
> My knowledge of MOP is rather weak, so I don't know whether the
> following is due to my misunderstanding of MOP concepts or due to a bug
> / feature (?) in CMUCL.
> I used to think that shared-initialize which is invoked by
> system-supplied primary method for initialize-instance should not
> include any additional optimizations so that slot changes it makes can
> be intercepted by defining methods on (setf slot-value-using-class).
> Seems like this is not always the case, at least with CMUCL 19c.
> In example below my (setf slot-value-using-class) method is invoked
> when verify-it function is not compiled, but if I compile this function
> there seem to be no (setf slot-value-using-class) invocations during
> (make-instance ...). I've also checked it with an outdated version of
> SBCL (0.9.3) where it behaved as expected, i.e. (setf
> slot-value-using-class)
> was always called. Is this a problem with my understanding of MOP or
> with CMUCL? Can it be fixed?
ANSI Common Lisp defines a number of permissible optimizations of slot
initialization. See especially the HyperSpec entry for shared-initialize
in the notes section.
Unfortunately, the CLOS MOP specification doesn't state that these
optimizations aren't applicable anymore when (setf
slot-value-using-class) generic function is specialized for a given
metaclass.
The workaround is to reimplement shared-initialize for your own
metaclass. Something like this:
(defmethod shared-initialize
((object tst-object) slot-names &rest all-keys)
(declare (dynamic-extent all-keys))
(let ((class-slots (class-slots (class-of object))))
(loop for slot in class-slots
for slot-initargs = (slot-definition-initargs slot)
when slot-initargs do
(multiple-value-bind
(indicator value)
(get-properties all-keys slot-initargs)
(when indicator
(setf (slot-value object (slot-definition-name slot))
value))))
(if (eq slot-names 't)
(loop for slot in class-slots
for slot-name = (slot-definition-name slot)
unless (slot-boundp object slot-name) do
(let ((slot-initfunction
(slot-definition-initfunction slot)))
(when slot-initfunction
(setf (slot-value object slot-name)
(funcall slot-initfunction)))))
(loop for slot-name in slot-names
for slot = (find slot-name class-slots
:key #'slot-definition-name)
unless (slot-boundp object slot-name) do
(let ((slot-initfunction
(slot-definition-initfunction slot)))
(when slot-initfunction
(setf (slot-value object slot-name)
(funcall slot-initfunction)))))))
object)
(It's better to use (setf slot-value) here instead of (setf
slot-value-using-class) because the latter doesn't seem to work in clisp.)
You have to ensure that your metaclass tst-class adds tst-object as the
default direct superclass instead of standard-object to each of its
instances. Like this:
(defclass tst-object (standard-object)
())
(defmethod initialize-instance :around
((class tst-class) &rest initargs
&key direct-superclasses)
(declare (dynamic-extent initargs))
(if (loop for superclass in direct-superclasses
thereis (subtypep superclass 'tst-object))
(call-next-method)
(apply #'call-next-method class
:direct-superclasses
(append direct-superclasses
(list (find-class 'tst-object)))
initargs)))
(defmethod reinitialize-instance :around
((class tst-class) &rest initargs
&key (direct-superclasses () direct-superclasses-p))
(declare (dynamic-extent initargs))
(if direct-superclasses-p
(if (loop for superclass in direct-superclasses
thereis (subtypep superclass 'tst-object))
(call-next-method)
(apply #'call-next-method class
:direct-superclasses
(append direct-superclasses
(list (find-class 'tst-object)))
initargs))
(call-next-method)))
I hope this helps,
Pascal
--
3rd European Lisp Workshop
July 3-4 - Nantes, France - co-located with ECOOP 2006
http://lisp-ecoop06.bknr.net/