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 89337736e136c17d2512f0bc26c968c05f8c3abd..e7fc45a91cb283e310592d84f96bb21eb3d9c503 100644 (file)
--- a/src/class-finalize-impl.lisp
+++ b/src/class-finalize-impl.lisp
@@ -50,17 +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)
 (defun merge-class-lists (class lists pick)
 (export 'merge-class-lists)
 (defun merge-class-lists (class lists pick)

-  "Merge the LISTS of subclasses of CLASS, using PICK to break ties.
+  "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."
+   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)
   (handler-case (merge-lists lists :pick pick)

-    (inconsistent-merge-error ()
-      (error "Failed to compute class precedence list for `~A'"
-            (sod-class-name class)))))
+    (inconsistent-merge-error (error)
+      (report-class-list-merge-error class lists error)
+      (continue error))))

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


@@ -290,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.
 


@@ -531,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