scratch/derived-mode-add-parents-2 97a2305482c: Move EIEIO's C3 linearization code to `subr.el`

[Stefan Monnier]

branch: scratch/derived-mode-add-parents-2
commit 97a2305482c24574c2429d50f3573810a0d12091
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    Move EIEIO's C3 linearization code to `subr.el`
    
    The code was used to linearize the EIEIO class hierarchy, since
    it results in saner results than things like BFS or DFS.
    By moving it to `subr.el` we get to benefit from that same
    advantage both in `cl--class-allparents` and
    in `derived-mode-all-parents`.
    
    * lisp/subr.el (merge-ordered-lists): New function.
    (derived-mode-all-parents): Use it to improve parent ordering.
    
    * lisp/emacs-lisp/eieio-core.el (eieio--c3-candidate)
    (eieio--c3-merge-lists): Delete functions, replaced by
    `merge-ordered-lists`.
    (eieio--class-precedence-c3): Use `merge-ordered-lists`.
    
    * lisp/emacs-lisp/cl-preloaded.el (cl--class-allparents):
    Use `merge-ordered-lists` to improve parent ordering.
    * lisp/emacs-lisp/cl-macs.el (cl--struct-all-parents): Delete function.
    (cl--pcase-mutually-exclusive-p): Use `cl--class-allparents` instead.
---
 lisp/emacs-lisp/cl-macs.el      | 17 ++----------
 lisp/emacs-lisp/cl-preloaded.el | 12 +++------
 lisp/emacs-lisp/eieio-core.el   | 58 +++++------------------------------------
 lisp/simple.el                  |  2 +-
 lisp/subr.el                    | 57 +++++++++++++++++++++++++++++++++-------
 5 files changed, 61 insertions(+), 85 deletions(-)

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index e2c13534054..2431e658368 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3337,19 +3337,6 @@ To see the documentation for a defined struct type, use
 
 ;;; Add cl-struct support to pcase
 
-;;In use by comp.el
-(defun cl--struct-all-parents (class) ;FIXME: Merge with `cl--class-allparents'
-  (when (cl--struct-class-p class)
-    (let ((res ())
-          (classes (list class)))
-      ;; BFS precedence.
-      (while (let ((class (pop classes)))
-               (push class res)
-               (setq classes
-                     (append classes
-                             (cl--class-parents class)))))
-      (nreverse res))))
-
 ;;;###autoload
 (pcase-defmacro cl-struct (type &rest fields)
   "Pcase patterns that match cl-struct EXPVAL of type TYPE.
@@ -3395,8 +3382,8 @@ the form NAME which is a shorthand for (NAME NAME)."
           (let ((c1 (cl--find-class t1))
                 (c2 (cl--find-class t2)))
             (and c1 c2
-                 (not (or (memq c1 (cl--struct-all-parents c2))
-                          (memq c2 (cl--struct-all-parents c1)))))))
+                 (not (or (memq t1 (cl--class-allparents c2))
+                          (memq t2 (cl--class-allparents c1)))))))
      (let ((c1 (and (symbolp t1) (cl--find-class t1))))
        (and c1 (cl--struct-class-p c1)
             (funcall orig (cl--defstruct-predicate t1)
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 03068639575..3d0c2b54785 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -323,15 +323,9 @@ supertypes from the most specific to least specific.")
 (cl-assert (cl--class-p (cl--find-class 'cl-structure-object)))
 
 (defun cl--class-allparents (class)
-  (let ((parents ())
-        (classes (list class)))
-    ;; BFS precedence.  FIXME: Use a topological sort.
-    (while (let ((class (pop classes)))
-             (cl-pushnew (cl--class-name class) parents)
-             (setq classes
-                   (append classes
-                           (cl--class-parents class)))))
-    (nreverse parents)))
+  (cons (cl--class-name class)
+        (merge-ordered-lists (mapcar #'cl--class-allparents
+                                     (cl--class-parents class)))))
 
 (eval-and-compile
   (cl-assert (null (cl--class-parents (cl--find-class 'cl-structure-object)))))
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index f5ff04ff372..8e8fa2b168e 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -964,49 +964,6 @@ need be... May remove that later...)"
        (cdr tuple)
       nil)))
 
-;;;
-;; Method Invocation order: C3
-(defun eieio--c3-candidate (class remaining-inputs)
-  "Return CLASS if it can go in the result now, otherwise nil."
-  ;; Ensure CLASS is not in any position but the first in any of the
-  ;; element lists of REMAINING-INPUTS.
-  (and (not (let ((found nil))
-             (while (and remaining-inputs (not found))
-               (setq found (member class (cdr (car remaining-inputs)))
-                     remaining-inputs (cdr remaining-inputs)))
-             found))
-       class))
-
-(defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs)
-  "Try to merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order.
-If a consistent order does not exist, signal an error."
-  (setq remaining-inputs (delq nil remaining-inputs))
-  (if (null remaining-inputs)
-      ;; If all remaining inputs are empty lists, we are done.
-      (nreverse reversed-partial-result)
-    ;; Otherwise, we 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* ((found nil)
-          (tail remaining-inputs)
-          (next (progn
-                  (while (and tail (not found))
-                    (setq found (eieio--c3-candidate (caar tail)
-                                                      remaining-inputs)
-                          tail (cdr tail)))
-                  found)))
-      (if next
-         ;; The graph is consistent so far, add NEXT to result and
-         ;; merge input lists, dropping NEXT from their heads where
-         ;; applicable.
-         (eieio--c3-merge-lists
-          (cons next reversed-partial-result)
-          (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l))
-                  remaining-inputs))
-       ;; The graph is inconsistent, give up
-       (signal 'inconsistent-class-hierarchy (list remaining-inputs))))))
-
 (defsubst eieio--class/struct-parents (class)
   (or (eieio--class-parents class)
       `(,eieio-default-superclass)))
