1 ;;; mode-local.el --- Support for mode local facilities
3 ;; Copyright (C) 2004-2005, 2007-2017 Free Software Foundation, Inc.
5 ;; Author: David Ponce <david@dponce.com>
6 ;; Maintainer: David Ponce <david@dponce.com>
7 ;; Created: 27 Apr 2004
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
27 ;; Each major mode will want to support a specific set of behaviors.
28 ;; Usually generic behaviors that need just a little bit of local
31 ;; This library permits the setting of override functions for tasks of
32 ;; that nature, and also provides reasonable defaults.
34 ;; There are buffer local variables (and there were frame local variables).
35 ;; This library gives the illusion of mode specific variables.
37 ;; You should use a mode-local variable or override to allow extension
38 ;; only if you expect a mode author to provide that extension. If a
39 ;; user might wish to customize a given variable or function then
40 ;; the existing customization mechanism should be used.
43 ;; Allow customization of a variable for a specific mode?
45 ;; Add macro for defining the '-default' functionality.
49 (eval-when-compile (require 'cl
))
52 ;; For find-function-regexp-alist. It is tempting to replace this
53 ;; ‘require’ by (defvar find-function-regexp-alist) and
54 ;; with-eval-after-load, but model-local.el is typically loaded when a
55 ;; semantic autoload is invoked, and something in semantic loads
56 ;; find-func.el before mode-local.el, so the eval-after-load is lost.
60 (defun mode-local-map-file-buffers (function &optional predicate buffers
)
61 "Run FUNCTION on every file buffer found.
62 FUNCTION does not have arguments; when it is entered `current-buffer'
63 is the currently selected file buffer.
64 If optional argument PREDICATE is non nil, only select file buffers
65 for which the function PREDICATE returns non-nil.
66 If optional argument BUFFERS is non-nil, it is a list of buffers to
67 walk through. It defaults to `buffer-list'."
68 (dolist (b (or buffers
(buffer-list)))
69 (and (buffer-live-p b
) (buffer-file-name b
)
70 (with-current-buffer b
71 (when (or (not predicate
) (funcall predicate
))
72 (funcall function
))))))
74 (defsubst get-mode-local-parent
(mode)
75 "Return the mode parent of the major mode MODE.
76 Return nil if MODE has no parent."
77 (or (get mode
'mode-local-parent
)
78 (get mode
'derived-mode-parent
)))
80 ;; FIXME doc (and function name) seems wrong.
81 ;; Return a list of MODE and all its parent modes, if any.
82 ;; Lists parent modes first.
83 (defun mode-local-equivalent-mode-p (mode)
84 "Is the major-mode in the current buffer equivalent to a mode in MODES."
87 (setq modes
(cons mode modes
)
88 mode
(get-mode-local-parent mode
)))
91 (defun mode-local-map-mode-buffers (function modes
)
92 "Run FUNCTION on every file buffer with major mode in MODES.
93 MODES can be a symbol or a list of symbols.
94 FUNCTION does not have arguments."
95 (or (listp modes
) (setq modes
(list modes
)))
96 (mode-local-map-file-buffers
98 (let ((mm (mode-local-equivalent-mode-p major-mode
))
100 (while (and (not ans
) mm
)
101 (setq ans
(memq (car mm
) modes
)
107 (defvar mode-local-init-hook nil
108 "Hook run after a new file buffer is created.
109 The current buffer is the newly created file buffer.")
111 (defvar mode-local-changed-mode-buffers nil
112 "List of buffers whose `major-mode' has changed recently.")
114 (defvar mode-local--init-mode nil
)
116 (defsubst mode-local-initialized-p
()
117 "Return non-nil if mode local is initialized in current buffer.
118 That is, if the current `major-mode' is equal to the major mode for
119 which mode local bindings have been activated."
120 (eq mode-local--init-mode major-mode
))
122 (defun mode-local-post-major-mode-change ()
123 "Initialize mode-local facilities.
124 This is run from `find-file-hook', and from `post-command-hook'
125 after changing the major mode."
126 (remove-hook 'post-command-hook
'mode-local-post-major-mode-change nil
)
127 (let ((buffers mode-local-changed-mode-buffers
))
128 (setq mode-local-changed-mode-buffers nil
)
129 (mode-local-map-file-buffers
131 ;; Make sure variables are set up for this mode.
132 (activate-mode-local-bindings)
133 (run-hooks 'mode-local-init-hook
))
135 (not (mode-local-initialized-p)))
138 (defun mode-local-on-major-mode-change ()
139 "Function called in `change-major-mode-hook'."
140 (add-to-list 'mode-local-changed-mode-buffers
(current-buffer))
141 (add-hook 'post-command-hook
'mode-local-post-major-mode-change t nil
))
145 (defsubst set-mode-local-parent
(mode parent
)
146 "Set parent of major mode MODE to PARENT mode.
147 To work properly, this function should be called after PARENT mode
148 local variables have been defined."
149 (put mode
'mode-local-parent parent
)
150 ;; Refresh mode bindings to get mode local variables inherited from
151 ;; PARENT. To work properly, the following should be called after
152 ;; PARENT mode local variables have been defined.
153 (mode-local-map-mode-buffers #'activate-mode-local-bindings mode
))
155 (defmacro define-child-mode
(mode parent
&optional docstring
)
156 "Make major mode MODE inherit behavior from PARENT mode.
157 DOCSTRING is optional and not used.
158 To work properly, this should be put after PARENT mode local variables
160 `(set-mode-local-parent ',mode
',parent
))
162 (defun mode-local-use-bindings-p (this-mode desired-mode
)
163 "Return non-nil if THIS-MODE can use bindings of DESIRED-MODE."
165 (while (and (not ans
) this-mode
)
166 (setq ans
(eq this-mode desired-mode
))
167 (setq this-mode
(get-mode-local-parent this-mode
)))
171 ;;; Core bindings API
173 (defvar mode-local-symbol-table nil
174 "Buffer local mode bindings.
175 These symbols provide a hook for a `major-mode' to specify specific
176 behaviors. Use the function `mode-local-bind' to define new bindings.")
177 (make-variable-buffer-local 'mode-local-symbol-table
)
179 (defvar mode-local-active-mode nil
180 "Major mode in which bindings are active.")
182 (defsubst new-mode-local-bindings
()
183 "Return a new empty mode bindings symbol table."
186 (defun mode-local-bind (bindings &optional plist mode
)
187 "Define BINDINGS in the specified environment.
188 BINDINGS is a list of (VARIABLE . VALUE).
189 Optional argument PLIST is a property list each VARIABLE symbol will
190 be set to. The following properties have special meaning:
192 - `constant-flag' if non-nil, prevent rebinding variables.
193 - `mode-variable-flag' if non-nil, define mode variables.
194 - `override-flag' if non-nil, define override functions.
196 The `override-flag' and `mode-variable-flag' properties are mutually
199 If optional argument MODE is non-nil, it must be a major mode symbol.
200 BINDINGS will be defined globally for this major mode. If MODE is
201 nil, BINDINGS will be defined locally in the current buffer, in
202 variable `mode-local-symbol-table'. The later should be done in MODE
204 ;; Check plist consistency
205 (and (plist-get plist
'mode-variable-flag
)
206 (plist-get plist
'override-flag
)
207 (error "Bindings can't be both overrides and mode variables"))
208 (let (table variable varname value binding
)
211 ;; Install in given MODE symbol table. Create a new one if
213 (setq table
(or (get mode
'mode-local-symbol-table
)
214 (new-mode-local-bindings)))
215 (put mode
'mode-local-symbol-table table
))
216 ;; Fail if trying to bind mode variables in local context!
217 (if (plist-get plist
'mode-variable-flag
)
218 (error "Mode required to bind mode variables"))
219 ;; Install in buffer local symbol table. Create a new one if
221 (setq table
(or mode-local-symbol-table
222 (setq mode-local-symbol-table
223 (new-mode-local-bindings)))))
225 (setq binding
(car bindings
)
226 bindings
(cdr bindings
)
227 varname
(symbol-name (car binding
))
229 (if (setq variable
(intern-soft varname table
))
230 ;; Binding already exists
231 ;; Check rebind consistency
233 ((equal (symbol-value variable
) value
)
234 ;; Just ignore rebind with the same value.
236 ((get variable
'constant-flag
)
237 (error "Can't change the value of constant `%s'"
239 ((and (get variable
'mode-variable-flag
)
240 (plist-get plist
'override-flag
))
241 (error "Can't rebind override `%s' as a mode variable"
243 ((and (get variable
'override-flag
)
244 (plist-get plist
'mode-variable-flag
))
245 (error "Can't rebind mode variable `%s' as an override"
248 ;; Merge plist and assign new value
249 (setplist variable
(append plist
(symbol-plist variable
)))
250 (set variable value
)))
252 (setq variable
(intern varname table
))
253 ;; Set new plist and assign initial value
254 (setplist variable plist
)
255 (set variable value
)))
256 ;; Return the symbol table used
259 (defsubst mode-local-symbol
(symbol &optional mode
)
260 "Return the mode local symbol bound with SYMBOL's name.
261 Return nil if the mode local symbol doesn't exist.
262 If optional argument MODE is nil, lookup first into locally bound
263 symbols, then in those bound in current `major-mode' and its parents.
264 If MODE is non-nil, lookup into symbols bound in that major mode and
266 (let ((name (symbol-name symbol
)) bind
)
268 (setq mode mode-local-active-mode
)
269 (setq mode major-mode
270 bind
(and mode-local-symbol-table
271 (intern-soft name mode-local-symbol-table
))))
272 (while (and mode
(not bind
))
273 (or (and (get mode
'mode-local-symbol-table
)
274 (setq bind
(intern-soft
275 name
(get mode
'mode-local-symbol-table
))))
276 (setq mode
(get-mode-local-parent mode
))))
279 (defsubst mode-local-symbol-value
(symbol &optional mode property
)
280 "Return the value of the mode local symbol bound with SYMBOL's name.
281 If optional argument MODE is non-nil, restrict lookup to that mode and
282 its parents (see the function `mode-local-symbol' for more details).
283 If optional argument PROPERTY is non-nil the mode local symbol must
284 have that property set. Return nil if the symbol doesn't exist, or
285 doesn't have PROPERTY set."
286 (and (setq symbol
(mode-local-symbol symbol mode
))
287 (or (not property
) (get symbol property
))
288 (symbol-value symbol
)))
290 ;;; Mode local variables
292 (defun activate-mode-local-bindings (&optional mode
)
293 "Activate variables defined locally in MODE and its parents.
294 That is, copy mode local bindings into corresponding buffer local
296 If MODE is not specified it defaults to current `major-mode'.
297 Return the alist of buffer-local variables that have been changed.
298 Elements are (SYMBOL . PREVIOUS-VALUE), describing one variable."
300 ;; do not do this if we are inside set-auto-mode as we may be in
301 ;; an initialization race condition.
302 (if (or (and (featurep 'emacs
) (boundp 'keep-mode-if-same
))
303 (and (featurep 'xemacs
) (boundp 'just-from-file-name
)))
304 ;; We are inside set-auto-mode, as this is an argument that is
307 ;; This will make sure that when everything is over, this will get
308 ;; called and we won't be under set-auto-mode anymore.
309 (mode-local-on-major-mode-change)
311 ;; Do the normal thing.
312 (let (modes table old-locals
)
314 (set (make-local-variable 'mode-local--init-mode
) major-mode
)
315 (setq mode major-mode
))
316 ;; Get MODE's parents & MODE in the right order.
318 (setq modes
(cons mode modes
)
319 mode
(get-mode-local-parent mode
)))
320 ;; Activate mode bindings following parent modes order.
322 (when (setq table
(get mode
'mode-local-symbol-table
))
325 (when (get var
'mode-variable-flag
)
326 (let ((v (intern (symbol-name var
))))
327 ;; Save the current buffer-local value of the
328 ;; mode-local variable.
329 (and (local-variable-p v
(current-buffer))
330 (push (cons v
(symbol-value v
)) old-locals
))
331 (set (make-local-variable v
) (symbol-value var
)))))
335 (defun deactivate-mode-local-bindings (&optional mode
)
336 "Deactivate variables defined locally in MODE and its parents.
337 That is, kill buffer local variables set from the corresponding mode
339 If MODE is not specified it defaults to current `major-mode'."
341 (kill-local-variable 'mode-local--init-mode
)
342 (setq mode major-mode
))
345 (when (setq table
(get mode
'mode-local-symbol-table
))
348 (when (get var
'mode-variable-flag
)
349 (kill-local-variable (intern (symbol-name var
)))))
351 (setq mode
(get-mode-local-parent mode
)))))
353 (defmacro with-mode-local-symbol
(mode &rest body
)
354 "With the local bindings of MODE symbol, evaluate BODY.
355 The current mode bindings are saved, BODY is evaluated, and the saved
356 bindings are restored, even in case of an abnormal exit.
357 Value is what BODY returns.
358 This is like `with-mode-local', except that MODE's value is used.
359 To use the symbol MODE (quoted), use `with-mode-local'."
360 (let ((old-mode (make-symbol "mode"))
361 (old-locals (make-symbol "old-locals"))
362 (new-mode (make-symbol "new-mode"))
363 (local (make-symbol "local")))
364 `(let ((,old-mode mode-local-active-mode
)
370 (deactivate-mode-local-bindings ,old-mode
)
371 (setq mode-local-active-mode
,new-mode
)
372 ;; Save the previous value of buffer-local variables
373 ;; changed by `activate-mode-local-bindings'.
374 (setq ,old-locals
(activate-mode-local-bindings ,new-mode
))
376 (deactivate-mode-local-bindings ,new-mode
)
377 ;; Restore the previous value of buffer-local variables.
378 (dolist (,local
,old-locals
)
379 (set (car ,local
) (cdr ,local
)))
380 ;; Restore the mode local variables.
381 (setq mode-local-active-mode
,old-mode
)
382 (activate-mode-local-bindings ,old-mode
)))))
383 (put 'with-mode-local-symbol
'lisp-indent-function
1)
385 (defmacro with-mode-local
(mode &rest body
)
386 "With the local bindings of MODE, evaluate BODY.
387 The current mode bindings are saved, BODY is evaluated, and the saved
388 bindings are restored, even in case of an abnormal exit.
389 Value is what BODY returns.
390 This is like `with-mode-local-symbol', except that MODE is quoted
391 and is not evaluated."
392 `(with-mode-local-symbol ',mode
,@body
))
393 (put 'with-mode-local
'lisp-indent-function
1)
396 (defsubst mode-local-value
(mode sym
)
397 "Return the value of the MODE local variable SYM."
398 (or mode
(error "Missing major mode symbol"))
399 (mode-local-symbol-value sym mode
'mode-variable-flag
))
401 (defmacro setq-mode-local
(mode &rest args
)
402 "Assign new values to variables local in MODE.
403 MODE must be a major mode symbol.
404 ARGS is a list (SYM VAL SYM VAL ...).
405 The symbols SYM are variables; they are literal (not evaluated).
406 The values VAL are expressions; they are evaluated.
407 Set each SYM to the value of its VAL, locally in buffers already in
408 MODE, or in buffers switched to that mode.
409 Return the value of the last VAL."
411 (let (i ll bl sl tmp sym val
)
414 (setq tmp
(make-symbol (format "tmp%d" i
))
418 ll
(cons (list tmp val
) ll
)
419 bl
(cons `(cons ',sym
,tmp
) bl
)
420 sl
(cons `(set (make-local-variable ',sym
) ,tmp
) sl
)
422 `(let* ,(nreverse ll
)
423 ;; Save mode bindings
424 (mode-local-bind (list ,@bl
) '(mode-variable-flag t
) ',mode
)
425 ;; Assign to local variables in all existing buffers in MODE
426 (mode-local-map-mode-buffers #'(lambda () ,@sl
) ',mode
)
427 ;; Return the last value
431 (defmacro defvar-mode-local
(mode sym val
&optional docstring
)
432 "Define MODE local variable SYM with value VAL.
433 DOCSTRING is optional."
435 (setq-mode-local ,mode
,sym
,val
)
436 (put (mode-local-symbol ',sym
',mode
)
437 'variable-documentation
,docstring
)
439 (put 'defvar-mode-local
'lisp-indent-function
'defun
)
441 (defmacro defconst-mode-local
(mode sym val
&optional docstring
)
442 "Define MODE local constant SYM with value VAL.
443 DOCSTRING is optional."
444 (let ((tmp (make-symbol "tmp")))
446 (setq-mode-local ,mode
,sym
,val
)
447 (setq ,tmp
(mode-local-symbol ',sym
',mode
))
448 (put ,tmp
'constant-flag t
)
449 (put ,tmp
'variable-documentation
,docstring
)
451 (put 'defconst-mode-local
'lisp-indent-function
'defun
)
453 ;;; Function overloading
455 (defun make-obsolete-overload (old new when
)
456 "Mark OLD overload as obsoleted by NEW overload.
457 WHEN is a string describing the first release where it was made obsolete."
458 (put old
'overload-obsoleted-by new
)
459 (put old
'overload-obsoleted-since when
)
460 (put old
'mode-local-overload t
)
461 (put new
'overload-obsolete old
))
463 (defsubst overload-obsoleted-by
(overload)
464 "Get the overload symbol obsoleted by OVERLOAD.
465 Return the obsolete symbol or nil if not found."
466 (get overload
'overload-obsolete
))
468 (defsubst overload-that-obsolete
(overload)
469 "Return the overload symbol that obsoletes OVERLOAD.
470 Return the symbol found or nil if OVERLOAD is not obsolete."
471 (get overload
'overload-obsoleted-by
))
473 (defsubst fetch-overload
(overload)
474 "Return the current OVERLOAD function, or nil if not found.
475 First, lookup for OVERLOAD into locally bound mode local symbols, then
476 in those bound in current `major-mode' and its parents."
477 (or (mode-local-symbol-value overload nil
'override-flag
)
478 ;; If an obsolete overload symbol exists, try it.
479 (and (overload-obsoleted-by overload
)
480 (mode-local-symbol-value
481 (overload-obsoleted-by overload
) nil
'override-flag
))))
483 (defun mode-local--override (name args body
)
484 "Return the form that handles overloading of function NAME.
485 ARGS are the arguments to the function.
486 BODY is code that would be run when there is no override defined. The
487 default is to call the function `NAME-default' with the appropriate
489 See also the function `define-overload'."
490 (let* ((default (intern (format "%s-default" name
)))
491 (overargs (delq '&rest
(delq '&optional
(copy-sequence args
))))
492 (override (make-symbol "override")))
493 `(let ((,override
(fetch-overload ',name
)))
495 (funcall ,override
,@overargs
)
496 ,@(or body
`((,default
,@overargs
)))))
499 (defun mode-local--expand-overrides (name args body
)
500 "Expand override forms that overload function NAME.
501 ARGS are the arguments to the function NAME.
502 BODY is code where override forms are searched for expansion.
503 Return result of expansion, or BODY if no expansion occurred.
504 See also the function `define-overload'."
509 (setq form
(car forms
))
512 ((eq (car form
) :override
)
513 (setq form
(mode-local--override name args
(cdr form
))))
514 ((eq (car form
) :override-with-args
)
515 (setq form
(mode-local--override name
(cadr form
) (cddr form
))))
516 ((setq form
(mode-local--expand-overrides name args form
))))
517 (setq ditto
(and ditto
(eq (car forms
) form
))
518 xbody
(cons form xbody
)
520 (if ditto body
(nreverse xbody
))))
522 (defun mode-local--overload-body (name args body
)
523 "Return the code that implements overloading of function NAME.
524 ARGS are the arguments to the function NAME.
525 BODY specifies the overload code.
526 See also the function `define-overload'."
527 (let ((result (mode-local--expand-overrides name args body
)))
529 (list (mode-local--override name args body
))
533 (put 'define-overloadable-function
'doc-string-elt
3)
535 (defmacro define-overloadable-function
(name args docstring
&rest body
)
536 "Define a new function, as with `defun', which can be overloaded.
537 NAME is the name of the function to create.
538 ARGS are the arguments to the function.
539 DOCSTRING is a documentation string to describe the function. The
540 docstring will automatically have details about its overload symbol
542 BODY is code that would be run when there is no override defined. The
543 default is to call the function `NAME-default' with the appropriate
546 BODY can also include an override form that specifies which part of
547 BODY is specifically overridden. This permits specifying common code
548 run for both default and overridden implementations.
549 An override form is one of:
551 1. (:override [OVERBODY])
552 2. (:override-with-args OVERARGS [OVERBODY])
554 OVERBODY is the code that would be run when there is no override
555 defined. The default is to call the function `NAME-default' with the
556 appropriate arguments deduced from ARGS.
557 OVERARGS is a list of arguments passed to the override and
558 `NAME-default' function, in place of those deduced from ARGS."
559 (declare (doc-string 3))
563 ,@(mode-local--overload-body name args body
))
564 (put ',name
'mode-local-overload t
)))
565 (put :override-with-args
'lisp-indent-function
1)
567 (defalias 'define-overload
'define-overloadable-function
)
569 (defsubst function-overload-p
(symbol)
570 "Return non-nil if SYMBOL is a function which can be overloaded."
571 (and symbol
(symbolp symbol
) (get symbol
'mode-local-overload
)))
573 (defmacro define-mode-local-override
574 (name mode args docstring
&rest body
)
575 "Define a mode specific override of the function overload NAME.
576 Has meaning only if NAME has been created with `define-overload'.
577 MODE is the major mode this override is being defined for.
578 ARGS are the function arguments, which should match those of the same
579 named function created with `define-overload'.
580 DOCSTRING is the documentation string.
581 BODY is the implementation of this function."
582 ;; FIXME: Make this obsolete and use cl-defmethod with &context instead.
583 (declare (doc-string 4))
584 (let ((newname (intern (format "%s-%s" name mode
))))
587 (defun ,newname
,args
588 ,(format "%s\n\nOverride %s in `%s' buffers."
590 ;; The body for this implementation
592 ;; For find-func to locate the definition of NEWNAME.
593 (put ',newname
'definition-name
',name
))
594 (mode-local-bind '((,name .
,newname
))
599 ;;; Read/Query Support
600 (defun mode-local-read-function (prompt &optional initial hist default
)
601 "Interactively read in the name of a mode-local function.
602 PROMPT, INITIAL, HIST, and DEFAULT are the same as for `completing-read'."
603 (completing-read prompt obarray
'function-overload-p t initial hist default
))
607 (defun overload-docstring-extension (overload)
608 "Return the doc string that augments the description of OVERLOAD."
609 (let ((doc "\nThis function can be overloaded\
610 with `define-mode-local-override'.")
611 (sym (overload-obsoleted-by overload
)))
613 (setq doc
(format "%s\nIt has made the overload `%s' obsolete since %s."
614 doc sym
(get sym
'overload-obsoleted-since
))))
615 (setq sym
(overload-that-obsolete overload
))
617 (setq doc
(format "%s\nThis overload is obsolete since %s;\nUse `%s' instead."
618 doc
(get overload
'overload-obsoleted-since
) sym
)))
621 (defun mode-local-augment-function-help (symbol)
622 "Augment the *Help* buffer for SYMBOL.
623 SYMBOL is a function that can be overridden."
624 (with-current-buffer "*Help*"
625 (pop-to-buffer (current-buffer))
626 (goto-char (point-min))
627 (unless (re-search-forward "^$" nil t
)
628 (goto-char (point-max))
631 (let ((inhibit-read-only t
))
632 (insert (substitute-command-keys (overload-docstring-extension symbol
))
635 ;; LIST ALL LOADED OVERRIDES FOR SYMBOL HERE
638 ;; We are called from describe-function in help-fns.el, where this is defined.
639 (defvar describe-function-orig-buffer
)
641 (defun describe-mode-local-overload (symbol)
642 "For `help-fns-describe-function-functions'; add overloads for SYMBOL."
643 (when (function-overload-p symbol
)
644 (let ((default (or (intern-soft (format "%s-default" (symbol-name symbol
)))
646 (override (with-current-buffer describe-function-orig-buffer
647 (fetch-overload symbol
)))
650 (insert (substitute-command-keys (overload-docstring-extension symbol
))
652 (insert (format-message "default function: `%s'\n" default
))
654 (insert (format-message "\noverride in buffer `%s': `%s'\n"
655 describe-function-orig-buffer override
))
656 (insert (format-message "\nno override in buffer `%s'\n"
657 describe-function-orig-buffer
)))
660 (lambda (sym) (when (get sym
'mode-local-symbol-table
) (push sym modes
)))
664 (let* ((major-mode mode
)
665 (override (fetch-overload symbol
)))
668 (insert (format-message "\noverride in mode `%s': `%s'\n"
669 major-mode override
))
673 (add-hook 'help-fns-describe-function-functions
'describe-mode-local-overload
)
675 (declare-function xref-item-location
"xref" (xref) t
)
677 (defun xref-mode-local--override-present (sym xrefs
)
678 "Return non-nil if SYM is in XREFS."
680 (while (and (null result
)
682 (when (equal sym
(car (xref-elisp-location-symbol (xref-item-location (pop xrefs
)))))
686 (defun xref-mode-local-overload (symbol)
687 "For `elisp-xref-find-def-functions'; add overloads for SYMBOL."
688 ;; Current buffer is the buffer where xref-find-definitions was invoked.
689 (when (function-overload-p symbol
)
690 (let* ((symbol-file (find-lisp-object-file-name symbol
(symbol-function symbol
)))
691 (default (intern-soft (format "%s-default" (symbol-name symbol
))))
692 (default-file (when default
(find-lisp-object-file-name default
(symbol-function default
))))
697 (lambda (sym) (when (get sym
'mode-local-symbol-table
) (push sym modes
)))
700 ;; mode-local-overrides are inherited from parent modes; we
701 ;; don't want to list the same function twice. So order ‘modes’
702 ;; with parents first, and check for duplicates.
707 (not (equal b
(get a
'mode-local-parent
)))))) ;; a is not a child, or not a child of b
710 (let* ((major-mode mode
)
711 (override (fetch-overload symbol
))
712 (override-file (when override
(find-lisp-object-file-name override
(symbol-function override
)))))
714 (when (and override override-file
)
715 (let ((meta-name (cons override major-mode
))
716 ;; For the declaration:
718 ;;(define-mode-local-override xref-elisp-foo c-mode
720 ;; The override symbol name is
721 ;; "xref-elisp-foo-c-mode". The summary should match
722 ;; the declaration, so strip the mode from the
724 (summary (format elisp--xref-format-extra
725 'define-mode-local-override
726 (substring (symbol-name override
) 0 (- (1+ (length (symbol-name major-mode
)))))
729 (unless (xref-mode-local--override-present override xrefs
)
730 (push (elisp--xref-make-xref
731 'define-mode-local-override meta-name override-file summary
)
734 ;; %s-default is interned whether it is a separate function or
735 ;; not, so we have to check that here.
736 (when (and (functionp default
) default-file
)
737 (push (elisp--xref-make-xref nil default default-file
) xrefs
))
740 (push (elisp--xref-make-xref 'define-overloadable-function symbol symbol-file
) xrefs
))
744 (add-hook 'elisp-xref-find-def-functions
'xref-mode-local-overload
)
746 (defconst xref-mode-local-find-overloadable-regexp
747 "(\\(\\(define-overloadable-function\\)\\|\\(define-overload\\)\\) +%s"
748 "Regexp used by `xref-find-definitions' when searching for a
749 mode-local overloadable function definition.")
751 (defun xref-mode-local-find-override (meta-name)
752 "Function used by `xref-find-definitions' when searching for an
753 override of a mode-local overloadable function.
754 META-NAME is a cons (OVERLOADABLE-SYMBOL . MAJOR-MODE)."
755 (let* ((override (car meta-name
))
756 (mode (cdr meta-name
))
757 (regexp (format "(define-mode-local-override +%s +%s"
758 (substring (symbol-name override
) 0 (- (1+ (length (symbol-name mode
)))))
760 (re-search-forward regexp nil t
)
763 (add-to-list 'find-function-regexp-alist
'(define-overloadable-function . xref-mode-local-find-overloadable-regexp
))
764 (add-to-list 'find-function-regexp-alist
(cons 'define-mode-local-override
#'xref-mode-local-find-override
))
766 ;; Help for mode-local bindings.
767 (defun mode-local-print-binding (symbol)
768 "Print the SYMBOL binding."
769 (let ((value (symbol-value symbol
)))
770 (princ (format-message "\n `%s' value is\n " symbol
))
771 (if (and value
(symbolp value
))
772 (princ (format-message "`%s'" value
))
778 (or (bolp) (princ "\n"))))
780 (defun mode-local-print-bindings (table)
781 "Print bindings in TABLE."
782 (let (us ;; List of unspecified symbols
783 mc
;; List of mode local constants
784 mv
;; List of mode local variables
785 ov
;; List of overloaded functions
786 fo
;; List of final overloaded functions
788 ;; Order symbols by type
792 ((get s
'mode-variable-flag
)
793 (if (get s
'constant-flag
) 'mc
'mv
))
794 ((get s
'override-flag
)
795 (if (get s
'constant-flag
) 'fo
'ov
))
799 ;; Print symbols by type
801 (princ "\n !! Unspecified symbols\n")
802 (mapc 'mode-local-print-binding us
))
804 (princ "\n ** Mode local constants\n")
805 (mapc 'mode-local-print-binding mc
))
807 (princ "\n ** Mode local variables\n")
808 (mapc 'mode-local-print-binding mv
))
810 (princ "\n ** Final overloaded functions\n")
811 (mapc 'mode-local-print-binding fo
))
813 (princ "\n ** Overloaded functions\n")
814 (mapc 'mode-local-print-binding ov
))
817 (defun mode-local-describe-bindings-2 (buffer-or-mode)
818 "Display mode local bindings active in BUFFER-OR-MODE."
820 (princ "Mode local bindings active in ")
822 ((bufferp buffer-or-mode
)
823 (with-current-buffer buffer-or-mode
824 (setq table mode-local-symbol-table
826 (princ (format "%S\n" buffer-or-mode
))
828 ((symbolp buffer-or-mode
)
829 (setq mode buffer-or-mode
)
830 (princ (format-message "`%s'\n" buffer-or-mode
))
832 ((signal 'wrong-type-argument
833 (list 'buffer-or-mode buffer-or-mode
))))
835 (princ "\n- Buffer local\n")
836 (mode-local-print-bindings table
))
838 (setq table
(get mode
'mode-local-symbol-table
))
840 (princ (format-message "\n- From `%s'\n" mode
))
841 (mode-local-print-bindings table
))
842 (setq mode
(get-mode-local-parent mode
)))))
844 (defun mode-local-describe-bindings-1 (buffer-or-mode &optional interactive-p
)
845 "Display mode local bindings active in BUFFER-OR-MODE.
846 Optional argument INTERACTIVE-P is non-nil if the calling command was
847 invoked interactively."
848 (if (fboundp 'with-displaying-help-buffer
)
850 (with-displaying-help-buffer
852 (with-current-buffer standard-output
853 (mode-local-describe-bindings-2 buffer-or-mode
)
854 (when (fboundp 'frob-help-extents
)
855 (goto-char (point-min))
856 (frob-help-extents standard-output
)))))
858 (when (fboundp 'help-setup-xref
)
860 (list 'mode-local-describe-bindings-1 buffer-or-mode
)
862 (with-output-to-temp-buffer (help-buffer) ; "*Help*"
863 (with-current-buffer standard-output
864 (mode-local-describe-bindings-2 buffer-or-mode
)))))
866 (defun describe-mode-local-bindings (buffer)
867 "Display mode local bindings active in BUFFER."
869 (when (setq buffer
(get-buffer buffer
))
870 (mode-local-describe-bindings-1 buffer
(called-interactively-p 'any
))))
872 (defun describe-mode-local-bindings-in-mode (mode)
873 "Display mode local bindings active in MODE hierarchy."
875 (list (completing-read
877 #'(lambda (s) (get s
'mode-local-symbol-table
))
878 t
(symbol-name major-mode
))))
879 (when (setq mode
(intern-soft mode
))
880 (mode-local-describe-bindings-1 mode
(called-interactively-p 'any
))))
884 (defun mode-local-setup-edebug-specs ()
885 "Define edebug specification for mode local macros."
886 (def-edebug-spec setq-mode-local
887 (symbolp &rest symbolp form
))
888 (def-edebug-spec defvar-mode-local
889 (&define symbolp name def-form
[ &optional stringp
] ))
890 (def-edebug-spec defconst-mode-local
892 (def-edebug-spec define-overload
893 (&define name lambda-list stringp def-body
))
894 (def-edebug-spec define-overloadable-function
895 (&define name lambda-list stringp def-body
))
896 (def-edebug-spec define-mode-local-override
897 (&define name symbolp lambda-list stringp def-body
)))
899 (add-hook 'edebug-setup-hook
'mode-local-setup-edebug-specs
)
901 (add-hook 'find-file-hook
'mode-local-post-major-mode-change
)
902 (add-hook 'change-major-mode-hook
'mode-local-on-major-mode-change
)
904 (provide 'mode-local
)
906 ;;; mode-local.el ends here