Re: [Sbcl-devel] Bootstrapping of classes(?); SBCL + ContextL

[Pascal C. <pc...@p-...>]

Hi there,

On 25 Oct 2008, at 21:45, Nikodemus Siivola wrote:

> On Sat, Oct 25, 2008 at 6:30 PM, Pascal Costanza <pc...@p-...> wrote:
>
>> In ContextL, there are some metaclass where
>> I add a direct superclass unless one of the existing direct  
>> superclasses is
>> already a subtype of that superclass. This seems to break for certain
>> anonymous classes during initialization of other class metaobjects.
>
> Right, and since the SUBTYPEP signals an error for some cases, you add
> the SPECIAL-OBJECT in a place where it doesn't belong. I see the
> problem, and have some ideas how to fix it -- or at least where to
> apply the duct tape.
>
>> I recall adding gensymmed names to anonymous classes in Closer MOP  
>> for SBCL,
>> but removed that later because it seemed to be fixed at some stage.  
>> Is the
>> problem back again?
>>
>> It should be possible to add the gensymmed names again to make  
>> ContextL work
>> again, but maybe you want to fix this in SBCL? Could you let me  
>> know so I
>> know what to do in Closer MOP?
>
> Depends. It will probably be at least a week before the fix hits CVS  
> HEAD.
>
> Alternatively, you could do something along the lines of
>
> (defun subclassp (class super)
>  (if (closer-mop:class-finalized-p class)
>      (and (member super (closer-mop:class-precedence-list class)) t)
>      (dolist (direct (closer-mop:class-direct-superclasses class))
> 	(when (or (eq super direct) (subclassp direct super))
> 	  (return t)))))
>
> (defmethod initialize-instance :around
>  ((class special-class) &rest initargs
>   &key direct-superclasses)
>  (declare (dynamic-extent initargs))
>  (let ((special (find-class 'special-object)))
>    (if (loop for superclass in direct-superclasses
>              thereis (subclassp superclass special))
>        (call-next-method)
>        (apply #'call-next-method class
>               :direct-superclasses
>               (append direct-superclasses (list special))
>               initargs))))
>
> (defmethod reinitialize-instance :around
>  ((class special-class) &rest initargs
>   &key (direct-superclasses () direct-superclasses-p))
>  (declare (dynamic-extent initargs))
>  (if direct-superclasses-p
>      (let ((special (find-class 'special-object)))
>        (if (loop for superclass in direct-superclasses
>                  thereis (subclassp superclass special))
>            (call-next-method)
>            (apply #'call-next-method class
>                   :direct-superclasses
>                   (append direct-superclasses (list special))
>                   initargs)))
>      (call-next-method)))
>
> in ContextL, maybe?

I have added a function subclassp to Closer to MOP, which doesn't take  
the class precedence list into account. (It's not necessary to do so!)  
Instead, it just walks the superclass hierarchy. I have replaced the  
corresponding calls to subtypep with calls to subclassp in ContextL.  
So this should work now.

(I had similar problems in other CL implementations - clisp doesn't  
like forward referenced classes, for example. That's why I add this to  
Closer to MOP.)

Your implementation of subclassp is recursive, and also may get into  
trouble when there is a circle in the class hierarchy. Also, I think  
the class-finalized-p test is not sufficient in this context - it  
could be that you do the test after a class metaobject has been  
reinitialized but before it is finalized again. Unfortunately, AMOP  
doesn't specify a function with which you could determine this state,  
so it's better to do the slow test in the general case.

Here is my version, derived from some similar code in Closette:

(defun subclassp (class superclass)
   (flet ((get-class (class) (etypecase class
                               (class class)
                               (symbol (find-class class)))))

       (loop with class = (get-class class)
             with superclass = (get-class superclass)

             for superclasses = (list class)
             then (set-difference
                   (union (class-direct-superclasses current-class)  
superclasses)
                   seen)

             for current-class = (first superclasses)

             while current-class

             if (eq current-class superclass) return t
             else collect current-class into seen

             finally (return nil))))


Pascal

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