@@ -1014,14 +971,13 @@ If a consistent order does not exist, signal an error."
 (defun eieio--class-precedence-c3 (class)
   "Return all parents of CLASS in c3 order."
   (let ((parents (eieio--class-parents class)))
-    (eieio--c3-merge-lists
-     (list class)
-     (append
-      (or
-       (mapcar #'eieio--class-precedence-c3 parents)
-       `((,eieio-default-superclass)))
-      (list parents))))
-  )
+    (cons class
+          (merge-ordered-lists
+           (append
+            (or
+             (mapcar #'eieio--class-precedence-c3 parents)
+             `((,eieio-default-superclass)))
+            (list parents))))))
 ;;;
 ;; Method Invocation Order: Depth First
 
diff --git a/lisp/simple.el b/lisp/simple.el
index 266a66500cb..f79f1013669 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -1029,7 +1029,7 @@ that if you use overwrite mode as your normal editing 
mode, you can use
 this function to insert characters when necessary.
 
 In binary overwrite mode, this function does overwrite, and octal
-(or decimal or hex) digits are interpreted as a character code.  This
+\(or decimal or hex) digits are interpreted as a character code.  This
 is intended to be useful for editing binary files."
   (interactive "*p")
   (let* ((char
diff --git a/lisp/subr.el b/lisp/subr.el
index b000787a5d6..a209c76ad85 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -2678,6 +2678,50 @@ The variable list SPEC is the same as in `if-let*'."
 
 ;; PUBLIC: find if the current mode derives from another.
 
+(defun merge-ordered-lists (lists &optional error-function)
+  "Merge LISTS in a consistent order.
+LISTS is a list of lists of elements.
+Merge them into a single list containing the same elements (removing
+duplicates) and obeying their relative positions in each list.
+If a consistent order does not exist, call ERROR-FUNCTION with
+the remaining lists.
+It should return the candidate to use to continue the merge
+By default we choose the first element of the first list."
+  ;; Use [C3](https://en.wikipedia.org/wiki/C3_linearization)
+  (let ((result '()))
+    (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 (memq 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))))
+       (unless next ;; The graph is inconsistent.
+         (setq next (funcall (or error-function #'caar) lists)))
+       ;; 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 (eq (car l) next) (cdr l) l))
+                     lists))))
+    (if (null result) (car lists) ;; Common case.
+      (append (nreverse result) (car lists)))))
+
 (defun derived-mode-all-parents (mode &optional known-children)
   "Return all the parents of MODE, starting with MODE.
 The returned list is not fresh, don't modify it.
@@ -2708,17 +2752,12 @@ The returned list is not fresh, don't modify it.
                          ;; If MODE is an alias, then follow the alias.
                          (let ((alias (symbol-function mode)))
                            (and (symbolp alias) alias))))
-             (parents (cons mode (if parent (funcall all-parents parent))))
+             (parents (if parent (funcall all-parents parent)))
              (extras (get mode 'derived-mode-extra-parents)))
         (put mode 'derived-mode--all-parents
-             (if (null extras) ;; Common case.
-                 parents
-               (delete-dups
-                (apply #'append
-                       parents (mapcar (lambda (extra)
-                                         (copy-sequence
-                                          (funcall all-parents extra)))
-                                       extras)))))))))
+             (cons mode
+                   (merge-ordered-lists
+                    (cons parents (mapcar all-parents extras)))))))))
 
 (defun provided-mode-derived-p (mode &rest modes)
   "Non-nil if MODE is derived from one of MODES.