1
0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-28 07:45:00 +00:00

Merge branch 'derived-mode-add-parents'

This commit is contained in:
Stefan Monnier 2023-11-16 09:57:38 -05:00
commit 4194f9bd87
24 changed files with 356 additions and 288 deletions

View File

@ -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}. derived from any of the major modes given by the symbols @var{modes}.
@end defun @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 @node Basic Major Modes
@subsection Basic Major Modes @subsection Basic Major Modes

View File

@ -1196,6 +1196,18 @@ values.
* Lisp Changes in Emacs 30.1 * 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. ** 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 It is now possible for drag-and-drop handler functions to respond to

View File

@ -68,22 +68,15 @@ walk through. It defaults to `buffer-list'."
(when (or (not predicate) (funcall predicate)) (when (or (not predicate) (funcall predicate))
(funcall function)))))) (funcall function))))))
(defsubst get-mode-local-parent (mode) (defun get-mode-local-parent (mode)
"Return the mode parent of the major mode MODE. "Return the mode parent of the major mode MODE.
Return nil if MODE has no parent." Return nil if MODE has no parent."
(declare (obsolete derived-mode-all-parents "30.1"))
(or (get mode 'mode-local-parent) (or (get mode 'mode-local-parent)
(get mode 'derived-mode-parent))) (get mode 'derived-mode-parent)))
;; FIXME doc (and function name) seems wrong. (define-obsolete-function-alias 'mode-local-equivalent-mode-p
;; Return a list of MODE and all its parent modes, if any. #'derived-mode-all-parents "30.1")
;; 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))
(defun mode-local-map-mode-buffers (function modes) (defun mode-local-map-mode-buffers (function modes)
"Run FUNCTION on every file buffer with major mode in 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." FUNCTION does not have arguments."
(setq modes (ensure-list modes)) (setq modes (ensure-list modes))
(mode-local-map-file-buffers (mode-local-map-file-buffers
function (lambda () function (lambda () (apply #'derived-mode-p modes))))
(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))))
;;; Hook machinery ;;; Hook machinery
;; ;;
@ -145,7 +132,8 @@ after changing the major mode."
"Set parent of major mode MODE to PARENT mode. "Set parent of major mode MODE to PARENT mode.
To work properly, this function should be called after PARENT mode To work properly, this function should be called after PARENT mode
local variables have been defined." 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 ;; Refresh mode bindings to get mode local variables inherited from
;; PARENT. To work properly, the following should be called after ;; PARENT. To work properly, the following should be called after
;; PARENT mode local variables have been defined. ;; PARENT mode local variables have been defined.
@ -159,13 +147,8 @@ definition."
(declare (obsolete define-derived-mode "27.1") (indent 2)) (declare (obsolete define-derived-mode "27.1") (indent 2))
`(mode-local--set-parent ',mode ',parent)) `(mode-local--set-parent ',mode ',parent))
(defun mode-local-use-bindings-p (this-mode desired-mode) (define-obsolete-function-alias 'mode-local-use-bindings-p
"Return non-nil if THIS-MODE can use bindings of DESIRED-MODE." #'provided-mode-derived-p "30.1")
(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))
;;; Core bindings API ;;; Core bindings API
@ -270,11 +253,13 @@ its parents."
(setq mode major-mode (setq mode major-mode
bind (and mode-local-symbol-table bind (and mode-local-symbol-table
(intern-soft name mode-local-symbol-table)))) (intern-soft name mode-local-symbol-table))))
(while (and mode (not bind)) (let ((parents (derived-mode-all-parents mode)))
(or (and (get mode 'mode-local-symbol-table) (while (and parents (not bind))
(setq bind (intern-soft (or (and (get (car parents) 'mode-local-symbol-table)
name (get mode 'mode-local-symbol-table)))) (setq bind (intern-soft
(setq mode (get-mode-local-parent mode)))) name (get (car parents)
'mode-local-symbol-table))))
(setq parents (cdr parents)))))
bind)) bind))
(defsubst mode-local-symbol-value (symbol &optional mode property) (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) (mode-local-on-major-mode-change)
;; Do the normal thing. ;; Do the normal thing.
(let (modes table old-locals) (let (table old-locals)
(unless mode (unless mode
(setq-local mode-local--init-mode major-mode) (setq-local mode-local--init-mode major-mode)
(setq 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. ;; 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)) (when (setq table (get mode 'mode-local-symbol-table))
(mapatoms (mapatoms
(lambda (var) (lambda (var)
@ -345,14 +326,13 @@ If MODE is not specified it defaults to current `major-mode'."
(kill-local-variable 'mode-local--init-mode) (kill-local-variable 'mode-local--init-mode)
(setq mode major-mode)) (setq mode major-mode))
(let (table) (let (table)
(while mode (dolist (mode (derived-mode-all-parents mode))
(when (setq table (get mode 'mode-local-symbol-table)) (when (setq table (get mode 'mode-local-symbol-table))
(mapatoms (mapatoms
(lambda (var) (lambda (var)
(when (get var 'mode-variable-flag) (when (get var 'mode-variable-flag)
(kill-local-variable (intern (symbol-name var))))) (kill-local-variable (intern (symbol-name var)))))
table)) table)))))
(setq mode (get-mode-local-parent mode)))))
(defmacro with-mode-local-symbol (mode &rest body) (defmacro with-mode-local-symbol (mode &rest body)
"With the local bindings of MODE symbol, evaluate 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 (when table
(princ "\n- Buffer local\n") (princ "\n- Buffer local\n")
(mode-local-print-bindings table)) (mode-local-print-bindings table))
(while mode (dolist (mode (derived-mode-all-parents mode))
(setq table (get mode 'mode-local-symbol-table)) (setq table (get mode 'mode-local-symbol-table))
(when table (when table
(princ (format-message "\n- From `%s'\n" mode)) (princ (format-message "\n- From `%s'\n" mode))
(mode-local-print-bindings table)) (mode-local-print-bindings table)))))
(setq mode (get-mode-local-parent mode)))))
(defun mode-local-describe-bindings-1 (buffer-or-mode &optional interactive-p) (defun mode-local-describe-bindings-1 (buffer-or-mode &optional interactive-p)
"Display mode local bindings active in BUFFER-OR-MODE. "Display mode local bindings active in BUFFER-OR-MODE.

View File

@ -799,7 +799,7 @@ local variable."
(null (oref table major-mode)) (null (oref table major-mode))
;; nil means the same as major-mode ;; nil means the same as major-mode
(and (not semantic-equivalent-major-modes) (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 (and semantic-equivalent-major-modes
(member (oref table major-mode) semantic-equivalent-major-modes)) (member (oref table major-mode) semantic-equivalent-major-modes))
) )

View File

@ -644,7 +644,7 @@ The symbols in the list are local variables in
(cond (cond
(x (cdr x)) (x (cdr x))
((symbolp S) (symbol-value S)))))) ((symbolp S) (symbol-value S))))))
template "")) template))
(defun semantic-grammar-header () (defun semantic-grammar-header ()
"Return text of a generated standard header." "Return text of a generated standard header."

View File

@ -434,8 +434,7 @@ continue processing recursively."
(symbolp (car (car val)))) (symbolp (car (car val))))
(mapconcat (lambda (subtok) (mapconcat (lambda (subtok)
(semantic-lex-spp-one-token-to-txt subtok)) (semantic-lex-spp-one-token-to-txt subtok))
val val))
""))
;; If val is nil, that's probably wrong. ;; If val is nil, that's probably wrong.
;; Found a system header case where this was true. ;; Found a system header case where this was true.
((null val) "") ((null val) "")
@ -699,8 +698,7 @@ be merged recursively."
(message "Invalid merge macro encountered; \ (message "Invalid merge macro encountered; \
will return empty string instead.") will return empty string instead.")
""))) "")))
txt txt))
""))
(defun semantic-lex-spp-find-closing-macro () (defun semantic-lex-spp-find-closing-macro ()
"Find next macro which closes a scope through a close-paren. "Find next macro which closes a scope through a close-paren.

View File

@ -34,12 +34,12 @@
(defun srecode-table (&optional mode) (defun srecode-table (&optional mode)
"Return the currently active Semantic Recoder table for this buffer. "Return the currently active Semantic Recoder table for this buffer.
Optional argument MODE specifies the mode table to use." Optional argument MODE specifies the mode table to use."
(let* ((modeq (or mode major-mode)) (let ((modes (derived-mode-all-parents (or mode major-mode)))
(table (srecode-get-mode-table modeq))) (table nil))
;; If there isn't one, keep searching backwards for a table. ;; If there isn't one, keep searching backwards for a table.
(while (and (not table) (setq modeq (get-mode-local-parent modeq))) (while (and modes (not (setq table (srecode-get-mode-table (car modes)))))
(setq table (srecode-get-mode-table modeq))) (setq modes (cdr modes)))
;; Last ditch effort. ;; Last ditch effort.
(when (not table) (when (not table)
@ -57,35 +57,23 @@ Templates are found in the SRecode Template Map.
See `srecode-get-maps' for more. See `srecode-get-maps' for more.
APPNAME is the name of an application. In this case, APPNAME is the name of an application. In this case,
all template files for that application will be loaded." all template files for that application will be loaded."
(let ((files (dolist (mmode (cons 'default (reverse (derived-mode-all-parents mmode))))
(apply #'append (let ((files
(mapcar (apply #'append
(if appname (mapcar
(if appname
(lambda (map)
(srecode-map-entries-for-app-and-mode map appname mmode))
(lambda (map) (lambda (map)
(srecode-map-entries-for-app-and-mode map appname mmode)) (srecode-map-entries-for-mode map mmode)))
(lambda (map) (srecode-get-maps)))))
(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)))
;; Load in templates for our major mode. ;; Load in templates for our major mode.
(dolist (f files) (when files
(let ((mt (srecode-get-mode-table mmode)) (let ((mt (srecode-get-mode-table mmode)))
) (dolist (f files)
(when (or (not mt) (not (srecode-mode-table-find mt (car f)))) (when (not (and mt (srecode-mode-table-find mt (car f))))
(srecode-compile-file (car f))) (srecode-compile-file (car f)))))))))
))
))
;;; PROJECT ;;; 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 HASH is the hash table to fill in.
Optional argument PREDICATE can be used to filter the returned Optional argument PREDICATE can be used to filter the returned
templates." templates."
(let* ((mhash (or hash (make-hash-table :test 'equal))) (let* ((mhash (or hash (make-hash-table :test 'equal))))
(mmode (or mode major-mode)) (dolist (mmode (cons 'default
(parent-mode (get-mode-local-parent mmode))) ;; Get the parent hash table filled into our
;; Get the parent hash table filled into our current hash. ;; current hash.
(unless (eq mode 'default) (reverse (derived-mode-all-parents
(srecode-all-template-hash (or parent-mode 'default) mhash)) (or mode major-mode)))))
;; Load up the hash table for our current mode. ;; Load up the hash table for our current mode.
(let* ((mt (srecode-get-mode-table mmode)) (let* ((mt (srecode-get-mode-table mmode))
@ -246,7 +234,7 @@ templates."
(funcall predicate temp)) (funcall predicate temp))
(puthash key temp mhash))) (puthash key temp mhash)))
(oref tab namehash)))) (oref tab namehash))))
mhash))) mhash))))
(defun srecode-calculate-default-template-string (hash) (defun srecode-calculate-default-template-string (hash)
"Calculate the name of the template to use as a DEFAULT. "Calculate the name of the template to use as a DEFAULT.

View File

@ -76,7 +76,7 @@ Each app keys to an alist of files and modes (as above.)")
"Return the entries in MAP for major MODE." "Return the entries in MAP for major MODE."
(let ((ans nil)) (let ((ans nil))
(dolist (f (oref map files)) (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)))) (setq ans (cons f ans))))
ans)) ans))

