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

[Stefan Monnier]

branch: scratch/derived-mode-add-parents-2
commit fbb897b7af53cdb43e18322c5cdfbfef7cdda1ee
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   | 61 ++++++---------------------------
 lisp/simple.el                  |  2 +-
 lisp/subr.el                    | 74 +++++++++++++++++++++++++++++++++--------
 5 files changed, 77 insertions(+), 89 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..a394156c93a 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,16 @@ 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))
+           (lambda (remaining-inputs)
+            (signal 'inconsistent-class-hierarchy
+                    (list remaining-inputs)))))))
 ;;;
 ;; 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..75614f3c674 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -2678,16 +2678,68 @@ 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) using the C3 linearization, so as to obeying their relative
+positions in each list.  Equality of elements is tested with `eql'.
+
+If a consistent order does not exist, call ERROR-FUNCTION with
+a remaining list of lists that we do not know how to merge.
+It should return the candidate to use to continue the merge, which
+has to be the head of one of the lists.
+By default we choose the head of the first list."
+  (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 (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))))
+       (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)))
+       ;; 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))))
+    (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.
 \n(fn MODE)"               ;`known-children' is for internal use only.
   ;; Can't use `with-memoization' :-(
   (let ((ps (get mode 'derived-mode--all-parents)))
-    (if ps ps
-      (if (memq mode known-children)
-          (error "Cycle in the major mode hierarchy: %S" mode)
-        (push mode known-children))
+    (cond
+     (ps ps)
+     ((memq mode known-children)
+      ;; These things happen, better not get all worked up about it.
+      ;;(error "Cycle in the major mode hierarchy: %S" mode)
+      nil)
+     (t
+      (push mode known-children)
       ;; The mode hierarchy (or DAG, actually), is very static, but we
       ;; need to react to changes because `parent' may not be defined
       ;; yet (e.g. it's still just an autoload), so the recursive call
@@ -2708,17 +2760,13 @@ 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))))
              (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 (if (and parent (not (memq parent extras)))
+                              (funcall all-parents parent))
+                          (mapcar all-parents extras))))))))))
 
 (defun provided-mode-derived-p (mode &rest modes)
   "Non-nil if MODE is derived from one of MODES.