From c27326420f2a7aaf8ee2299ee9dfeefd52ef659d Mon Sep 17 00:00:00 2001
From: Stefan Monnier <monnier@iro.umontreal.ca>
Date: Mon, 14 Jul 2025 12:37:11 -0400
Subject: [PATCH] (cl--class-allparents): Fix bug#78989

Give more control over ordering when linearizing the
parent graph and avoid pathological misbehavior (such as
placing `t` in the middle of the linearization instead of the
end) when we can't "do it right".

* lisp/subr.el (merge-ordered-lists): Degrade more gracefully in case
of inconsistent hierarchies and don't do it silently.

* lisp/emacs-lisp/cl-preloaded.el (cl--class-allparents): Use the local
ordering to break ties, as in the C3 algorithm.

(cherry picked from commit 7f1cae9637f9a9d4715e101eecad391748e3bd3c)
---
 lisp/emacs-lisp/cl-preloaded.el | 10 ++++-
 lisp/subr.el                    | 68 ++++++++++++++++++++-------------
 2 files changed, 50 insertions(+), 28 deletions(-)

diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 263a9b85225..71b4a863b30 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -285,8 +285,14 @@
 
 (defun cl--class-allparents (class)
   (cons (cl--class-name class)
-        (merge-ordered-lists (mapcar #'cl--class-allparents
-                                     (cl--class-parents class)))))
+        (let* ((parents (cl--class-parents class))
+               (aps (mapcar #'cl--class-allparents parents)))
+          (if (null (cdr aps)) ;; Single-inheritance fast-path.
+              (car aps)
+            (merge-ordered-lists
+             ;; Add the list of immediate parents, to control which
+             ;; linearization is chosen.  doi:10.1145/236337.236343
+             (nconc aps (list (mapcar #'cl--class-name parents))))))))
 
 (cl-defstruct (built-in-class
                (:include cl--class)
diff --git a/lisp/subr.el b/lisp/subr.el
index 728b3761a9a..cf01d23a90c 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -2851,38 +2851,54 @@ By default we choose the head of the first list."
   ;; [C3](https://en.wikipedia.org/wiki/C3_linearization)
   (let ((result '()))
     (setq lists (remq nil lists)) ;Don't mutate the original `lists' argument.
-    (while (cdr (setq lists (delq nil lists)))
-      ;; Try to find the next element of the result. This
-      ;; is achieved by considering the first element of each
-      ;; (non-empty) input list and accepting a candidate if it is
-      ;; consistent with the rests of the input lists.
-      (let* ((next nil)
-	     (tail lists))
-	(while tail
-	  (let ((candidate (caar tail))
-	        (other-lists lists))
-	    ;; Ensure CANDIDATE is not in any position but the first
-	    ;; in any of the element lists of LISTS.
-	    (while other-lists
-	      (if (not (memql candidate (cdr (car other-lists))))
-	          (setq other-lists (cdr other-lists))
-	        (setq candidate nil)
-	        (setq other-lists nil)))
-	    (if (not candidate)
-	        (setq tail (cdr tail))
-	      (setq next candidate)
-	      (setq tail nil))))
+    (while (cdr lists)
+      ;; Try to find the next element of the result.  This is achieved
+      ;; by considering the first element of each input list and accepting
+      ;; a candidate if it is consistent with the rest of the input lists.
+      (let* ((find-next
+	      (lambda (lists)
+	        (let ((next nil)
+	              (tail lists))
+	          (while tail
+	            (let ((candidate (caar tail))
+	                  (other-lists lists))
+	              ;; Ensure CANDIDATE is not in any position but the first
+	              ;; in any of the element lists of LISTS.
+	              (while other-lists
+	                (if (not (memql candidate (cdr (car other-lists))))
+	                    (setq other-lists (cdr other-lists))
+	                  (setq candidate nil)
+	                  (setq other-lists nil)))
+	              (if (not candidate)
+	                  (setq tail (cdr tail))
+	                (setq next candidate)
+	                (setq tail nil))))
+	          next)))
+	     (next (funcall find-next lists)))
 	(unless next ;; The graph is inconsistent.
-	  (setq next (funcall (or error-function #'caar) lists))
-	  (unless (assoc next lists #'eql)
-	    (error "Invalid candidate returned by error-function: %S" next)))
+	  (let ((tail lists))
+            ;; Try and reduce the "remaining-list" such that its `caar`
+            ;; participates in the inconsistency (is part of an actual cycle).
+	    (while (and (cdr tail) (null (funcall find-next (cdr tail))))
+	      (setq tail (cdr tail)))
+	    (setq next (funcall (or error-function
+	                            (lambda (remaining-lists)
+                                      (message "Inconsistent hierarchy: %S"
+                                               remaining-lists)
+                                      (caar remaining-lists)))
+	                        tail))
+	    (unless (assoc next lists #'eql)
+	      (error "Invalid candidate returned by error-function: %S" next))
+	    ;; Break the cycle, while keeping other dependencies.
+            (dolist (list lists) (setcdr list (remq next (cdr list))))))
 	;; The graph is consistent so far, add NEXT to result and
 	;; merge input lists, dropping NEXT from their heads where
 	;; applicable.
 	(push next result)
 	(setq lists
-	      (mapcar (lambda (l) (if (eql (car l) next) (cdr l) l))
-		      lists))))
+	      (delq nil
+		    (mapcar (lambda (l) (if (eql (car l) next) (cdr l) l))
+		            lists)))))
     (if (null result) (car lists) ;; Common case.
       (append (nreverse result) (car lists)))))
 
-- 
2.39.5