doc/sod.tex: Don't print the `Index' header in uppercase.

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

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index f67c1187af6760a3a5b5a4e65d77890b28d63a24..772ad6ff570f0c5b7c58844ec2515b0a57b2d534 100644 (file)
--- a/src/class-finalize-impl.lisp
+++ b/src/class-finalize-impl.lisp
@@ -50,19 +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.  Also, this wrapper
-   provides a standard presentation function so that any errors are presented
-   properly."
-  (merge-lists lists
-              :pick pick
-              :present (lambda (class)
-                         (format nil "`~A'" (sod-class-name class)))))
+   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.
 


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


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


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


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


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


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