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 ce3282f5eaa792f85688ec5c81bea04339ffc15e..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.
 


@@ -72,14 +123,11 @@ (defun clos-tiebreaker (candidates so-far)
    direct subclass then that subclass's direct superclasses list must order
    them relative to each other."
 
    direct subclass then that subclass's direct superclasses list must order
    them relative to each other."
 

-  (let (winner)
-    (dolist (class so-far)
-      (dolist (candidate candidates)
-       (when (member candidate (sod-class-direct-superclasses class))
-         (setf winner candidate))))
-    (unless winner
-      (error "SOD INTERNAL ERROR: Failed to break tie in CLOS"))
-    winner))
+  (dolist (class so-far)
+    (dolist (candidate candidates)
+      (when (member candidate (sod-class-direct-superclasses class))
+       (return-from clos-tiebreaker candidate))))
+  (error "SOD INTERNAL ERROR: Failed to break tie in CLOS"))

 
 (defun c3-tiebreaker (candidates cpls)
   "The C3 linearization tiebreaker function.
 
 (defun c3-tiebreaker (candidates cpls)
   "The C3 linearization tiebreaker function.


@@ -128,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)


@@ -153,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)


@@ -174,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)))))


@@ -237,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))


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


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


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