(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)

diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 263a9b852256730ffc84ca97c07f8d70a3b7c622..71b4a863b305054f63269b72bd2209f7a0766342 100644 (file)
--- 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 728b3761a9a8e84bfece1c44ea2aa41bfff65183..cf01d23a90c4e2a66071d2c527c3c76e836c6268 100644 (file)
--- 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)))))