src/: Guess the metaclass early, unless we're explicitly bootstrapping.

[sod] / src / class-finalize-impl.lisp

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index 6be6b497078e718f69a6ae5026c35d01375cee56..e7fc45a91cb283e310592d84f96bb21eb3d9c503 100644 (file)
--- a/src/class-finalize-impl.lisp
+++ b/src/class-finalize-impl.lisp
@@ -50,14 +50,65 @@ (cl:in-package #:sod)
 
 ;;; Utilities.
 
 
 ;;; Utilities.
 

+(export 'report-class-list-merge-error)
+(defun report-class-list-merge-error (class lists error)
+  "Report a failure to merge superclasseses.
+
+   Here, CLASS is the class whose class precedence list we're trying to
+   compute; the LISTS are the individual superclass orderings being merged;
+   and ERROR is an `inconsistent-merge-error' describing the problem that was
+   encountered.
+
+   Each of the LISTS is assumed to begin with the class from which the
+   corresponding constraint originates; see `merge-class-lists'."
+
+  (let* ((state (make-inheritance-path-reporter-state class))
+        (candidates (merge-error-candidates error))
+        (focus (remove-duplicates
+                (remove nil
+                        (mapcar (lambda (list)
+                                  (cons (car list)
+                                        (remove-if-not
+                                         (lambda (item)
+                                           (member item candidates))
+                                         list)))
+                                lists)
+                        :key #'cddr)
+                :test #'equal :key #'cdr)))
+
+    (cerror*-with-location class "Ill-formed superclass graph: ~
+                                 can't construct class precedence list ~
+                                 for `~A'"
+                          class)
+    (dolist (offenders focus)
+      (let ((super (car offenders)))
+       (info-with-location super
+                           "~{Class `~A' orders `~A' before ~
+                              ~#[<BUG>~;`~A'~;`~A' and `~A'~:;~
+                                 ~@{`~A', ~#[~;and `~A'~]~}~]~}"
+                           offenders)
+       (report-inheritance-path state super)))))
+

 (export 'merge-class-lists)
 (export 'merge-class-lists)

-(defun merge-class-lists (lists pick)
-  "Merge the LISTS of classes, using PICK to break ties.
+(defun merge-class-lists (class lists pick)
+  "Merge the LISTS of superclasses of CLASS, using PICK to break ties.

 
    This is a convenience wrapper around the main `merge-lists' function.
    Given that class linearizations (almost?) always specify a custom
 
    This is a convenience wrapper around the main `merge-lists' function.
    Given that class linearizations (almost?) always specify a custom

-   tiebreaker function, this isn't a keyword argument."
-  (merge-lists lists :pick pick))
+   tiebreaker function, this isn't a keyword argument.
+
+   If a merge error occurs, this function translates it into a rather more
+   useful form, and tries to provide helpful notes.
+
+   For error reporting purposes, it's assumed that each of the LISTS begins
+   with the class from which the corresponding constraint originates.  This
+   initial class does double-duty: it is also considered to be part of the
+   list for the purpose of the merge."
+
+  (handler-case (merge-lists lists :pick pick)
+    (inconsistent-merge-error (error)
+      (report-class-list-merge-error class lists error)
+      (continue error))))

 
 ;;; Tiebreaker functions.
 
 
 ;;; Tiebreaker functions.
 


@@ -125,11 +176,11 @@ (defun clos-cpl (class)
               (remove-duplicates (cons class
                                        (mappend #'superclasses
                                                 direct-supers))))))
               (remove-duplicates (cons class
                                        (mappend #'superclasses
                                                 direct-supers))))))

-    (merge-class-lists
-     (mapcar (lambda (class)
-              (cons class (sod-class-direct-superclasses class)))
-            (superclasses class))
-     #'clos-tiebreaker)))
+    (merge-class-lists class
+                      (mapcar (lambda (c)
+                                (cons c (sod-class-direct-superclasses c)))
+                              (superclasses class))
+                      #'clos-tiebreaker)))

 
 (export 'dylan-cpl)
 (defun dylan-cpl (class)
 
 (export 'dylan-cpl)
 (defun dylan-cpl (class)


@@ -150,11 +201,11 @@ (defun dylan-cpl (class)
    assuming that the superclass CPLs are already monotonic.  If they aren't,
    you're going to lose anyway."
 
    assuming that the superclass CPLs are already monotonic.  If they aren't,
    you're going to lose anyway."
 

-  (let ((direct-supers (sod-class-direct-superclasses class)))
-    (merge-class-lists
-     (cons (cons class direct-supers)
-          (mapcar #'sod-class-precedence-list direct-supers))
-     #'clos-tiebreaker)))
+  (let* ((direct-supers (sod-class-direct-superclasses class))
+        (cpls (mapcar #'sod-class-precedence-list direct-supers)))
+    (merge-class-lists class
+                      (cons (cons class direct-supers) cpls)
+                      #'clos-tiebreaker)))

 
 (export 'c3-cpl)
 (defun c3-cpl (class)
 
 (export 'c3-cpl)
 (defun c3-cpl (class)


@@ -171,7 +222,8 @@ (defun c3-cpl (class)
 
   (let* ((direct-supers (sod-class-direct-superclasses class))
         (cpls (mapcar #'sod-class-precedence-list direct-supers)))
 
   (let* ((direct-supers (sod-class-direct-superclasses class))
         (cpls (mapcar #'sod-class-precedence-list direct-supers)))

-    (merge-class-lists (cons (cons class direct-supers) cpls)
+    (merge-class-lists class
+                      (cons (cons class direct-supers) cpls)

                       (lambda (candidates so-far)
                         (declare (ignore so-far))
                         (c3-tiebreaker candidates cpls)))))
                       (lambda (candidates so-far)
                         (declare (ignore so-far))
                         (c3-tiebreaker candidates cpls)))))


@@ -234,7 +286,8 @@ (defun l*loops-cpl (class)
 
   (let ((dfs (flavors-cpl class)))
     (cons class
 
   (let ((dfs (flavors-cpl class)))
     (cons class

-         (merge-class-lists (mapcar #'sod-class-precedence-list
+         (merge-class-lists class
+                            (mapcar #'sod-class-precedence-list

                                     (sod-class-direct-superclasses class))
                             (lambda (candidates so-far)
                               (declare (ignore so-far))
                                     (sod-class-direct-superclasses class))
                             (lambda (candidates so-far)
                               (declare (ignore so-far))


@@ -245,10 +298,7 @@ (defun l*loops-cpl (class)
 ;;; Default function.
 
 (defmethod compute-cpl ((class sod-class))
 ;;; Default function.
 
 (defmethod compute-cpl ((class sod-class))

-  (handler-case (c3-cpl class)
-    (inconsistent-merge-error ()
-      (error "Failed to compute class precedence list for `~A'"
-            (sod-class-name class)))))
+  (c3-cpl class))

 
 ;;;--------------------------------------------------------------------------
 ;;; Chains.
 
 ;;;--------------------------------------------------------------------------
 ;;; Chains.


@@ -288,27 +338,6 @@ (defmethod compute-chains ((class sod-class))
                                           (gethash super table))
                                         (cdr class-precedence-list)))))))))
 
                                           (gethash super table))
                                         (cdr class-precedence-list)))))))))
 

-;;;--------------------------------------------------------------------------
-;;; Metaclasses.
-
-(defmethod guess-metaclass ((class sod-class))
-  "Default metaclass-guessing function for classes.
-
-   Return the most specific metaclass of any of the CLASS's direct
-   superclasses."
-
-  ;; During bootstrapping, our superclasses might not have their own
-  ;; metaclasses resolved yet.  If we find this, then throw `bootstrapping'
-  ;; so that `shared-initialize' on `sod-class' can catch it (or as a shot
-  ;; across the bows of anyone else who calls us).
-  (finalization-error (:bad-metaclass)
-    (select-minimal-class-property (sod-class-direct-superclasses class)
-                                  (lambda (super)
-                                    (if (slot-boundp super 'metaclass)
-                                        (slot-value super 'metaclass)
-                                        (throw 'bootstrapping nil)))
-                                  #'sod-subclass-p class "metaclass")))
-

 ;;;--------------------------------------------------------------------------
 ;;; Sanity checking.
 
 ;;;--------------------------------------------------------------------------
 ;;; Sanity checking.
 


@@ -529,11 +558,6 @@ (defmethod finalize-sod-class ((class sod-class))
   ;; clone of the CPL and chain establishment code.  If the interface changes
   ;; then `bootstrap-classes' will need to be changed too.
 
   ;; clone of the CPL and chain establishment code.  If the interface changes
   ;; then `bootstrap-classes' will need to be changed too.
 

-  ;; Set up the metaclass if it's not been set already.  This is delayed
-  ;; to give bootstrapping a chance to set up metaclass and superclass
-  ;; circularities.
-  (default-slot (class 'metaclass) (guess-metaclass class))
-

   ;; Finalize all of the superclasses.  There's some special pleading here to
   ;; make bootstrapping work: we don't try to finalize the metaclass if we're
   ;; a root class (no direct superclasses -- because in that case the
   ;; Finalize all of the superclasses.  There's some special pleading here to
   ;; make bootstrapping work: we don't try to finalize the metaclass if we're
   ;; a root class (no direct superclasses -- because in that case the