scratch/derived-mode-add-parents 5afa55a946a 4/6: subr.el: Add multiple inheritance to `derived-mode-p`

[Stefan Monnier]

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

    subr.el: Add multiple inheritance to `derived-mode-p`
    
    Add the ability for a major mode to declare "extra parents" in
    addition to the one from which it inherits.
    
    * lisp/subr.el (derived-mode-add-parents): New function.
    (derived-mode-all-parents): Adjust accordingly.
---
 lisp/subr.el | 51 ++++++++++++++++++++++++++++++++++++---------------
 1 file changed, 36 insertions(+), 15 deletions(-)

diff --git a/lisp/subr.el b/lisp/subr.el
index 16f327ff699..b000787a5d6 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -2688,22 +2688,37 @@ The returned list is not fresh, don't modify it.
       (if (memq mode known-children)
           (error "Cycle in the major mode hierarchy: %S" mode)
         (push mode known-children))
-      (let* ((parent (or (get mode 'derived-mode-parent)
+      ;; 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
+      ;; to `derived-mode-all-parents' may return an
+      ;; invalid/incomplete result which we'll need to update when the
+      ;; mode actually gets loaded.
+      (let* ((all-parents
+              (lambda (parent)
+                ;; Can't use `cl-lib' here (nor `gv') :-(
+                ;;(cl-assert (not (equal parent mode)))
+                ;;(cl-pushnew mode (get parent 'derived-mode--followers))
+                (let ((followers (get parent 'derived-mode--followers)))
+                  (unless (memq mode followers)
+                    (put parent 'derived-mode--followers
+                         (cons mode followers))))
+                (derived-mode-all-parents parent known-children)))
+             (parent (or (get mode 'derived-mode-parent)
                          ;; If MODE is an alias, then follow the alias.
                          (let ((alias (symbol-function mode)))
-                           (and (symbolp alias) alias)))))
+                           (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
-             (cons mode
-                   (when parent
-                     ;; Can't use `cl-lib' here (nor `gv') :-(
-                     ;;(cl-assert (not (equal parent mode)))
-                     ;;(cl-pushnew mode (get parent 'derived-mode--followers))
-                     (let ((followers (get parent 'derived-mode--followers)))
-                       (unless (memq mode followers)
-                         (put parent 'derived-mode--followers
-                              (cons mode followers))))
-                     (derived-mode-all-parents
-                      parent known-children))))))))
+             (if (null extras) ;; Common case.
+                 parents
+               (delete-dups
+                (apply #'append
+                       parents (mapcar (lambda (extra)
+                                         (copy-sequence
+                                          (funcall all-parents extra)))
+                                       extras)))))))))
 
 (defun provided-mode-derived-p (mode &rest modes)
   "Non-nil if MODE is derived from one of MODES.
@@ -2715,8 +2730,7 @@ If you just want to check `major-mode', use 
`derived-mode-p'."
     (car ps)))
 
 (defun derived-mode-p (&rest modes)
-  "Non-nil if the current major mode is derived from one of MODES.
-Uses the `derived-mode-parent' property of the symbol to trace backwards."
+  "Non-nil if the current major mode is derived from one of MODES."
   (declare (side-effect-free t))
   (apply #'provided-mode-derived-p major-mode modes))
 
@@ -2725,6 +2739,13 @@ Uses the `derived-mode-parent' property of the symbol to 
trace backwards."
   (put mode 'derived-mode-parent parent)
   (derived-mode--flush mode))
 
+(defun derived-mode-add-parents (mode extra-parents)
+  "Add EXTRA-PARENTS to the parents of MODE.
+Declares the parents of MODE to be its main parent (as defined
+in `define-derived-mode') plus EXTRA-PARENTS."
+  (put mode 'derived-mode-extra-parents extra-parents)
+  (derived-mode--flush mode))
+
 (defun derived-mode--flush (mode)
   (put mode 'derived-mode--all-parents nil)
   (let ((followers (get mode 'derived-mode--followers)))