X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/c05a49772af66d4059f856218f0bea74d2462d45..4ee476bc29b80fca2faabb4bd286ca70c98f7a44:/src/class-finalize-impl.lisp

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index ce3282f..772ad6f 100644
--- a/src/class-finalize-impl.lisp
+++ b/src/class-finalize-impl.lisp
@@ -50,14 +50,65 @@ (cl:in-package #:sod)
 
 ;;; 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 (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
-   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.
 
@@ -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."
 
-  (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.
@@ -128,11 +176,11 @@ (defun clos-cpl (class)
 	       (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)
@@ -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."
 
-  (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)
@@ -174,7 +222,8 @@ (defun c3-cpl (class)
 
   (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)))))
@@ -237,7 +286,8 @@ (defun l*loops-cpl (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))
@@ -248,10 +298,7 @@ (defun l*loops-cpl (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.