From 0dca577dbc1360385c0f21a33ceebb2575275e05 Mon Sep 17 00:00:00 2001
Message-Id: <0dca577dbc1360385c0f21a33ceebb2575275e05.1715341736.git.mdw@distorted.org.uk>
From: Mark Wooding <mdw@chiark.greenend.org.uk>
Date: Sun, 26 Mar 2017 15:16:18 +0100
Subject: [PATCH] src/class-finalize.lisp: Improve reporting of CPL
 construction errors.
Organization: Straylight/Edgeware

From: Mark Wooding <mdw@distorted.org.uk>

Introduce `report-class-list-merge-error' to report problems properly.
---
 doc/SYMBOLS                  |  1 +
 doc/meta.tex                 |  4 +++
 src/class-finalize-impl.lisp | 58 ++++++++++++++++++++++++++++++++----
 3 files changed, 58 insertions(+), 5 deletions(-)

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 45369ff..dcd96ec 100644
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -198,6 +198,7 @@ class-finalize-impl.lisp
   l*loops-cpl                                   function
   merge-class-lists                             function
   python-cpl                                    function
+  report-class-list-merge-error                 function
 
 class-finalize-proto.lisp
   check-sod-class                               generic
diff --git a/doc/meta.tex b/doc/meta.tex
index 0710350..24a7af8 100644
--- a/doc/meta.tex
+++ b/doc/meta.tex
@@ -330,6 +330,10 @@
 \begin{describe}{gf}{compute-cpl @<class> @> @<list>}
 \end{describe}
 
+\begin{describe}{fun}
+    {report-class-list-merge-error @<class> @<lists> @<error>}
+\end{describe}
+
 \begin{describe}{fun}{merge-class-lists @<class> @<lists> @<pick> @> @<list>}
 \end{describe}
 
diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index 8933773..772ad6f 100644
--- a/src/class-finalize-impl.lisp
+++ b/src/class-finalize-impl.lisp
@@ -50,17 +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 (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
-   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)
-    (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.
 
-- 
[mdw]