[rucksack-devel] Re: SHARED-INITIALIZE calling (SETF SLOT-VALUE-USING-CLASS)

[Pascal Costanza]

Hi Arthur,

I had exactly the same issue some time ago. The surprising thing is  
that a CLOS implementation is actually allowed not to use (setf slot- 
value-using-class) for object initialization, though the part that  
specifices this is somewhat tricky to find. Check out the notes  
section of shared-initialize in the HyperSpec, there it is specified  
under what circumstances (setf slot-value-using-class) can be  
circumvented (although this part actually doesn't explicitly refer to  
the MOP).

My solution was to create a new default super class for my own  
metaclass, ensure that it is used instead of standard-object, and  
then specialize shared-initialize accordingly. The following is taken  
from ContextL, and is just a straightforward implementation of the  
shared-initalize specification. Feel free to reuse it.

#+(or lispworks (and mcl (not openmcl)))
(defmethod shared-initialize ((object special-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)

Note that I intentionally do not use (setf slot-value-using-class)  
here, but (setf slot-value) because otherwise this would break in  
some implementations. (I don't remember which one it was.) The  
effect, however, is that (setf slot-value-using-class) will  
ultimately be called - and then it works correctly. Don't ask me  
why... ;)

I hope this helps.


Pascal

On 3 Sep 2006, at 23:45, Arthur Lemmens wrote:

> Hi Pascal,
>
> While working on Rucksack I noticed that Lispworks (5.0) does not
> seem to call (SETF SLOT-VALUE-USING-CLASS) for the slots that it
> initializes in SHARED-INITIALIZE, whereas SBCL (0.9.16) *does*
> call (SETF SLOT-VALUE-USING-CLASS) in that situation.
>
> Have you ever noticed this difference?  Can you confirm it?  Do you
> know if the MOP specifies one way or the other?  Can you think of a
> way to get Lispworks behave like SBCL, or the other way round?
>
> Which is the better approach, according to you?  I was a bit surprised
> when I found out that Lispworks' SHARED-INITIALIZE did not call
> (SETF SLOT-VALUE-USING-CLASS), but then I programmed my way around it
> and forgot about it.  Until SBCL users started testing my nifty new
> indexing and schema update features for Rucksack, and complained about
> stack overflows ;-)
>
> Thanks for any insights you may have on this subject,
>
> Arthur
>
>

-- 
Pascal Costanza, mailto:pc at p-cos.net, http://p-cos.net
Vrije Universiteit Brussel, Programming Technology Lab
Pleinlaan 2, B-1050 Brussel, Belgium