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
commit
4194f9bd87
@ -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
|
||||
|
||||
|
||||
12
etc/NEWS
12
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
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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))
|
||||
)
|
||||
|
||||
@ -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."
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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))
|
||||
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)))))
|
||||
|
||||
@ -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 ()
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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))))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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))))
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
136
lisp/subr.el
136
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)
|
||||
|
||||
|
||||
@ -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))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user