🚀 go-pugleaf

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
matomira@di.epfl.ch

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