View File

@ -137,41 +137,36 @@ Tracks all the template-tables for a specific major mode.")
"Get the SRecoder mode table for the major mode MODE. "Get the SRecoder mode table for the major mode MODE.
This will find the mode table specific to MODE, and then This will find the mode table specific to MODE, and then
calculate all inherited templates from parent modes." calculate all inherited templates from parent modes."
(let ((table nil) (let ((table nil))
(tmptable nil)) (dolist (mode (derived-mode-all-parents mode))
(while mode (let ((tmptable (eieio-instance-tracker-find
(setq tmptable (eieio-instance-tracker-find mode 'major-mode 'srecode-mode-table-list)))
mode 'major-mode 'srecode-mode-table-list) (when tmptable
mode (get-mode-local-parent mode)) (if (not table)
(when tmptable (progn
(if (not table) ;; If this is the first, update tables to have
(progn ;; all the mode specific tables in it.
;; If this is the first, update tables to have (setq table tmptable)
;; all the mode specific tables in it. (oset table tables (oref table modetables)))
(setq table tmptable) ;; If there already is a table, then reset the tables
(oset table tables (oref table modetables))) ;; slot to include all the tables belonging to this new child node.
;; If there already is a table, then reset the tables (oset table tables (append (oref table modetables)
;; slot to include all the tables belonging to this new child node. (oref tmptable modetables)))))
(oset table tables (append (oref table modetables) ))
(oref tmptable modetables)))))
)
table)) table))
(defun srecode-make-mode-table (mode) (defun srecode-make-mode-table (mode)
"Get the SRecoder mode table for the major mode MODE." "Get the SRecoder mode table for the major mode MODE."
(let ((old (eieio-instance-tracker-find (let ((old (eieio-instance-tracker-find
mode 'major-mode 'srecode-mode-table-list))) mode 'major-mode 'srecode-mode-table-list)))
(if old (or old
old (let* ((new (srecode-mode-table :major-mode mode
(let* ((ms (if (stringp mode) mode (symbol-name mode))) :modetables nil
(new (srecode-mode-table ms :tables nil)))
:major-mode mode ;; Save this new mode table in that mode's variable.
:modetables nil (eval `(setq-mode-local ,mode srecode-table ,new) t)
: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) (cl-defmethod srecode-mode-table-find ((mt srecode-mode-table) file)
"Look in the mode table MT for a template table from FILE. "Look in the mode table MT for a template table from FILE.

View File

@ -1391,11 +1391,8 @@ See the full list and their hierarchy in `cl--typeof-types'."
(defun cl--generic-derived-specializers (mode &rest _) (defun cl--generic-derived-specializers (mode &rest _)
;; FIXME: Handle (derived-mode <mode1> ... <modeN>) ;; FIXME: Handle (derived-mode <mode1> ... <modeN>)
(let ((specializers ())) (mapcar (lambda (mode) `(derived-mode ,mode))
(while mode (derived-mode-all-parents mode)))
(push `(derived-mode ,mode) specializers)
(setq mode (get mode 'derived-mode-parent)))
(nreverse specializers)))
(cl-generic-define-generalizer cl--generic-derived-generalizer (cl-generic-define-generalizer cl--generic-derived-generalizer
90 (lambda (name) `(and (symbolp ,name) (functionp ,name) ,name)) 90 (lambda (name) `(and (symbolp ,name) (functionp ,name) ,name))

View File

@ -3337,19 +3337,6 @@ To see the documentation for a defined struct type, use
;;; Add cl-struct support to pcase ;;; 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 ;;;###autoload
(pcase-defmacro cl-struct (type &rest fields) (pcase-defmacro cl-struct (type &rest fields)
"Pcase patterns that match cl-struct EXPVAL of type TYPE. "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)) (let ((c1 (cl--find-class t1))
(c2 (cl--find-class t2))) (c2 (cl--find-class t2)))
(and c1 c2 (and c1 c2
(not (or (memq c1 (cl--struct-all-parents c2)) (not (or (memq t1 (cl--class-allparents c2))
(memq c2 (cl--struct-all-parents c1))))))) (memq t2 (cl--class-allparents c1)))))))
(let ((c1 (and (symbolp t1) (cl--find-class t1)))) (let ((c1 (and (symbolp t1) (cl--find-class t1))))
(and c1 (cl--struct-class-p c1) (and c1 (cl--struct-class-p c1)
(funcall orig (cl--defstruct-predicate t1) (funcall orig (cl--defstruct-predicate t1)

View File

@ -323,15 +323,9 @@ supertypes from the most specific to least specific.")
(cl-assert (cl--class-p (cl--find-class 'cl-structure-object))) (cl-assert (cl--class-p (cl--find-class 'cl-structure-object)))
(defun cl--class-allparents (class) (defun cl--class-allparents (class)
(let ((parents ()) (cons (cl--class-name class)
(classes (list class))) (merge-ordered-lists (mapcar #'cl--class-allparents
;; BFS precedence. FIXME: Use a topological sort. (cl--class-parents class)))))
(while (let ((class (pop classes)))
(cl-pushnew (cl--class-name class) parents)
(setq classes
(append classes
(cl--class-parents class)))))
(nreverse parents)))
(eval-and-compile (eval-and-compile
(cl-assert (null (cl--class-parents (cl--find-class 'cl-structure-object))))) (cl-assert (null (cl--class-parents (cl--find-class 'cl-structure-object)))))

View File

@ -240,7 +240,9 @@ No problems result if this variable is not bound.
(unless (get ',abbrev 'variable-documentation) (unless (get ',abbrev 'variable-documentation)
(put ',abbrev 'variable-documentation (put ',abbrev 'variable-documentation
(purecopy ,(format "Abbrev table for `%s'." child)))))) (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)) ,(if group `(put ',child 'custom-mode-group ,group))
(defun ,child () (defun ,child ()

View File

@ -964,49 +964,6 @@ need be... May remove that later...)"
(cdr tuple) (cdr tuple)
nil))) 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) (defsubst eieio--class/struct-parents (class)
(or (eieio--class-parents class) (or (eieio--class-parents class)
`(,eieio-default-superclass))) `(,eieio-default-superclass)))
@ -1014,14 +971,16 @@ If a consistent order does not exist, signal an error."
(defun eieio--class-precedence-c3 (class) (defun eieio--class-precedence-c3 (class)
"Return all parents of CLASS in c3 order." "Return all parents of CLASS in c3 order."
(let ((parents (eieio--class-parents class))) (let ((parents (eieio--class-parents class)))
(eieio--c3-merge-lists (cons class
(list class) (merge-ordered-lists
(append (append
(or (or
(mapcar #'eieio--class-precedence-c3 parents) (mapcar #'eieio--class-precedence-c3 parents)
`((,eieio-default-superclass))) `((,eieio-default-superclass)))
(list parents)))) (list parents))
) (lambda (remaining-inputs)
(signal 'inconsistent-class-hierarchy
(list remaining-inputs)))))))
;;; ;;;
;; Method Invocation Order: Depth First ;; Method Invocation Order: Depth First

View File

@ -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 by programs that create small temporary files. This is for systems that
have fast storage with limited space, such as a RAM disk." have fast storage with limited space, such as a RAM disk."
:group 'files :group 'files
:initialize 'custom-initialize-delay :initialize #'custom-initialize-delay
:type '(choice (const nil) directory)) :type '(choice (const nil) directory))
;; The system null device. (Should reference NULL_DEVICE from C.) ;; The system null device. (Should reference NULL_DEVICE from C.)
@ -434,7 +434,7 @@ ignored."
,@(mapcar (lambda (algo) ,@(mapcar (lambda (algo)
(list 'const algo)) (list 'const algo))
(secure-hash-algorithms))))) (secure-hash-algorithms)))))
:initialize 'custom-initialize-delay :initialize #'custom-initialize-delay
:version "21.1") :version "21.1")
(defvar auto-save--timer nil "Timer for `auto-save-visited-mode'.") (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") (defcustom remote-shell-program (or (executable-find "ssh") "ssh")
"Program to use to execute commands on a remote host (i.e. ssh)." "Program to use to execute commands on a remote host (i.e. ssh)."
:version "29.1" :version "29.1"
:initialize 'custom-initialize-delay :initialize #'custom-initialize-delay
:group 'environment :group 'environment
:type 'file) :type 'file)
@ -4585,12 +4585,7 @@ applied in order then that means the more specific modes will
variables will override modes." variables will override modes."
(let ((key (car node))) (let ((key (car node)))
(cond ((null key) -1) (cond ((null key) -1)
((symbolp key) ((symbolp key) (length (derived-mode-all-parents key)))
(let ((mode key)
(depth 0))
(while (setq mode (get mode 'derived-mode-parent))
(setq depth (1+ depth)))
depth))
((stringp key) ((stringp key)
(+ 1000 (length key))) (+ 1000 (length key)))
(t -2)))) (t -2))))

View File

@ -742,6 +742,7 @@ the C sources, too."
(defun help-fns--parent-mode (function) (defun help-fns--parent-mode (function)
;; If this is a derived mode, link to the parent. ;; If this is a derived mode, link to the parent.
(let ((parent-mode (and (symbolp function) (let ((parent-mode (and (symbolp function)
;; FIXME: Should we mention other parent modes?
(get function (get function
'derived-mode-parent)))) 'derived-mode-parent))))
(when parent-mode (when parent-mode

View File

@ -400,9 +400,9 @@ format. See `ibuffer-update-saved-filters-format' and
(error "This buffer is not in Ibuffer mode")) (error "This buffer is not in Ibuffer mode"))
(cond (ibuffer-auto-mode (cond (ibuffer-auto-mode
(frame-or-buffer-changed-p 'ibuffer-auto-buffers-changed) ; Initialize state vector (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 (t
(remove-hook 'post-command-hook 'ibuffer-auto-update-changed)))) (remove-hook 'post-command-hook #'ibuffer-auto-update-changed))))
(defun ibuffer-auto-update-changed () (defun ibuffer-auto-update-changed ()
(when (frame-or-buffer-changed-p 'ibuffer-auto-buffers-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): ")) (list (read--expression "Eval in buffers (form): "))
:opstring "evaluated in" :opstring "evaluated in"
:modifier-p :maybe) :modifier-p :maybe)
(eval form)) (eval form t))
;;;###autoload (autoload 'ibuffer-do-view-and-eval "ibuf-ext") ;;;###autoload (autoload 'ibuffer-do-view-and-eval "ibuf-ext")
(define-ibuffer-op view-and-eval (form) (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 (unwind-protect
(progn (progn
(switch-to-buffer buf) (switch-to-buffer buf)
(eval form)) (eval form t))
(switch-to-buffer ibuffer-buf)))) (switch-to-buffer ibuffer-buf))))
;;;###autoload (autoload 'ibuffer-do-rename-uniquely "ibuf-ext") ;;;###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) "]")) (concat " [filter: " (cdr qualifier) "]"))
('or ('or
(concat " [OR" (mapconcat #'ibuffer-format-qualifier (concat " [OR" (mapconcat #'ibuffer-format-qualifier
(cdr qualifier) "") "]")) (cdr qualifier))
"]"))
('and ('and
(concat " [AND" (mapconcat #'ibuffer-format-qualifier (concat " [AND" (mapconcat #'ibuffer-format-qualifier
(cdr qualifier) "") "]")) (cdr qualifier))
"]"))
(_ (_
(let ((type (assq (car qualifier) ibuffer-filtering-alist))) (let ((type (assq (car qualifier) ibuffer-filtering-alist)))
(unless qualifier (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." If INCLUDE-PARENTS is non-nil then include parent modes."
(let ((modes)) (let ((modes))
(dolist (buf (buffer-list)) (dolist (buf (buffer-list))
(let ((this-mode (buffer-local-value 'major-mode buf))) (let ((this-modes (derived-mode-all-parents
(while (and this-mode (not (memq this-mode modes))) (buffer-local-value 'major-mode buf))))
(push this-mode modes) (while (and this-modes (not (memq (car this-modes) modes)))
(setq this-mode (and include-parents (push (car this-modes) modes)
(get this-mode 'derived-mode-parent)))))) (setq this-modes (and include-parents
(cdr this-modes))))))
(mapcar #'symbol-name modes))) (mapcar #'symbol-name modes)))
@ -1391,7 +1394,7 @@ matches against the value of `default-directory' in that buffer."
(:description "predicate" (:description "predicate"
:reader (read-minibuffer "Filter by predicate (form): ")) :reader (read-minibuffer "Filter by predicate (form): "))
(with-current-buffer buf (with-current-buffer buf
(eval qualifier))) (eval qualifier t)))
;;;###autoload (autoload 'ibuffer-filter-chosen-by-completion "ibuf-ext") ;;;###autoload (autoload 'ibuffer-filter-chosen-by-completion "ibuf-ext")
(defun ibuffer-filter-chosen-by-completion () (defun ibuffer-filter-chosen-by-completion ()
@ -1508,7 +1511,7 @@ Ordering is lexicographic."
"Emulate `bs-show' from the bs.el package." "Emulate `bs-show' from the bs.el package."
(interactive) (interactive)
(ibuffer t "*Ibuffer-bs*" '((filename . ".*")) nil t) (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 () (defun ibuffer-bs-toggle-all ()
"Emulate `bs-toggle-show-all' from the bs.el package." "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)))))) (t (file-name-nondirectory name))))))
buffers)) buffers))
(string (string
(mapconcat 'identity (delete "" file-names) " "))) (mapconcat #'identity (delete "" file-names) " ")))
(unless (string= string "") (unless (string= string "")
(if (eq last-command 'kill-region) (if (eq last-command 'kill-region)
(kill-append string nil) (kill-append string nil)

View File

@ -53,13 +53,13 @@ Automatically becomes buffer local when set in any fashion.")
(make-variable-buffer-local 'info-lookup-mode) (make-variable-buffer-local 'info-lookup-mode)
(defcustom info-lookup-other-window-flag t (defcustom info-lookup-other-window-flag t
"Non-nil means pop up the Info buffer in another window." "Non-nil means pop up the Info buffer in another window."
:group 'info-lookup :type 'boolean) :type 'boolean)
(defcustom info-lookup-highlight-face 'match (defcustom info-lookup-highlight-face 'match
"Face for highlighting looked up help items. "Face for highlighting looked up help items.
Setting this variable to nil disables highlighting." Setting this variable to nil disables highlighting."
:group 'info-lookup :type 'face) :type 'face)
(defvar info-lookup-highlight-overlay nil (defvar info-lookup-highlight-overlay nil
"Overlay object used for highlighting.") "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 If a file name matches REGEXP, then use help mode MODE instead of the
buffer's major mode." buffer's major mode."
:group 'info-lookup :type '(repeat (cons (regexp :tag "Regexp") :type '(repeat (cons (regexp :tag "Regexp")
(symbol :tag "Mode")))) (symbol :tag "Mode"))))
(defvar info-lookup-history nil (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 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." 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) (defun info-lookup-maybe-add-help (&rest arg)
"Add a help specification if none is defined. "Add a help specification if none is defined.
See the documentation of the function `info-lookup-add-help' See the documentation of the function `info-lookup-add-help'
for more details." 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) (defun info-lookup-add-help* (maybe &rest arg)
(let (topic mode regexp ignore-case doc-spec (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))))) (setq file-name-alist (cdr file-name-alist)))))
;; If major-mode has no setups in info-lookup-alist, under any topic, then ;; 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 ;; search up through `derived-mode-all-parents' to find a parent mode which
;; have some setups. This means that a `define-derived-mode' with no ;; 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 ;; 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' ;; its parents has some setups. Good for example on `makefile-gmake-mode'
;; and similar derivatives of `makefile-mode'. ;; and similar derivatives of `makefile-mode'.
;; ;;
(let ((mode major-mode)) ;; Look for `mode' with some setups. (let ((modes (derived-mode-all-parents major-mode))) ;; Look for `mode' with some setups.
(while (and mode (not info-lookup-mode)) (while (and modes (not info-lookup-mode))
(dolist (topic-cell info-lookup-alist) ;; Usually only two topics here. (dolist (topic-cell info-lookup-alist) ;; Usually only two topics here.
(if (info-lookup->mode-value (car topic-cell) mode) (if (info-lookup->mode-value (car topic-cell) (car modes))
(setq info-lookup-mode mode))) (setq info-lookup-mode (car modes))))
(setq mode (get mode 'derived-mode-parent)))) (setq modes (cdr modes))))
(or info-lookup-mode (setq info-lookup-mode major-mode))) (or info-lookup-mode (setq info-lookup-mode major-mode)))
@ -526,7 +526,7 @@ different window."
(nconc (condition-case nil (nconc (condition-case nil
(info-lookup-make-completions topic mode) (info-lookup-make-completions topic mode)
(error nil)) (error nil))
(apply 'append (apply #'append
(mapcar (lambda (arg) (mapcar (lambda (arg)
(info-lookup->completions topic arg)) (info-lookup->completions topic arg))
refer-modes)))) refer-modes))))

View File

@ -149,14 +149,14 @@ documentation of `unload-feature' for details.")
(save-current-buffer (save-current-buffer
(dolist (buffer (buffer-list)) (dolist (buffer (buffer-list))
(set-buffer buffer) (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 ;; Look for a predecessor mode not defined in the feature we're processing
(while (and proposed (rassq proposed unload-function-defs-list)) (while (and proposed (rassq (car proposed) unload-function-defs-list))
(setq proposed (get proposed 'derived-mode-parent))) (setq proposed (cdr proposed)))
(unless (eq proposed major-mode) (unless (eq (car proposed) major-mode)
;; Two cases: either proposed is nil, and we want to switch to fundamental ;; 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. ;; 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) (defvar loadhist-unload-filename nil)

View File

@ -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 documentation of that program for the details about how it determines
which file names match SEARCH-STRING. (Those details vary highly with which file names match SEARCH-STRING. (Those details vary highly with
the version.)" the version.)"
:type 'string :type 'string)
:group 'locate)
(defcustom locate-post-command-hook nil (defcustom locate-post-command-hook nil
"List of hook functions run after `locate' (see `run-hooks')." "List of hook functions run after `locate' (see `run-hooks')."
:type 'hook :type 'hook)
:group 'locate)
(defvar locate-history-list nil (defvar locate-history-list nil
"The history list used by the \\[locate] command.") "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 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 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)." should be the arguments to that command (including the name to find)."
:type 'function :type 'function)
:group 'locate)
(defcustom locate-buffer-name "*Locate*" (defcustom locate-buffer-name "*Locate*"
"Name of the buffer to show results from the \\[locate] command." "Name of the buffer to show results from the \\[locate] command."
:type 'string :type 'string)
:group 'locate)
(defcustom locate-fcodes-file nil (defcustom locate-fcodes-file nil
"File name for the database of file names used by `locate'. "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 that `locate' searches. The executive program that the Emacs
function `locate' uses, as given by the variables `locate-command' function `locate' uses, as given by the variables `locate-command'
or `locate-make-command-line', determines the database." or `locate-make-command-line', determines the database."
:type '(choice (const :tag "None" nil) file) :type '(choice (const :tag "None" nil) file))
:group 'locate)
(defcustom locate-header-face nil (defcustom locate-header-face nil
"Face used to highlight the locate header." "Face used to highlight the locate header."
:type '(choice (const :tag "None" nil) face) :type '(choice (const :tag "None" nil) face))
:group 'locate)
;;;###autoload ;;;###autoload
(defcustom locate-ls-subdir-switches (purecopy "-al") (defcustom locate-ls-subdir-switches (purecopy "-al")
"`ls' switches for inserting subdirectories in `*Locate*' buffers. "`ls' switches for inserting subdirectories in `*Locate*' buffers.
This should contain the \"-l\" switch, but not the \"-F\" or \"-b\" switches." This should contain the \"-l\" switch, but not the \"-F\" or \"-b\" switches."
:type 'string :type 'string
:group 'locate
:version "22.1") :version "22.1")
(defcustom locate-update-when-revert nil (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'.) option `locate-update-path'.)
If nil, reverting does not update the locate database." If nil, reverting does not update the locate database."
:type 'boolean :type 'boolean
:group 'locate
:version "22.1") :version "22.1")
(defcustom locate-update-command "updatedb" (defcustom locate-update-command "updatedb"
"The executable program used to update the locate database." "The executable program used to update the locate database."
:type 'string :type 'string)
:group 'locate)
(defcustom locate-update-path "/" (defcustom locate-update-path "/"
"The default directory from where `locate-update-command' is called. "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 permissions are sufficient to run the command, you can set this
option to \"/\"." option to \"/\"."
:type 'string :type 'string
:group 'locate
:version "22.1") :version "22.1")
(defcustom locate-prompt-for-command nil (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; Setting this option non-nil actually inverts the meaning of a prefix arg;
that is, with a prefix arg, you get the default behavior." that is, with a prefix arg, you get the default behavior."
:group 'locate
:type 'boolean) :type 'boolean)
(defcustom locate-mode-hook nil (defcustom locate-mode-hook nil
"List of hook functions run by `locate-mode' (see `run-mode-hooks')." "List of hook functions run by `locate-mode' (see `run-mode-hooks')."
:type 'hook :type 'hook)
:group 'locate)
;; Functions ;; Functions
@ -371,17 +359,17 @@ except that FILTER is not optional."
(defvar locate-mode-map (defvar locate-mode-map
(let ((map (copy-keymap dired-mode-map))) (let ((map (copy-keymap dired-mode-map)))
;; Undefine Useless Dired Menu bars ;; Undefine Useless Dired Menu bars
(define-key map [menu-bar Dired] 'undefined) (define-key map [menu-bar Dired] #'undefined)
(define-key map [menu-bar subdir] 'undefined) (define-key map [menu-bar subdir] #'undefined)
(define-key map [menu-bar mark executables] 'undefined) (define-key map [menu-bar mark executables] #'undefined)
(define-key map [menu-bar mark directory] 'undefined) (define-key map [menu-bar mark directory] #'undefined)
(define-key map [menu-bar mark directories] 'undefined) (define-key map [menu-bar mark directories] #'undefined)
(define-key map [menu-bar mark symlinks] 'undefined) (define-key map [menu-bar mark symlinks] #'undefined)
(define-key map [M-mouse-2] 'locate-mouse-view-file) (define-key map [M-mouse-2] #'locate-mouse-view-file)
(define-key map "\C-c\C-t" 'locate-tags) (define-key map "\C-c\C-t" #'locate-tags)
(define-key map "l" 'locate-do-redisplay) (define-key map "l" #'locate-do-redisplay)
(define-key map "U" 'dired-unmark-all-files) (define-key map "U" #'dired-unmark-all-files)
(define-key map "V" 'locate-find-directory) (define-key map "V" #'locate-find-directory)
map) map)
"Local keymap for Locate mode buffers.") "Local keymap for Locate mode buffers.")
@ -486,7 +474,7 @@ do not work in subdirectories.
(setq-local revert-buffer-function #'locate-update) (setq-local revert-buffer-function #'locate-update)
(setq-local page-delimiter "\n\n")) (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) (defun locate-do-setup (search-string)
(goto-char (point-min)) (goto-char (point-min))

View File

@ -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. this function to insert characters when necessary.
In binary overwrite mode, this function does overwrite, and octal 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." is intended to be useful for editing binary files."
(interactive "*p") (interactive "*p")
(let* ((char (let* ((char

View File

@ -783,8 +783,7 @@ an example."
:package-version '(so-long . "1.0")) :package-version '(so-long . "1.0"))
(make-variable-buffer-local 'so-long-file-local-mode-function) (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) ;Only in Emacs≥26.1
(unless (fboundp 'provided-mode-derived-p)
(defun provided-mode-derived-p (mode &rest modes) (defun provided-mode-derived-p (mode &rest modes)
"Non-nil if MODE is derived from one of MODES. "Non-nil if MODE is derived from one of MODES.
Uses the `derived-mode-parent' property of the symbol to trace backwards. Uses the `derived-mode-parent' property of the symbol to trace backwards.

View File

@ -2682,27 +2682,139 @@ The variable list SPEC is the same as in `if-let*'."
;; PUBLIC: find if the current mode derives from another. ;; 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) (defun provided-mode-derived-p (mode &rest modes)
"Non-nil if MODE is derived from one of 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'." If you just want to check `major-mode', use `derived-mode-p'."
(declare (side-effect-free t)) (declare (side-effect-free t))
(while (let ((ps (derived-mode-all-parents mode)))
(and (while (and modes (not (memq (car modes) ps)))
(not (memq mode modes)) (setq modes (cdr modes)))
(let* ((parent (get mode 'derived-mode-parent))) (car modes)))
(setq mode (or parent
;; If MODE is an alias, then follow the alias.
(let ((alias (symbol-function mode)))
(and (symbolp alias) alias)))))))
mode)
(defun derived-mode-p (&rest modes) (defun derived-mode-p (&rest modes)
"Non-nil if the current major mode is derived from one of 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."
(declare (side-effect-free t)) (declare (side-effect-free t))
(apply #'provided-mode-derived-p major-mode modes)) (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) (defvar-local major-mode--suspended nil)
(put 'major-mode--suspended 'permanent-local t) (put 'major-mode--suspended 'permanent-local t)

View File

@ -345,8 +345,7 @@
;;;; Mode hooks. ;;;; Mode hooks.
(defalias 'subr-tests--parent-mode (defalias 'subr-tests--parent-mode #'prog-mode)
(if (fboundp 'prog-mode) 'prog-mode 'fundamental-mode))
(define-derived-mode subr-tests--derived-mode-1 prog-mode "test") (define-derived-mode subr-tests--derived-mode-1 prog-mode "test")
(define-derived-mode subr-tests--derived-mode-2 subr-tests--parent-mode "test") (define-derived-mode subr-tests--derived-mode-2 subr-tests--parent-mode "test")
@ -360,6 +359,41 @@
'subr-tests--parent-mode)) 'subr-tests--parent-mode))
(should (provided-mode-derived-p 'subr-tests--derived-mode-2 'prog-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 () (ert-deftest number-sequence-test ()
(should (= (length (should (= (length
(number-sequence (1- most-positive-fixnum) most-positive-fixnum)) (number-sequence (1- most-positive-fixnum) most-positive-fixnum))