[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master 4194f9bd870 2/2: Merge branch 'derived-mode-add-parents'
|
From: |
Stefan Monnier |
|
Subject: |
master 4194f9bd870 2/2: Merge branch 'derived-mode-add-parents' |
|
Date: |
Thu, 16 Nov 2023 09:59:36 -0500 (EST) |
branch: master
commit 4194f9bd8705b7ccc23f49aa5795af228dab26bb
Merge: ef6622bf047 44b5761b44a
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
Merge branch 'derived-mode-add-parents'
---
doc/lispref/modes.texi | 25 ++++++++
etc/NEWS | 12 ++++
lisp/cedet/mode-local.el | 65 +++++++------------
lisp/cedet/semantic/db.el | 2 +-
lisp/cedet/semantic/grammar.el | 2 +-
lisp/cedet/semantic/lex-spp.el | 6 +-
lisp/cedet/srecode/find.el | 64 ++++++++-----------
lisp/cedet/srecode/map.el | 2 +-
lisp/cedet/srecode/table.el | 51 +++++++--------
lisp/emacs-lisp/cl-generic.el | 7 +--
lisp/emacs-lisp/cl-macs.el | 17 +----
lisp/emacs-lisp/cl-preloaded.el | 12 +---
lisp/emacs-lisp/derived.el | 4 +-
lisp/emacs-lisp/eieio-core.el | 61 +++---------------
lisp/files.el | 13 ++--
lisp/help-fns.el | 1 +
lisp/ibuf-ext.el | 31 ++++-----
lisp/info-look.el | 28 ++++-----
lisp/loadhist.el | 10 +--
lisp/locate.el | 52 ++++++---------
lisp/simple.el | 2 +-
lisp/so-long.el | 3 +-
lisp/subr.el | 136 ++++++++++++++++++++++++++++++++++++----
test/lisp/subr-tests.el | 38 ++++++++++-
24 files changed, 356 insertions(+), 288 deletions(-)
diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi
index f907a6aaf09..130bc10cd59 100644
--- a/doc/lispref/modes.texi
+++ b/doc/lispref/modes.texi
@@ -937,6 +937,31 @@ This function returns non-@code{nil} if the current major
mode is
derived from any of the major modes given by the symbols @var{modes}.
@end defun
+The graph of major modes is accessed with the following lower-level
+functions:
+
+@defun derived-mode-set-parent mode parent
+This function declares that @var{mode} inherits from @code{parent}.
+This is the function that @code{define-derived-mode} calls after
+defining @var{mode} to register the fact that @var{mode} was defined
+by reusing @code{parent}.
+@end defun
+
+@defun derived-mode-add-parents mode extra-parents
+This function makes it possible to register additional parents beside
+the one that was used when defining @var{mode}. This can be used when
+the similarity between @var{mode} and the modes in @var{extra-parents}
+is such that it makes sense to treat it as a child of those
+modes for purposes like applying directory-local variables.
+@end defun
+
+@defun derived-mode-all-parents mode
+This function returns the list of all the modes in the ancestry of
+@var{mode}, ordered from the most specific to the least specific, and
+starting with @var{mode} itself.
+@end defun
+
+
@node Basic Major Modes
@subsection Basic Major Modes
diff --git a/etc/NEWS b/etc/NEWS
index 23f4a8b5311..e2a8e5dfdd8 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1196,6 +1196,18 @@ values.
* Lisp Changes in Emacs 30.1
+** New function 'merge-ordered-lists'.
+Mostly used internally to do a kind of topological sort of
+inheritance hierarchies.
+
+** New API to control the graph of major modes.
+While 'define-derived-mode' still only support single inheritance,
+modes can declare additional parents (for tests like 'derived-mode-p')
+with `derived-mode-add-parents`.
+Accessing the 'derived-mode-parent' property directly is now
+deprecated in favor of the new functions 'derived-mode-set-parent'
+and 'derived-mode-all-parents'.
+
+++
** Drag-and-drop functions can now be called once for compound drops.
It is now possible for drag-and-drop handler functions to respond to
diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el
index c1a48bc50c8..4fb4460d4c6 100644
--- a/lisp/cedet/mode-local.el
+++ b/lisp/cedet/mode-local.el
@@ -68,22 +68,15 @@ walk through. It defaults to `buffer-list'."
(when (or (not predicate) (funcall predicate))
(funcall function))))))
-(defsubst get-mode-local-parent (mode)
+(defun get-mode-local-parent (mode)
"Return the mode parent of the major mode MODE.
Return nil if MODE has no parent."
+ (declare (obsolete derived-mode-all-parents "30.1"))
(or (get mode 'mode-local-parent)
(get mode 'derived-mode-parent)))
-;; FIXME doc (and function name) seems wrong.
-;; Return a list of MODE and all its parent modes, if any.
-;; Lists parent modes first.
-(defun mode-local-equivalent-mode-p (mode)
- "Is the major-mode in the current buffer equivalent to a mode in MODES."
- (let ((modes nil))
- (while mode
- (setq modes (cons mode modes)
- mode (get-mode-local-parent mode)))
- modes))
+(define-obsolete-function-alias 'mode-local-equivalent-mode-p
+ #'derived-mode-all-parents "30.1")
(defun mode-local-map-mode-buffers (function modes)
"Run FUNCTION on every file buffer with major mode in MODES.
@@ -91,13 +84,7 @@ MODES can be a symbol or a list of symbols.
FUNCTION does not have arguments."
(setq modes (ensure-list modes))
(mode-local-map-file-buffers
- function (lambda ()
- (let ((mm (mode-local-equivalent-mode-p major-mode))
- (ans nil))
- (while (and (not ans) mm)
- (setq ans (memq (car mm) modes)
- mm (cdr mm)) )
- ans))))
+ function (lambda () (apply #'derived-mode-p modes))))
;;; Hook machinery
;;
@@ -145,7 +132,8 @@ after changing the major mode."
"Set parent of major mode MODE to PARENT mode.
To work properly, this function should be called after PARENT mode
local variables have been defined."
- (put mode 'mode-local-parent parent)
+ (declare (obsolete derived-mode-add-parents "30.1"))
+ (derived-mode-add-parents mode (list parent))
;; Refresh mode bindings to get mode local variables inherited from
;; PARENT. To work properly, the following should be called after
;; PARENT mode local variables have been defined.
@@ -159,13 +147,8 @@ definition."
(declare (obsolete define-derived-mode "27.1") (indent 2))
`(mode-local--set-parent ',mode ',parent))
-(defun mode-local-use-bindings-p (this-mode desired-mode)
- "Return non-nil if THIS-MODE can use bindings of DESIRED-MODE."
- (let ((ans nil))
- (while (and (not ans) this-mode)
- (setq ans (eq this-mode desired-mode))
- (setq this-mode (get-mode-local-parent this-mode)))
- ans))
+(define-obsolete-function-alias 'mode-local-use-bindings-p
+ #'provided-mode-derived-p "30.1")
;;; Core bindings API
@@ -270,11 +253,13 @@ its parents."
(setq mode major-mode
bind (and mode-local-symbol-table
(intern-soft name mode-local-symbol-table))))
- (while (and mode (not bind))
- (or (and (get mode 'mode-local-symbol-table)
- (setq bind (intern-soft
- name (get mode 'mode-local-symbol-table))))
- (setq mode (get-mode-local-parent mode))))
+ (let ((parents (derived-mode-all-parents mode)))
+ (while (and parents (not bind))
+ (or (and (get (car parents) 'mode-local-symbol-table)
+ (setq bind (intern-soft
+ name (get (car parents)
+ 'mode-local-symbol-table))))
+ (setq parents (cdr parents)))))
bind))
(defsubst mode-local-symbol-value (symbol &optional mode property)
@@ -311,16 +296,12 @@ Elements are (SYMBOL . PREVIOUS-VALUE), describing one
variable."
(mode-local-on-major-mode-change)
;; Do the normal thing.
- (let (modes table old-locals)
+ (let (table old-locals)
(unless mode
(setq-local mode-local--init-mode major-mode)
(setq mode major-mode))
- ;; Get MODE's parents & MODE in the right order.
- (while mode
- (setq modes (cons mode modes)
- mode (get-mode-local-parent mode)))
;; Activate mode bindings following parent modes order.
- (dolist (mode modes)
+ (dolist (mode (derived-mode-all-parents mode))
(when (setq table (get mode 'mode-local-symbol-table))
(mapatoms
(lambda (var)
@@ -345,14 +326,13 @@ If MODE is not specified it defaults to current
`major-mode'."
(kill-local-variable 'mode-local--init-mode)
(setq mode major-mode))
(let (table)
- (while mode
+ (dolist (mode (derived-mode-all-parents mode))
(when (setq table (get mode 'mode-local-symbol-table))
(mapatoms
(lambda (var)
(when (get var 'mode-variable-flag)
(kill-local-variable (intern (symbol-name var)))))
- table))
- (setq mode (get-mode-local-parent mode)))))
+ table)))))
(defmacro with-mode-local-symbol (mode &rest body)
"With the local bindings of MODE symbol, evaluate BODY.
@@ -866,12 +846,11 @@ META-NAME is a cons (OVERLOADABLE-SYMBOL . MAJOR-MODE)."
(when table
(princ "\n- Buffer local\n")
(mode-local-print-bindings table))
- (while mode
+ (dolist (mode (derived-mode-all-parents mode))
(setq table (get mode 'mode-local-symbol-table))
(when table
(princ (format-message "\n- From `%s'\n" mode))
- (mode-local-print-bindings table))
- (setq mode (get-mode-local-parent mode)))))
+ (mode-local-print-bindings table)))))
(defun mode-local-describe-bindings-1 (buffer-or-mode &optional interactive-p)
"Display mode local bindings active in BUFFER-OR-MODE.
diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el
index 7c7ee749249..0c78493542f 100644
--- a/lisp/cedet/semantic/db.el
+++ b/lisp/cedet/semantic/db.el
@@ -799,7 +799,7 @@ local variable."
(null (oref table major-mode))
;; nil means the same as major-mode
(and (not semantic-equivalent-major-modes)
- (mode-local-use-bindings-p major-mode (oref table major-mode)))
+ (provided-mode-derived-p major-mode (oref table major-mode)))
(and semantic-equivalent-major-modes
(member (oref table major-mode) semantic-equivalent-major-modes))
)
diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el
index 60c57210b8f..15ad18ad886 100644
--- a/lisp/cedet/semantic/grammar.el
+++ b/lisp/cedet/semantic/grammar.el
@@ -644,7 +644,7 @@ The symbols in the list are local variables in
(cond
(x (cdr x))
((symbolp S) (symbol-value S))))))
- template ""))
+ template))
(defun semantic-grammar-header ()
"Return text of a generated standard header."
diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el
index 6a16845ecf2..35f09e7a784 100644
--- a/lisp/cedet/semantic/lex-spp.el
+++ b/lisp/cedet/semantic/lex-spp.el
@@ -434,8 +434,7 @@ continue processing recursively."
(symbolp (car (car val))))
(mapconcat (lambda (subtok)
(semantic-lex-spp-one-token-to-txt subtok))
- val
- ""))
+ val))
;; If val is nil, that's probably wrong.
;; Found a system header case where this was true.
((null val) "")
@@ -699,8 +698,7 @@ be merged recursively."
(message "Invalid merge macro encountered; \
will return empty string instead.")
"")))
- txt
- ""))
+ txt))
(defun semantic-lex-spp-find-closing-macro ()
"Find next macro which closes a scope through a close-paren.
diff --git a/lisp/cedet/srecode/find.el b/lisp/cedet/srecode/find.el
index cfd64edfc98..6d64a26e46c 100644
--- a/lisp/cedet/srecode/find.el
+++ b/lisp/cedet/srecode/find.el
@@ -34,12 +34,12 @@
(defun srecode-table (&optional mode)
"Return the currently active Semantic Recoder table for this buffer.
Optional argument MODE specifies the mode table to use."
- (let* ((modeq (or mode major-mode))
- (table (srecode-get-mode-table modeq)))
+ (let ((modes (derived-mode-all-parents (or mode major-mode)))
+ (table nil))
;; If there isn't one, keep searching backwards for a table.
- (while (and (not table) (setq modeq (get-mode-local-parent modeq)))
- (setq table (srecode-get-mode-table modeq)))
+ (while (and modes (not (setq table (srecode-get-mode-table (car modes)))))
+ (setq modes (cdr modes)))
;; Last ditch effort.
(when (not table)
@@ -57,35 +57,23 @@ Templates are found in the SRecode Template Map.
See `srecode-get-maps' for more.
APPNAME is the name of an application. In this case,
all template files for that application will be loaded."
- (let ((files
- (apply #'append
- (mapcar
- (if appname
+ (dolist (mmode (cons 'default (reverse (derived-mode-all-parents mmode))))
+ (let ((files
+ (apply #'append
+ (mapcar
+ (if appname
+ (lambda (map)
+ (srecode-map-entries-for-app-and-mode map appname
mmode))
(lambda (map)
- (srecode-map-entries-for-app-and-mode map appname mmode))
- (lambda (map)
- (srecode-map-entries-for-mode map mmode)))
- (srecode-get-maps))))
- )
- ;; Don't recurse if we are already the 'default state.
- (when (not (eq mmode 'default))
- ;; Are we a derived mode? If so, get the parent mode's
- ;; templates loaded too.
- (if (get-mode-local-parent mmode)
- (srecode-load-tables-for-mode (get-mode-local-parent mmode)
- appname)
- ;; No parent mode, all templates depend on the defaults being
- ;; loaded in, so get that in instead.
- (srecode-load-tables-for-mode 'default appname)))
+ (srecode-map-entries-for-mode map mmode)))
+ (srecode-get-maps)))))
- ;; Load in templates for our major mode.
- (dolist (f files)
- (let ((mt (srecode-get-mode-table mmode))
- )
- (when (or (not mt) (not (srecode-mode-table-find mt (car f))))
- (srecode-compile-file (car f)))
- ))
- ))
+ ;; Load in templates for our major mode.
+ (when files
+ (let ((mt (srecode-get-mode-table mmode)))
+ (dolist (f files)
+ (when (not (and mt (srecode-mode-table-find mt (car f))))
+ (srecode-compile-file (car f)))))))))
;;; PROJECT
;;
@@ -227,12 +215,12 @@ Optional argument MODE is the major mode to look for.
Optional argument HASH is the hash table to fill in.
Optional argument PREDICATE can be used to filter the returned
templates."
- (let* ((mhash (or hash (make-hash-table :test 'equal)))
- (mmode (or mode major-mode))
- (parent-mode (get-mode-local-parent mmode)))
- ;; Get the parent hash table filled into our current hash.
- (unless (eq mode 'default)
- (srecode-all-template-hash (or parent-mode 'default) mhash))
+ (let* ((mhash (or hash (make-hash-table :test 'equal))))
+ (dolist (mmode (cons 'default
+ ;; Get the parent hash table filled into our
+ ;; current hash.
+ (reverse (derived-mode-all-parents
+ (or mode major-mode)))))
;; Load up the hash table for our current mode.
(let* ((mt (srecode-get-mode-table mmode))
@@ -246,7 +234,7 @@ templates."
(funcall predicate temp))
(puthash key temp mhash)))
(oref tab namehash))))
- mhash)))
+ mhash))))
(defun srecode-calculate-default-template-string (hash)
"Calculate the name of the template to use as a DEFAULT.
diff --git a/lisp/cedet/srecode/map.el b/lisp/cedet/srecode/map.el
index 004bb7adddb..44e465c69b1 100644
--- a/lisp/cedet/srecode/map.el
+++ b/lisp/cedet/srecode/map.el
@@ -76,7 +76,7 @@ Each app keys to an alist of files and modes (as above.)")
"Return the entries in MAP for major MODE."
(let ((ans nil))
(dolist (f (oref map files))
- (when (mode-local-use-bindings-p mode (cdr f))
+ (when (provided-mode-derived-p mode (cdr f))
(setq ans (cons f ans))))
ans))
diff --git a/lisp/cedet/srecode/table.el b/lisp/cedet/srecode/table.el
index de151049f7f..e5ab53dd253 100644
--- a/lisp/cedet/srecode/table.el
+++ b/lisp/cedet/srecode/table.el
@@ -137,41 +137,36 @@ Tracks all the template-tables for a specific major
mode.")
"Get the SRecoder mode table for the major mode MODE.
This will find the mode table specific to MODE, and then
calculate all inherited templates from parent modes."
- (let ((table nil)
- (tmptable nil))
- (while mode
- (setq tmptable (eieio-instance-tracker-find
- mode 'major-mode 'srecode-mode-table-list)
- mode (get-mode-local-parent mode))
- (when tmptable
- (if (not table)
- (progn
- ;; If this is the first, update tables to have
- ;; all the mode specific tables in it.
- (setq table tmptable)
- (oset table tables (oref table modetables)))
- ;; If there already is a table, then reset the tables
- ;; slot to include all the tables belonging to this new child node.
- (oset table tables (append (oref table modetables)
- (oref tmptable modetables)))))
- )
+ (let ((table nil))
+ (dolist (mode (derived-mode-all-parents mode))
+ (let ((tmptable (eieio-instance-tracker-find
+ mode 'major-mode 'srecode-mode-table-list)))
+ (when tmptable
+ (if (not table)
+ (progn
+ ;; If this is the first, update tables to have
+ ;; all the mode specific tables in it.
+ (setq table tmptable)
+ (oset table tables (oref table modetables)))
+ ;; If there already is a table, then reset the tables
+ ;; slot to include all the tables belonging to this new child node.
+ (oset table tables (append (oref table modetables)
+ (oref tmptable modetables)))))
+ ))
table))
(defun srecode-make-mode-table (mode)
"Get the SRecoder mode table for the major mode MODE."
(let ((old (eieio-instance-tracker-find
mode 'major-mode 'srecode-mode-table-list)))
- (if old
- old
- (let* ((ms (if (stringp mode) mode (symbol-name mode)))
- (new (srecode-mode-table ms
- :major-mode mode
- :modetables nil
- :tables nil)))
- ;; Save this new mode table in that mode's variable.
- (eval `(setq-mode-local ,mode srecode-table ,new) t)
+ (or old
+ (let* ((new (srecode-mode-table :major-mode mode
+ :modetables nil
+ :tables nil)))
+ ;; Save this new mode table in that mode's variable.
+ (eval `(setq-mode-local ,mode srecode-table ,new) t)
- new))))
+ new))))
(cl-defmethod srecode-mode-table-find ((mt srecode-mode-table) file)
"Look in the mode table MT for a template table from FILE.
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 5346678dab0..56eb83e6f75 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1391,11 +1391,8 @@ See the full list and their hierarchy in
`cl--typeof-types'."
(defun cl--generic-derived-specializers (mode &rest _)
;; FIXME: Handle (derived-mode <mode1> ... <modeN>)
- (let ((specializers ()))
- (while mode
- (push `(derived-mode ,mode) specializers)
- (setq mode (get mode 'derived-mode-parent)))
- (nreverse specializers)))
+ (mapcar (lambda (mode) `(derived-mode ,mode))
+ (derived-mode-all-parents mode)))
(cl-generic-define-generalizer cl--generic-derived-generalizer
90 (lambda (name) `(and (symbolp ,name) (functionp ,name) ,name))
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/derived.el b/lisp/emacs-lisp/derived.el
index b35994364a7..dec5883767d 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -240,7 +240,9 @@ No problems result if this variable is not bound.
(unless (get ',abbrev 'variable-documentation)
(put ',abbrev 'variable-documentation
(purecopy ,(format "Abbrev table for `%s'." child))))))
- (put ',child 'derived-mode-parent ',parent)
+ (if (fboundp 'derived-mode-set-parent) ;; Emacs≥30.1
+ (derived-mode-set-parent ',child ',parent)
+ (put ',child 'derived-mode-parent ',parent))
,(if group `(put ',child 'custom-mode-group ,group))
(defun ,child ()
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/files.el b/lisp/files.el
index 3d838cd3b8c..d729bdf8c25 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -228,7 +228,7 @@ If non-nil, this directory is used instead of
`temporary-file-directory'
by programs that create small temporary files. This is for systems that
have fast storage with limited space, such as a RAM disk."
:group 'files
- :initialize 'custom-initialize-delay
+ :initialize #'custom-initialize-delay
:type '(choice (const nil) directory))
;; The system null device. (Should reference NULL_DEVICE from C.)
@@ -434,7 +434,7 @@ ignored."
,@(mapcar (lambda (algo)
(list 'const algo))
(secure-hash-algorithms)))))
- :initialize 'custom-initialize-delay
+ :initialize #'custom-initialize-delay
:version "21.1")
(defvar auto-save--timer nil "Timer for `auto-save-visited-mode'.")
@@ -1296,7 +1296,7 @@ Tip: You can use this expansion of remote identifier
components
(defcustom remote-shell-program (or (executable-find "ssh") "ssh")
"Program to use to execute commands on a remote host (i.e. ssh)."
:version "29.1"
- :initialize 'custom-initialize-delay
+ :initialize #'custom-initialize-delay
:group 'environment
:type 'file)
@@ -4585,12 +4585,7 @@ applied in order then that means the more specific modes
will
variables will override modes."
(let ((key (car node)))
(cond ((null key) -1)
- ((symbolp key)
- (let ((mode key)
- (depth 0))
- (while (setq mode (get mode 'derived-mode-parent))
- (setq depth (1+ depth)))
- depth))
+ ((symbolp key) (length (derived-mode-all-parents key)))
((stringp key)
(+ 1000 (length key)))
(t -2))))
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index e93c535bbef..e723d97cfc2 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -742,6 +742,7 @@ the C sources, too."
(defun help-fns--parent-mode (function)
;; If this is a derived mode, link to the parent.
(let ((parent-mode (and (symbolp function)
+ ;; FIXME: Should we mention other parent modes?
(get function
'derived-mode-parent))))
(when parent-mode
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el
index 37065f5d41a..70c7516f903 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -400,9 +400,9 @@ format. See `ibuffer-update-saved-filters-format' and
(error "This buffer is not in Ibuffer mode"))
(cond (ibuffer-auto-mode
(frame-or-buffer-changed-p 'ibuffer-auto-buffers-changed) ;
Initialize state vector
- (add-hook 'post-command-hook 'ibuffer-auto-update-changed))
+ (add-hook 'post-command-hook #'ibuffer-auto-update-changed))
(t
- (remove-hook 'post-command-hook 'ibuffer-auto-update-changed))))
+ (remove-hook 'post-command-hook #'ibuffer-auto-update-changed))))
(defun ibuffer-auto-update-changed ()
(when (frame-or-buffer-changed-p 'ibuffer-auto-buffers-changed)
@@ -557,7 +557,7 @@ See `ibuffer-do-view-and-eval' for that."
(list (read--expression "Eval in buffers (form): "))
:opstring "evaluated in"
:modifier-p :maybe)
- (eval form))
+ (eval form t))
;;;###autoload (autoload 'ibuffer-do-view-and-eval "ibuf-ext")
(define-ibuffer-op view-and-eval (form)
@@ -575,7 +575,7 @@ To evaluate a form without viewing the buffer, see
`ibuffer-do-eval'."
(unwind-protect
(progn
(switch-to-buffer buf)
- (eval form))
+ (eval form t))
(switch-to-buffer ibuffer-buf))))
;;;###autoload (autoload 'ibuffer-do-rename-uniquely "ibuf-ext")
@@ -1185,10 +1185,12 @@ Interactively, prompt for NAME, and use the current
filters."
(concat " [filter: " (cdr qualifier) "]"))
('or
(concat " [OR" (mapconcat #'ibuffer-format-qualifier
- (cdr qualifier) "") "]"))
+ (cdr qualifier))
+ "]"))
('and
(concat " [AND" (mapconcat #'ibuffer-format-qualifier
- (cdr qualifier) "") "]"))
+ (cdr qualifier))
+ "]"))
(_
(let ((type (assq (car qualifier) ibuffer-filtering-alist)))
(unless qualifier
@@ -1202,11 +1204,12 @@ Interactively, prompt for NAME, and use the current
filters."
If INCLUDE-PARENTS is non-nil then include parent modes."
(let ((modes))
(dolist (buf (buffer-list))
- (let ((this-mode (buffer-local-value 'major-mode buf)))
- (while (and this-mode (not (memq this-mode modes)))
- (push this-mode modes)
- (setq this-mode (and include-parents
- (get this-mode 'derived-mode-parent))))))
+ (let ((this-modes (derived-mode-all-parents
+ (buffer-local-value 'major-mode buf))))
+ (while (and this-modes (not (memq (car this-modes) modes)))
+ (push (car this-modes) modes)
+ (setq this-modes (and include-parents
+ (cdr this-modes))))))
(mapcar #'symbol-name modes)))
@@ -1391,7 +1394,7 @@ matches against the value of `default-directory' in that
buffer."
(:description "predicate"
:reader (read-minibuffer "Filter by predicate (form): "))
(with-current-buffer buf
- (eval qualifier)))
+ (eval qualifier t)))
;;;###autoload (autoload 'ibuffer-filter-chosen-by-completion "ibuf-ext")
(defun ibuffer-filter-chosen-by-completion ()
@@ -1508,7 +1511,7 @@ Ordering is lexicographic."
"Emulate `bs-show' from the bs.el package."
(interactive)
(ibuffer t "*Ibuffer-bs*" '((filename . ".*")) nil t)
- (define-key (current-local-map) "a" 'ibuffer-bs-toggle-all))
+ (define-key (current-local-map) "a" #'ibuffer-bs-toggle-all))
(defun ibuffer-bs-toggle-all ()
"Emulate `bs-toggle-show-all' from the bs.el package."
@@ -1746,7 +1749,7 @@ You can then feed the file name(s) to other commands with
\\[yank]."
(t (file-name-nondirectory name))))))
buffers))
(string
- (mapconcat 'identity (delete "" file-names) " ")))
+ (mapconcat #'identity (delete "" file-names) " ")))
(unless (string= string "")
(if (eq last-command 'kill-region)
(kill-append string nil)
diff --git a/lisp/info-look.el b/lisp/info-look.el
index eeb758e5b85..8653a292a16 100644
--- a/lisp/info-look.el
+++ b/lisp/info-look.el
@@ -53,13 +53,13 @@ Automatically becomes buffer local when set in any
fashion.")
(make-variable-buffer-local 'info-lookup-mode)
(defcustom info-lookup-other-window-flag t
- "Non-nil means pop up the Info buffer in another window."
- :group 'info-lookup :type 'boolean)
+ "Non-nil means pop up the Info buffer in another window."
+ :type 'boolean)
(defcustom info-lookup-highlight-face 'match
"Face for highlighting looked up help items.
Setting this variable to nil disables highlighting."
- :group 'info-lookup :type 'face)
+ :type 'face)
(defvar info-lookup-highlight-overlay nil
"Overlay object used for highlighting.")
@@ -73,7 +73,7 @@ List elements are cons cells of the form
If a file name matches REGEXP, then use help mode MODE instead of the
buffer's major mode."
- :group 'info-lookup :type '(repeat (cons (regexp :tag "Regexp")
+ :type '(repeat (cons (regexp :tag "Regexp")
(symbol :tag "Mode"))))
(defvar info-lookup-history nil
@@ -167,13 +167,13 @@ the value of `:mode' as HELP-MODE, etc..
If no topic or mode option has been specified, then the help topic defaults
to `symbol', and the help mode defaults to the current major mode."
- (apply 'info-lookup-add-help* nil arg))
+ (apply #'info-lookup-add-help* nil arg))
(defun info-lookup-maybe-add-help (&rest arg)
"Add a help specification if none is defined.
See the documentation of the function `info-lookup-add-help'
for more details."
- (apply 'info-lookup-add-help* t arg))
+ (apply #'info-lookup-add-help* t arg))
(defun info-lookup-add-help* (maybe &rest arg)
(let (topic mode regexp ignore-case doc-spec
@@ -349,18 +349,18 @@ If optional argument QUERY is non-nil, query for the help
mode."
(setq file-name-alist (cdr file-name-alist)))))
;; If major-mode has no setups in info-lookup-alist, under any topic, then
- ;; search up through derived-mode-parent to find a parent mode which does
- ;; have some setups. This means that a `define-derived-mode' with no
+ ;; search up through `derived-mode-all-parents' to find a parent mode which
+ ;; does have some setups. This means that a `define-derived-mode' with no
;; setups of its own will select its parent mode for lookups, if one of
;; its parents has some setups. Good for example on `makefile-gmake-mode'
;; and similar derivatives of `makefile-mode'.
;;
- (let ((mode major-mode)) ;; Look for `mode' with some setups.
- (while (and mode (not info-lookup-mode))
+ (let ((modes (derived-mode-all-parents major-mode))) ;; Look for `mode' with
some setups.
+ (while (and modes (not info-lookup-mode))
(dolist (topic-cell info-lookup-alist) ;; Usually only two topics here.
- (if (info-lookup->mode-value (car topic-cell) mode)
- (setq info-lookup-mode mode)))
- (setq mode (get mode 'derived-mode-parent))))
+ (if (info-lookup->mode-value (car topic-cell) (car modes))
+ (setq info-lookup-mode (car modes))))
+ (setq modes (cdr modes))))
(or info-lookup-mode (setq info-lookup-mode major-mode)))
@@ -526,7 +526,7 @@ different window."
(nconc (condition-case nil
(info-lookup-make-completions topic mode)
(error nil))
- (apply 'append
+ (apply #'append
(mapcar (lambda (arg)
(info-lookup->completions topic arg))
refer-modes))))
diff --git a/lisp/loadhist.el b/lisp/loadhist.el
index 3800ea70ea4..8a571661e89 100644
--- a/lisp/loadhist.el
+++ b/lisp/loadhist.el
@@ -149,14 +149,14 @@ documentation of `unload-feature' for details.")
(save-current-buffer
(dolist (buffer (buffer-list))
(set-buffer buffer)
- (let ((proposed major-mode))
+ (let ((proposed (derived-mode-all-parents major-mode)))
;; Look for a predecessor mode not defined in the feature we're
processing
- (while (and proposed (rassq proposed unload-function-defs-list))
- (setq proposed (get proposed 'derived-mode-parent)))
- (unless (eq proposed major-mode)
+ (while (and proposed (rassq (car proposed) unload-function-defs-list))
+ (setq proposed (cdr proposed)))
+ (unless (eq (car proposed) major-mode)
;; Two cases: either proposed is nil, and we want to switch to
fundamental
;; mode, or proposed is not nil and not major-mode, and so we use it.
- (funcall (or proposed 'fundamental-mode)))))))
+ (funcall (or (car proposed) 'fundamental-mode)))))))
(defvar loadhist-unload-filename nil)
diff --git a/lisp/locate.el b/lisp/locate.el
index 63386e18ebb..caccf644c02 100644
--- a/lisp/locate.el
+++ b/lisp/locate.el
@@ -141,13 +141,11 @@ system, or of all files that you have access to. Consult
the
documentation of that program for the details about how it determines
which file names match SEARCH-STRING. (Those details vary highly with
the version.)"
- :type 'string
- :group 'locate)
+ :type 'string)
(defcustom locate-post-command-hook nil
"List of hook functions run after `locate' (see `run-hooks')."
- :type 'hook
- :group 'locate)
+ :type 'hook)
(defvar locate-history-list nil
"The history list used by the \\[locate] command.")
@@ -162,13 +160,11 @@ This function should take one argument, a string (the
name to find)
and return a list of strings. The first element of the list should be
the name of a command to be executed by a shell, the remaining elements
should be the arguments to that command (including the name to find)."
- :type 'function
- :group 'locate)
+ :type 'function)
(defcustom locate-buffer-name "*Locate*"
"Name of the buffer to show results from the \\[locate] command."
- :type 'string
- :group 'locate)
+ :type 'string)
(defcustom locate-fcodes-file nil
"File name for the database of file names used by `locate'.
@@ -179,20 +175,17 @@ Just setting this variable does not actually change the
database
that `locate' searches. The executive program that the Emacs
function `locate' uses, as given by the variables `locate-command'
or `locate-make-command-line', determines the database."
- :type '(choice (const :tag "None" nil) file)
- :group 'locate)
+ :type '(choice (const :tag "None" nil) file))
(defcustom locate-header-face nil
"Face used to highlight the locate header."
- :type '(choice (const :tag "None" nil) face)
- :group 'locate)
+ :type '(choice (const :tag "None" nil) face))
;;;###autoload
(defcustom locate-ls-subdir-switches (purecopy "-al")
"`ls' switches for inserting subdirectories in `*Locate*' buffers.
This should contain the \"-l\" switch, but not the \"-F\" or \"-b\" switches."
:type 'string
- :group 'locate
:version "22.1")
(defcustom locate-update-when-revert nil
@@ -202,13 +195,11 @@ If non-nil, offer to update the locate database when
reverting that buffer.
option `locate-update-path'.)
If nil, reverting does not update the locate database."
:type 'boolean
- :group 'locate
:version "22.1")
(defcustom locate-update-command "updatedb"
"The executable program used to update the locate database."
- :type 'string
- :group 'locate)
+ :type 'string)
(defcustom locate-update-path "/"
"The default directory from where `locate-update-command' is called.
@@ -218,7 +209,6 @@ can be achieved by setting this option to \"/su::\" or
\"/sudo::\"
permissions are sufficient to run the command, you can set this
option to \"/\"."
:type 'string
- :group 'locate
:version "22.1")
(defcustom locate-prompt-for-command nil
@@ -227,13 +217,11 @@ Otherwise, that behavior is invoked via a prefix argument.
Setting this option non-nil actually inverts the meaning of a prefix arg;
that is, with a prefix arg, you get the default behavior."
- :group 'locate
:type 'boolean)
(defcustom locate-mode-hook nil
"List of hook functions run by `locate-mode' (see `run-mode-hooks')."
- :type 'hook
- :group 'locate)
+ :type 'hook)
;; Functions
@@ -371,17 +359,17 @@ except that FILTER is not optional."
(defvar locate-mode-map
(let ((map (copy-keymap dired-mode-map)))
;; Undefine Useless Dired Menu bars
- (define-key map [menu-bar Dired] 'undefined)
- (define-key map [menu-bar subdir] 'undefined)
- (define-key map [menu-bar mark executables] 'undefined)
- (define-key map [menu-bar mark directory] 'undefined)
- (define-key map [menu-bar mark directories] 'undefined)
- (define-key map [menu-bar mark symlinks] 'undefined)
- (define-key map [M-mouse-2] 'locate-mouse-view-file)
- (define-key map "\C-c\C-t" 'locate-tags)
- (define-key map "l" 'locate-do-redisplay)
- (define-key map "U" 'dired-unmark-all-files)
- (define-key map "V" 'locate-find-directory)
+ (define-key map [menu-bar Dired] #'undefined)
+ (define-key map [menu-bar subdir] #'undefined)
+ (define-key map [menu-bar mark executables] #'undefined)
+ (define-key map [menu-bar mark directory] #'undefined)
+ (define-key map [menu-bar mark directories] #'undefined)
+ (define-key map [menu-bar mark symlinks] #'undefined)
+ (define-key map [M-mouse-2] #'locate-mouse-view-file)
+ (define-key map "\C-c\C-t" #'locate-tags)
+ (define-key map "l" #'locate-do-redisplay)
+ (define-key map "U" #'dired-unmark-all-files)
+ (define-key map "V" #'locate-find-directory)
map)
"Local keymap for Locate mode buffers.")
@@ -486,7 +474,7 @@ do not work in subdirectories.
(setq-local revert-buffer-function #'locate-update)
(setq-local page-delimiter "\n\n"))
-(put 'locate-mode 'derived-mode-parent 'dired-mode)
+(derived-mode-add-parents 'locate-mode '(dired-mode special-mode))
(defun locate-do-setup (search-string)
(goto-char (point-min))
diff --git a/lisp/simple.el b/lisp/simple.el
index e73e37efcfa..de6eed3fe8f 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/so-long.el b/lisp/so-long.el
index b7cfce31173..e5f7b81e717 100644
--- a/lisp/so-long.el
+++ b/lisp/so-long.el
@@ -783,8 +783,7 @@ an example."
:package-version '(so-long . "1.0"))
(make-variable-buffer-local 'so-long-file-local-mode-function)
-;; `provided-mode-derived-p' was added in 26.1
-(unless (fboundp 'provided-mode-derived-p)
+(unless (fboundp 'provided-mode-derived-p) ;Only in Emacs≥26.1
(defun provided-mode-derived-p (mode &rest modes)
"Non-nil if MODE is derived from one of MODES.
Uses the `derived-mode-parent' property of the symbol to trace backwards.
diff --git a/lisp/subr.el b/lisp/subr.el
index dec935c3152..dcf49509177 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -2682,27 +2682,139 @@ 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), obeying their relative positions in each list.
+The order of the (sub)lists determines the final order in those cases where
+the order within the sublists does not impose a unique choice.
+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."
+ ;; Algorithm inspired from
+ ;; [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))))
+ (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)))
+ (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)
+ ;; But do try to return something meaningful.
+ (memq mode (reverse known-children)))
+ (t
+ ;; 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* ((new-children (cons mode known-children))
+ (get-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 new-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))))
+ (extras (get mode 'derived-mode-extra-parents))
+ (all-parents
+ (merge-ordered-lists
+ (cons (if (and parent (not (memq parent extras)))
+ (funcall get-all-parents parent))
+ (mapcar get-all-parents extras)))))
+ ;; Cache the result unless it was affected by `known-children'
+ ;; because of a cycle.
+ (if (and (memq mode all-parents) known-children)
+ (cons mode (remq mode all-parents))
+ (put mode 'derived-mode--all-parents (cons mode all-parents))))))))
+
(defun provided-mode-derived-p (mode &rest modes)
"Non-nil if MODE is derived from one of MODES.
-Uses the `derived-mode-parent' property of the symbol to trace backwards.
If you just want to check `major-mode', use `derived-mode-p'."
(declare (side-effect-free t))
- (while
- (and
- (not (memq mode modes))
- (let* ((parent (get mode 'derived-mode-parent)))
- (setq mode (or parent
- ;; If MODE is an alias, then follow the alias.
- (let ((alias (symbol-function mode)))
- (and (symbolp alias) alias)))))))
- mode)
+ (let ((ps (derived-mode-all-parents mode)))
+ (while (and modes (not (memq (car modes) ps)))
+ (setq modes (cdr modes)))
+ (car modes)))
(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))
+(defun derived-mode-set-parent (mode parent)
+ "Declare PARENT to be the parent of MODE."
+ (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)))
+ (when followers ;; Common case.
+ (put mode 'derived-mode--followers nil)
+ (mapc #'derived-mode--flush followers))))
+
(defvar-local major-mode--suspended nil)
(put 'major-mode--suspended 'permanent-local t)
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index db327056533..f485328aa7a 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -345,8 +345,7 @@
;;;; Mode hooks.
-(defalias 'subr-tests--parent-mode
- (if (fboundp 'prog-mode) 'prog-mode 'fundamental-mode))
+(defalias 'subr-tests--parent-mode #'prog-mode)
(define-derived-mode subr-tests--derived-mode-1 prog-mode "test")
(define-derived-mode subr-tests--derived-mode-2 subr-tests--parent-mode "test")
@@ -360,6 +359,41 @@
'subr-tests--parent-mode))
(should (provided-mode-derived-p 'subr-tests--derived-mode-2 'prog-mode)))
+
+(define-derived-mode subr-tests--mode-A subr-tests--derived-mode-1 "t")
+(define-derived-mode subr-tests--mode-B subr-tests--mode-A "t")
+(defalias 'subr-tests--mode-C #'subr-tests--mode-B)
+(derived-mode-add-parents 'subr-tests--mode-A '(subr-tests--mode-C))
+
+(ert-deftest subr-tests--derived-mode-add-parents ()
+ ;; The Right Answer is somewhat unclear in the presence of cycles,
+ ;; but let's make sure we get tolerable answers.
+ ;; FIXME: Currently `prog-mode' doesn't always end up at the end :-(
+ (let ((set-equal (lambda (a b)
+ (not (or (cl-set-difference a b)
+ (cl-set-difference b a))))))
+ (dolist (mode '(subr-tests--mode-A subr-tests--mode-B subr-tests--mode-C))
+ (should (eq (derived-mode-all-parents mode)
+ (derived-mode-all-parents mode)))
+ (should (eq mode (car (derived-mode-all-parents mode))))
+ (should (funcall set-equal
+ (derived-mode-all-parents mode)
+ '(subr-tests--mode-A subr-tests--mode-B prog-mode
+ subr-tests--mode-C subr-tests--derived-mode-1))))))
+
+(ert-deftest subr-tests--merge-ordered-lists ()
+ (should (equal (merge-ordered-lists
+ '((B A) (C A) (D B) (E D C))
+ (lambda (_) (error "cycle")))
+ '(E D B C A)))
+ (should (equal (merge-ordered-lists
+ '((E D C) (B A) (C A) (D B))
+ (lambda (_) (error "cycle")))
+ '(E D C B A)))
+ (should-error (merge-ordered-lists
+ '((E C D) (B A) (A C) (D B))
+ (lambda (_) (error "cycle")))))
+
(ert-deftest number-sequence-test ()
(should (= (length
(number-sequence (1- most-positive-fixnum) most-positive-fixnum))