From: Fernando Mato Mira
Subject: Metaclass inheritance?
Date: Fri, 08 Jan 1993 14:42:39 +0000
Message-ID: <1993Jan8.154239@di.epfl.ch>

Let's say you have a metaclass ATTRIBUTED-CLASS, so when you do

(defclass foo () () 
 (:metaclass attributed-class))

you get something like
#<ATTRIBUTED-CLASS SCHEMA @ #x10f7f26a>

Then somebody comes and does  
(defclass bar (foo) ())

and he gets
#<STANDARD-CLASS BAR @ #x10f82c02>

when what he really needs is
#<ATTRIBUTED-CLASS BAR @ #x10f82c02>

and you would like to hide the implementation-dependent metaclass.

I think that in many cases, if you can resolve the set of common subclasses of
the set of metaclasses of the direct superclasses of a class to a hierarchy,
taking the root of that hierarchy as the default metaclass is the way that you want to go, and not getting just STANDARD-CLASS instead.
For disambiguating more complicated cases, or for getting some other metaclass than this default one, the :metaclass option is there.
If you do not disambiguate by using the :metaclass option, then getting STANDARD-CLASS as the default would be OK.
When a direct superclass of the class being defined  is a forward-referenced class, it is treated by the previous algorithm as if its metaclass were STANDARD-CLASS instead of FORWARD-REFERENCED-CLASS.

It seems that the only way of implementing this today is by defining an :around
method on ENSURE-CLASS-USING-CLASS which is not exactly great to specialize, so
maybe taking a look again at this part of the CLOS specification would be a good
idea.

-- 
Fernando D. Mato Mira
Computer Graphics Lab			   "Bury GIFs!! Get JPEGed!!!"
Swiss Federal Institute of Technology
········@di.epfl.ch

NeXTMail : ········@lignext.epfl.ch
FAX 	 : +41 (21) 693 - 5328

From: Fernando Mato Mira
Subject: Re: Metaclass inheritance?
Date: Fri, 08 Jan 1993 21:03:17 +0000
Message-ID: <1993Jan8.220317@di.epfl.ch>

Here is a way of implementing the rule for implementing metaclass inheritance
proposed in my previous post (Note that it is NECESSARY to clearly specify in
the MOP that DEFCLASS should NOT default the :metaclass option to STANDARD-CLASS.
I found out that the current implementation of Allegro CL does exactly this.
(There is no problem if the standard methods on ENSURE-CLASS-USING-CLASS do it,
though).

(in-package :clos)
(use-package :series)

(defmethod ensure-class-using-class :around ((class t) name 
                                             &rest args
                                             &key (direct-superclasses nil)
                                                  (metaclass nil))
  (if (or metaclass (null direct-superclasses))
      (call-next-method)
    (let* ((forward-referenced-class (find-class 'forward-referenced-class))
           (direct-supers (if (collect-or (map-fn 't #'(lambda (class)
                                                         (symbolp class))
                                                  (scan 'list direct-superclasses)))
                              (collect '(list class)
                                       (map-fn 't #'(lambda (class)
                                                      (if (symbolp class)
                                                          (or (find-class class nil) 
                                                              (ensure-class class
                                                                            :metaclass 'forward-referenced-class))
                                                        class))
                                               (scan 'list direct-superclasses)))
                            direct-superclasses))
           (metaclasses (collect 'list
                                 (map-fn 'list ;(type standard-class))
                                         #'subclasses* 
                                         (choose-if #'(lambda (class)
                                                        (not (eq class forward-referenced-class)))
                                                    (map-fn 'class
                                                            #'class-of
                                                            (scan '(list class) direct-supers)))))))
      (cond (metaclasses
             (cond ((eql (length metaclasses) 1)
                    (setq metaclass (caar metaclasses)))
                   (t
                    (setq metaclasses (delete-duplicates (apply #'intersection metaclasses)))
                    (setq metaclass (collect '(list class) (choose-if #'(lambda (class)
                                                                   (collect-and (map-fn 't #'(lambda (c)
                                                                                               (subtypep c class))
                                                                                        (scan '(list class) metaclasses))))
                                                               (scan '(list class) metaclasses))))
                    (if (eql (length metaclass) 1)
                        (setq metaclass (car metaclass))
                      (setq metaclass 'standard-class)))))
            (t 
             (setq metaclass 'standard-class)))
      #+allegro ; non-compliance fix
      (if (symbolp metaclass)
          (apply #'call-next-method class name :direct-superclasses direct-supers :metaclass metaclass args)
        (apply #'call-next-method class name :direct-superclasses direct-supers :metaclass (class-name metaclass) args))
      #-allegro
      (apply #'call-next-method class name :direct-superclasses direct-supers :metaclass metaclass args))))


(defun subclasses* (class)
  (let (last-cons l)
    (clos::map-over-subclasses #'(lambda (x)
                                   (cond (last-cons
                                           (rplacd  last-cons (cons x nil))
                                           (setq last-cons (cdr last-cons)))
                                     (t
                                       (setq last-cons (cons x nil))
                                       (setq l last-cons))))
                               class)
    l))

-- 
Fernando D. Mato Mira
Computer Graphics Lab			   "Bury GIFs!! Get JPEGed!!!"
Swiss Federal Institute of Technology
········@di.epfl.ch

NeXTMail : ········@lignext.epfl.ch
FAX 	 : +41 (21) 693 - 5328