Commit | Line | Data |
---|---|---|
7b232be9 CY |
1 | ;;; mode-local.el --- Support for mode local facilities |
2 | ;; | |
5df4f04c | 3 | ;; Copyright (C) 2004, 2005, 2007, 2008, 2009, 2010, 2011 |
d2ce10d2 | 4 | ;; Free Software Foundation, Inc. |
7b232be9 CY |
5 | ;; |
6 | ;; Author: David Ponce <david@dponce.com> | |
7 | ;; Maintainer: David Ponce <david@dponce.com> | |
8 | ;; Created: 27 Apr 2004 | |
9 | ;; Keywords: syntax | |
10 | ||
11 | ;; This file is part of GNU Emacs. | |
12 | ||
13 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
14 | ;; it under the terms of the GNU General Public License as published by | |
15 | ;; the Free Software Foundation, either version 3 of the License, or | |
16 | ;; (at your option) any later version. | |
17 | ||
18 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
21 | ;; GNU General Public License for more details. | |
22 | ||
23 | ;; You should have received a copy of the GNU General Public License | |
24 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
25 | ||
26 | ;;; Commentary: | |
27 | ;; | |
28 | ;; Each major mode will want to support a specific set of behaviors. | |
29 | ;; Usually generic behaviors that need just a little bit of local | |
30 | ;; specifics. | |
31 | ;; | |
32 | ;; This library permits the setting of override functions for tasks of | |
33 | ;; that nature, and also provides reasonable defaults. | |
34 | ;; | |
35 | ;; There are buffer local variables, and frame local variables. | |
36 | ;; This library gives the illusion of mode specific variables. | |
37 | ;; | |
38 | ;; You should use a mode-local variable or override to allow extension | |
39 | ;; only if you expect a mode author to provide that extension. If a | |
40 | ;; user might wish to customize a give variable or function then | |
41 | ;; the existing customization mechanism should be used. | |
42 | ||
43 | ;; To Do: | |
44 | ;; Allow customization of a variable for a specific mode? | |
45 | ;; | |
46 | ;; Add macro for defining the '-default' functionality. | |
47 | ||
48 | ;;; Code: | |
49 | ||
50 | (eval-when-compile (require 'cl)) | |
51 | ||
52 | ;;; Misc utilities | |
53 | ;; | |
54 | (defun mode-local-map-file-buffers (function &optional predicate buffers) | |
55 | "Run FUNCTION on every file buffer found. | |
56 | FUNCTION does not have arguments; when it is entered `current-buffer' | |
57 | is the currently selected file buffer. | |
58 | If optional argument PREDICATE is non nil, only select file buffers | |
59 | for which the function PREDICATE return non-nil. | |
60 | If optional argument BUFFERS is non-nil, it is a list of buffers to | |
61 | walk through. It defaults to `buffer-list'." | |
62 | (dolist (b (or buffers (buffer-list))) | |
63 | (and (buffer-live-p b) (buffer-file-name b) | |
64 | (with-current-buffer b | |
65 | (when (or (not predicate) (funcall predicate)) | |
66 | (funcall function)))))) | |
67 | ||
68 | (defsubst get-mode-local-parent (mode) | |
69 | "Return the mode parent of the major mode MODE. | |
70 | Return nil if MODE has no parent." | |
71 | (or (get mode 'mode-local-parent) | |
72 | (get mode 'derived-mode-parent))) | |
73 | ||
df8fff6c GM |
74 | ;; FIXME doc (and function name) seems wrong. |
75 | ;; Return a list of MODE and all its parent modes, if any. | |
76 | ;; Lists parent modes first. | |
7b232be9 CY |
77 | (defun mode-local-equivalent-mode-p (mode) |
78 | "Is the major-mode in the current buffer equivalent to a mode in MODES." | |
79 | (let ((modes nil)) | |
80 | (while mode | |
81 | (setq modes (cons mode modes) | |
82 | mode (get-mode-local-parent mode))) | |
83 | modes)) | |
84 | ||
85 | (defun mode-local-map-mode-buffers (function modes) | |
86 | "Run FUNCTION on every file buffer with major mode in MODES. | |
87 | MODES can be a symbol or a list of symbols. | |
88 | FUNCTION does not have arguments." | |
89 | (or (listp modes) (setq modes (list modes))) | |
90 | (mode-local-map-file-buffers | |
91 | function #'(lambda () | |
92 | (let ((mm (mode-local-equivalent-mode-p major-mode)) | |
93 | (ans nil)) | |
94 | (while (and (not ans) mm) | |
95 | (setq ans (memq (car mm) modes) | |
96 | mm (cdr mm)) ) | |
97 | ans)))) | |
98 | \f | |
99 | ;;; Hook machinery | |
100 | ;; | |
101 | (defvar mode-local-init-hook nil | |
102 | "Hook run after a new file buffer is created. | |
103 | The current buffer is the newly created file buffer.") | |
104 | ||
105 | (defvar mode-local-changed-mode-buffers nil | |
106 | "List of buffers whose `major-mode' has changed recently.") | |
107 | ||
108 | (defvar mode-local--init-mode nil) | |
109 | ||
110 | (defsubst mode-local-initialized-p () | |
111 | "Return non-nil if mode local is initialized in current buffer. | |
112 | That is, if the current `major-mode' is equal to the major mode for | |
113 | which mode local bindings have been activated." | |
114 | (eq mode-local--init-mode major-mode)) | |
115 | ||
116 | (defun mode-local-post-major-mode-change () | |
117 | "Initialize mode-local facilities. | |
118 | This is run from `find-file-hook', and from `post-command-hook' | |
119 | after changing the major mode." | |
120 | (remove-hook 'post-command-hook 'mode-local-post-major-mode-change nil) | |
121 | (let ((buffers mode-local-changed-mode-buffers)) | |
122 | (setq mode-local-changed-mode-buffers nil) | |
123 | (mode-local-map-file-buffers | |
124 | (lambda () | |
125 | ;; Make sure variables are set up for this mode. | |
126 | (activate-mode-local-bindings) | |
127 | (run-hooks 'mode-local-init-hook)) | |
128 | (lambda () | |
129 | (not (mode-local-initialized-p))) | |
130 | buffers))) | |
131 | ||
132 | (defun mode-local-on-major-mode-change () | |
133 | "Function called in `change-major-mode-hook'." | |
134 | (add-to-list 'mode-local-changed-mode-buffers (current-buffer)) | |
135 | (add-hook 'post-command-hook 'mode-local-post-major-mode-change t nil)) | |
136 | \f | |
137 | ;;; Mode lineage | |
138 | ;; | |
139 | (defsubst set-mode-local-parent (mode parent) | |
140 | "Set parent of major mode MODE to PARENT mode. | |
141 | To work properly, this function should be called after PARENT mode | |
142 | local variables have been defined." | |
143 | (put mode 'mode-local-parent parent) | |
144 | ;; Refresh mode bindings to get mode local variables inherited from | |
145 | ;; PARENT. To work properly, the following should be called after | |
146 | ;; PARENT mode local variables have been defined. | |
147 | (mode-local-map-mode-buffers #'activate-mode-local-bindings mode)) | |
148 | ||
149 | (defmacro define-child-mode (mode parent &optional docstring) | |
150 | "Make major mode MODE inherits behavior from PARENT mode. | |
151 | DOCSTRING is optional and not used. | |
152 | To work properly, this should be put after PARENT mode local variables | |
153 | definition." | |
154 | `(set-mode-local-parent ',mode ',parent)) | |
155 | ||
156 | (defun mode-local-use-bindings-p (this-mode desired-mode) | |
157 | "Return non-nil if THIS-MODE can use bindings of DESIRED-MODE." | |
158 | (let ((ans nil)) | |
159 | (while (and (not ans) this-mode) | |
160 | (setq ans (eq this-mode desired-mode)) | |
161 | (setq this-mode (get-mode-local-parent this-mode))) | |
162 | ans)) | |
163 | ||
164 | \f | |
165 | ;;; Core bindings API | |
166 | ;; | |
167 | (defvar mode-local-symbol-table nil | |
168 | "Buffer local mode bindings. | |
169 | These symbols provide a hook for a `major-mode' to specify specific | |
170 | behaviors. Use the function `mode-local-bind' to define new bindings.") | |
171 | (make-variable-buffer-local 'mode-local-symbol-table) | |
172 | ||
173 | (defvar mode-local-active-mode nil | |
174 | "Major mode in which bindings are active.") | |
175 | ||
176 | (defsubst new-mode-local-bindings () | |
177 | "Return a new empty mode bindings symbol table." | |
178 | (make-vector 13 0)) | |
179 | ||
180 | (defun mode-local-bind (bindings &optional plist mode) | |
181 | "Define BINDINGS in the specified environment. | |
182 | BINDINGS is a list of (VARIABLE . VALUE). | |
183 | Optional argument PLIST is a property list each VARIABLE symbol will | |
184 | be set to. The following properties have special meaning: | |
185 | ||
186 | - `constant-flag' if non-nil, prevent to rebind variables. | |
187 | - `mode-variable-flag' if non-nil, define mode variables. | |
188 | - `override-flag' if non-nil, define override functions. | |
189 | ||
190 | The `override-flag' and `mode-variable-flag' properties are mutually | |
191 | exclusive. | |
192 | ||
193 | If optional argument MODE is non-nil, it must be a major mode symbol. | |
194 | BINDINGS will be defined globally for this major mode. If MODE is | |
195 | nil, BINDINGS will be defined locally in the current buffer, in | |
196 | variable `mode-local-symbol-table'. The later should be done in MODE | |
197 | hook." | |
198 | ;; Check plist consistency | |
199 | (and (plist-get plist 'mode-variable-flag) | |
200 | (plist-get plist 'override-flag) | |
201 | (error "Bindings can't be both overrides and mode variables")) | |
202 | (let (table variable varname value binding) | |
203 | (if mode | |
204 | (progn | |
205 | ;; Install in given MODE symbol table. Create a new one if | |
206 | ;; needed. | |
207 | (setq table (or (get mode 'mode-local-symbol-table) | |
208 | (new-mode-local-bindings))) | |
209 | (put mode 'mode-local-symbol-table table)) | |
210 | ;; Fail if trying to bind mode variables in local context! | |
211 | (if (plist-get plist 'mode-variable-flag) | |
212 | (error "Mode required to bind mode variables")) | |
213 | ;; Install in buffer local symbol table. Create a new one if | |
214 | ;; needed. | |
215 | (setq table (or mode-local-symbol-table | |
216 | (setq mode-local-symbol-table | |
217 | (new-mode-local-bindings))))) | |
218 | (while bindings | |
219 | (setq binding (car bindings) | |
220 | bindings (cdr bindings) | |
221 | varname (symbol-name (car binding)) | |
222 | value (cdr binding)) | |
223 | (if (setq variable (intern-soft varname table)) | |
224 | ;; Binding already exists | |
225 | ;; Check rebind consistency | |
226 | (cond | |
227 | ((equal (symbol-value variable) value) | |
228 | ;; Just ignore rebind with the same value. | |
229 | ) | |
230 | ((get variable 'constant-flag) | |
231 | (error "Can't change the value of constant `%s'" | |
232 | variable)) | |
233 | ((and (get variable 'mode-variable-flag) | |
234 | (plist-get plist 'override-flag)) | |
235 | (error "Can't rebind override `%s' as a mode variable" | |
236 | variable)) | |
237 | ((and (get variable 'override-flag) | |
238 | (plist-get plist 'mode-variable-flag)) | |
239 | (error "Can't rebind mode variable `%s' as an override" | |
240 | variable)) | |
241 | (t | |
242 | ;; Merge plist and assign new value | |
243 | (setplist variable (append plist (symbol-plist variable))) | |
244 | (set variable value))) | |
245 | ;; New binding | |
246 | (setq variable (intern varname table)) | |
247 | ;; Set new plist and assign initial value | |
248 | (setplist variable plist) | |
249 | (set variable value))) | |
250 | ;; Return the symbol table used | |
251 | table)) | |
252 | ||
253 | (defsubst mode-local-symbol (symbol &optional mode) | |
254 | "Return the mode local symbol bound with SYMBOL's name. | |
255 | Return nil if the mode local symbol doesn't exist. | |
256 | If optional argument MODE is nil, lookup first into locally bound | |
257 | symbols, then in those bound in current `major-mode' and its parents. | |
258 | If MODE is non-nil, lookup into symbols bound in that major mode and | |
259 | its parents." | |
260 | (let ((name (symbol-name symbol)) bind) | |
261 | (or mode | |
262 | (setq mode mode-local-active-mode) | |
263 | (setq mode major-mode | |
264 | bind (and mode-local-symbol-table | |
265 | (intern-soft name mode-local-symbol-table)))) | |
266 | (while (and mode (not bind)) | |
267 | (or (and (get mode 'mode-local-symbol-table) | |
268 | (setq bind (intern-soft | |
269 | name (get mode 'mode-local-symbol-table)))) | |
270 | (setq mode (get-mode-local-parent mode)))) | |
271 | bind)) | |
272 | ||
273 | (defsubst mode-local-symbol-value (symbol &optional mode property) | |
274 | "Return the value of the mode local symbol bound with SYMBOL's name. | |
275 | If optional argument MODE is non-nil, restrict lookup to that mode and | |
276 | its parents (see the function `mode-local-symbol' for more details). | |
277 | If optional argument PROPERTY is non-nil the mode local symbol must | |
278 | have that property set. Return nil if the symbol doesn't exist, or | |
279 | doesn't have PROPERTY set." | |
280 | (and (setq symbol (mode-local-symbol symbol mode)) | |
281 | (or (not property) (get symbol property)) | |
282 | (symbol-value symbol))) | |
283 | \f | |
284 | ;;; Mode local variables | |
285 | ;; | |
286 | (defun activate-mode-local-bindings (&optional mode) | |
287 | "Activate variables defined locally in MODE and its parents. | |
288 | That is, copy mode local bindings into corresponding buffer local | |
289 | variables. | |
290 | If MODE is not specified it defaults to current `major-mode'. | |
291 | Return the alist of buffer-local variables that have been changed. | |
292 | Elements are (SYMBOL . PREVIOUS-VALUE), describing one variable." | |
293 | ;; Hack - | |
294 | ;; do not do this if we are inside set-auto-mode as we may be in | |
295 | ;; an initialization race condition. | |
296 | (if (or (and (featurep 'emacs) (boundp 'keep-mode-if-same)) | |
297 | (and (featurep 'xemacs) (boundp 'just-from-file-name))) | |
298 | ;; We are inside set-auto-mode, as this is an argument that is | |
299 | ;; vaguely unique. | |
300 | ||
301 | ;; This will make sure that when everything is over, this will get | |
302 | ;; called and we won't be under set-auto-mode anymore. | |
303 | (mode-local-on-major-mode-change) | |
304 | ||
305 | ;; Do the normal thing. | |
306 | (let (modes table old-locals) | |
307 | (unless mode | |
308 | (set (make-local-variable 'mode-local--init-mode) major-mode) | |
309 | (setq mode major-mode)) | |
310 | ;; Get MODE's parents & MODE in the right order. | |
311 | (while mode | |
312 | (setq modes (cons mode modes) | |
313 | mode (get-mode-local-parent mode))) | |
314 | ;; Activate mode bindings following parent modes order. | |
315 | (dolist (mode modes) | |
316 | (when (setq table (get mode 'mode-local-symbol-table)) | |
317 | (mapatoms | |
318 | #'(lambda (var) | |
319 | (when (get var 'mode-variable-flag) | |
320 | (let ((v (intern (symbol-name var)))) | |
321 | ;; Save the current buffer-local value of the | |
322 | ;; mode-local variable. | |
323 | (and (local-variable-p v (current-buffer)) | |
324 | (push (cons v (symbol-value v)) old-locals)) | |
325 | (set (make-local-variable v) (symbol-value var))))) | |
326 | table))) | |
327 | old-locals))) | |
328 | ||
329 | (defun deactivate-mode-local-bindings (&optional mode) | |
330 | "Deactivate variables defined locally in MODE and its parents. | |
331 | That is, kill buffer local variables set from the corresponding mode | |
332 | local bindings. | |
333 | If MODE is not specified it defaults to current `major-mode'." | |
334 | (unless mode | |
335 | (kill-local-variable 'mode-local--init-mode) | |
336 | (setq mode major-mode)) | |
337 | (let (table) | |
338 | (while mode | |
339 | (when (setq table (get mode 'mode-local-symbol-table)) | |
340 | (mapatoms | |
341 | #'(lambda (var) | |
342 | (when (get var 'mode-variable-flag) | |
343 | (kill-local-variable (intern (symbol-name var))))) | |
344 | table)) | |
345 | (setq mode (get-mode-local-parent mode))))) | |
346 | ||
347 | (defmacro with-mode-local-symbol (mode &rest body) | |
348 | "With the local bindings of MODE symbol, evaluate BODY. | |
349 | The current mode bindings are saved, BODY is evaluated, and the saved | |
350 | bindings are restored, even in case of an abnormal exit. | |
351 | Value is what BODY returns. | |
352 | This is like `with-mode-local', except that MODE's value is used. | |
353 | To use the symbol MODE (quoted), use `with-mode-local'." | |
354 | (let ((old-mode (make-symbol "mode")) | |
355 | (old-locals (make-symbol "old-locals")) | |
356 | (new-mode (make-symbol "new-mode")) | |
357 | (local (make-symbol "local"))) | |
358 | `(let ((,old-mode mode-local-active-mode) | |
359 | (,old-locals nil) | |
360 | (,new-mode ,mode) | |
361 | ) | |
362 | (unwind-protect | |
363 | (progn | |
364 | (deactivate-mode-local-bindings ,old-mode) | |
365 | (setq mode-local-active-mode ,new-mode) | |
366 | ;; Save the previous value of buffer-local variables | |
367 | ;; changed by `activate-mode-local-bindings'. | |
368 | (setq ,old-locals (activate-mode-local-bindings ,new-mode)) | |
369 | ,@body) | |
370 | (deactivate-mode-local-bindings ,new-mode) | |
371 | ;; Restore the previous value of buffer-local variables. | |
372 | (dolist (,local ,old-locals) | |
373 | (set (car ,local) (cdr ,local))) | |
374 | ;; Restore the mode local variables. | |
375 | (setq mode-local-active-mode ,old-mode) | |
376 | (activate-mode-local-bindings ,old-mode))))) | |
377 | (put 'with-mode-local-symbol 'lisp-indent-function 1) | |
378 | ||
379 | (defmacro with-mode-local (mode &rest body) | |
380 | "With the local bindings of MODE, evaluate BODY. | |
381 | The current mode bindings are saved, BODY is evaluated, and the saved | |
382 | bindings are restored, even in case of an abnormal exit. | |
383 | Value is what BODY returns. | |
df8fff6c | 384 | This is like `with-mode-local-symbol', except that MODE is quoted |
8b68d2df | 385 | and is not evaluated." |
7b232be9 CY |
386 | `(with-mode-local-symbol ',mode ,@body)) |
387 | (put 'with-mode-local 'lisp-indent-function 1) | |
388 | ||
389 | ||
390 | (defsubst mode-local-value (mode sym) | |
391 | "Return the value of the MODE local variable SYM." | |
392 | (or mode (error "Missing major mode symbol")) | |
393 | (mode-local-symbol-value sym mode 'mode-variable-flag)) | |
394 | ||
395 | (defmacro setq-mode-local (mode &rest args) | |
396 | "Assign new values to variables local in MODE. | |
397 | MODE must be a major mode symbol. | |
398 | ARGS is a list (SYM VAL SYM VAL ...). | |
399 | The symbols SYM are variables; they are literal (not evaluated). | |
400 | The values VAL are expressions; they are evaluated. | |
401 | Set each SYM to the value of its VAL, locally in buffers already in | |
402 | MODE, or in buffers switched to that mode. | |
403 | Return the value of the last VAL." | |
404 | (when args | |
405 | (let (i ll bl sl tmp sym val) | |
406 | (setq i 0) | |
407 | (while args | |
408 | (setq tmp (make-symbol (format "tmp%d" i)) | |
409 | i (1+ i) | |
410 | sym (car args) | |
411 | val (cadr args) | |
412 | ll (cons (list tmp val) ll) | |
413 | bl (cons `(cons ',sym ,tmp) bl) | |
414 | sl (cons `(set (make-local-variable ',sym) ,tmp) sl) | |
415 | args (cddr args))) | |
416 | `(let* ,(nreverse ll) | |
417 | ;; Save mode bindings | |
418 | (mode-local-bind (list ,@bl) '(mode-variable-flag t) ',mode) | |
419 | ;; Assign to local variables in all existing buffers in MODE | |
420 | (mode-local-map-mode-buffers #'(lambda () ,@sl) ',mode) | |
421 | ;; Return the last value | |
422 | ,tmp) | |
423 | ))) | |
424 | ||
425 | (defmacro defvar-mode-local (mode sym val &optional docstring) | |
426 | "Define MODE local variable SYM with value VAL. | |
427 | DOCSTRING is optional." | |
428 | `(progn | |
429 | (setq-mode-local ,mode ,sym ,val) | |
430 | (put (mode-local-symbol ',sym ',mode) | |
431 | 'variable-documentation ,docstring) | |
432 | ',sym)) | |
433 | (put 'defvar-mode-local 'lisp-indent-function 'defun) | |
434 | ||
435 | (defmacro defconst-mode-local (mode sym val &optional docstring) | |
436 | "Define MODE local constant SYM with value VAL. | |
437 | DOCSTRING is optional." | |
438 | (let ((tmp (make-symbol "tmp"))) | |
439 | `(let (,tmp) | |
440 | (setq-mode-local ,mode ,sym ,val) | |
441 | (setq ,tmp (mode-local-symbol ',sym ',mode)) | |
442 | (put ,tmp 'constant-flag t) | |
443 | (put ,tmp 'variable-documentation ,docstring) | |
444 | ',sym))) | |
445 | (put 'defconst-mode-local 'lisp-indent-function 'defun) | |
446 | \f | |
447 | ;;; Function overloading | |
448 | ;; | |
5a916e35 SM |
449 | (defun make-obsolete-overload (old new when) |
450 | "Mark OLD overload as obsoleted by NEW overload. | |
451 | WHEN is a string describing the first release where it was made obsolete." | |
7b232be9 | 452 | (put old 'overload-obsoleted-by new) |
5a916e35 | 453 | (put old 'overload-obsoleted-since when) |
7b232be9 CY |
454 | (put old 'mode-local-overload t) |
455 | (put new 'overload-obsolete old)) | |
456 | ||
457 | (defsubst overload-obsoleted-by (overload) | |
458 | "Get the overload symbol obsoleted by OVERLOAD. | |
459 | Return the obsolete symbol or nil if not found." | |
460 | (get overload 'overload-obsolete)) | |
461 | ||
462 | (defsubst overload-that-obsolete (overload) | |
463 | "Return the overload symbol that obsoletes OVERLOAD. | |
464 | Return the symbol found or nil if OVERLOAD is not obsolete." | |
465 | (get overload 'overload-obsoleted-by)) | |
466 | ||
467 | (defsubst fetch-overload (overload) | |
468 | "Return the current OVERLOAD function, or nil if not found. | |
469 | First, lookup for OVERLOAD into locally bound mode local symbols, then | |
470 | in those bound in current `major-mode' and its parents." | |
471 | (or (mode-local-symbol-value overload nil 'override-flag) | |
472 | ;; If an obsolete overload symbol exists, try it. | |
473 | (and (overload-obsoleted-by overload) | |
474 | (mode-local-symbol-value | |
475 | (overload-obsoleted-by overload) nil 'override-flag)))) | |
476 | ||
477 | (defun mode-local--override (name args body) | |
478 | "Return the form that handles overloading of function NAME. | |
479 | ARGS are the arguments to the function. | |
480 | BODY is code that would be run when there is no override defined. The | |
481 | default is to call the function `NAME-default' with the appropriate | |
482 | arguments. | |
483 | See also the function `define-overload'." | |
484 | (let* ((default (intern (format "%s-default" name))) | |
485 | (overargs (delq '&rest (delq '&optional (copy-sequence args)))) | |
486 | (override (make-symbol "override"))) | |
487 | `(let ((,override (fetch-overload ',name))) | |
488 | (if ,override | |
489 | (funcall ,override ,@overargs) | |
490 | ,@(or body `((,default ,@overargs))))) | |
491 | )) | |
492 | ||
493 | (defun mode-local--expand-overrides (name args body) | |
494 | "Expand override forms that overload function NAME. | |
495 | ARGS are the arguments to the function NAME. | |
496 | BODY is code where override forms are searched for expansion. | |
497 | Return result of expansion, or BODY if no expansion occurred. | |
498 | See also the function `define-overload'." | |
499 | (let ((forms body) | |
500 | (ditto t) | |
501 | form xbody) | |
502 | (while forms | |
503 | (setq form (car forms)) | |
504 | (cond | |
505 | ((atom form)) | |
506 | ((eq (car form) :override) | |
507 | (setq form (mode-local--override name args (cdr form)))) | |
508 | ((eq (car form) :override-with-args) | |
509 | (setq form (mode-local--override name (cadr form) (cddr form)))) | |
510 | ((setq form (mode-local--expand-overrides name args form)))) | |
511 | (setq ditto (and ditto (eq (car forms) form)) | |
512 | xbody (cons form xbody) | |
513 | forms (cdr forms))) | |
514 | (if ditto body (nreverse xbody)))) | |
515 | ||
516 | (defun mode-local--overload-body (name args body) | |
517 | "Return the code that implements overloading of function NAME. | |
518 | ARGS are the arguments to the function NAME. | |
519 | BODY specifies the overload code. | |
520 | See also the function `define-overload'." | |
521 | (let ((result (mode-local--expand-overrides name args body))) | |
522 | (if (eq body result) | |
523 | (list (mode-local--override name args body)) | |
524 | result))) | |
525 | ||
526 | (defmacro define-overloadable-function (name args docstring &rest body) | |
527 | "Define a new function, as with `defun' which can be overloaded. | |
528 | NAME is the name of the function to create. | |
529 | ARGS are the arguments to the function. | |
530 | DOCSTRING is a documentation string to describe the function. The | |
531 | docstring will automatically had details about its overload symbol | |
532 | appended to the end. | |
533 | BODY is code that would be run when there is no override defined. The | |
534 | default is to call the function `NAME-default' with the appropriate | |
535 | arguments. | |
536 | ||
537 | BODY can also include an override form that specifies which part of | |
538 | BODY is specifically overridden. This permits to specify common code | |
539 | run for both default and overridden implementations. | |
540 | An override form is one of: | |
541 | ||
542 | 1. (:override [OVERBODY]) | |
543 | 2. (:override-with-args OVERARGS [OVERBODY]) | |
544 | ||
545 | OVERBODY is the code that would be run when there is no override | |
546 | defined. The default is to call the function `NAME-default' with the | |
547 | appropriate arguments deduced from ARGS. | |
548 | OVERARGS is a list of arguments passed to the override and | |
549 | `NAME-default' function, in place of those deduced from ARGS." | |
550 | `(eval-and-compile | |
551 | (defun ,name ,args | |
552 | ,docstring | |
553 | ,@(mode-local--overload-body name args body)) | |
554 | (put ',name 'mode-local-overload t))) | |
555 | (put :override-with-args 'lisp-indent-function 1) | |
556 | ||
557 | (defalias 'define-overload 'define-overloadable-function) | |
558 | ||
559 | (defsubst function-overload-p (symbol) | |
560 | "Return non-nil if SYMBOL is a function which can be overloaded." | |
561 | (and symbol (symbolp symbol) (get symbol 'mode-local-overload))) | |
562 | ||
563 | (defmacro define-mode-local-override | |
564 | (name mode args docstring &rest body) | |
565 | "Define a mode specific override of the function overload NAME. | |
566 | Has meaning only if NAME has been created with `define-overload'. | |
567 | MODE is the major mode this override is being defined for. | |
568 | ARGS are the function arguments, which should match those of the same | |
569 | named function created with `define-overload'. | |
570 | DOCSTRING is the documentation string. | |
571 | BODY is the implementation of this function." | |
572 | (let ((newname (intern (format "%s-%s" name mode)))) | |
573 | `(progn | |
574 | (eval-and-compile | |
575 | (defun ,newname ,args | |
576 | ,(format "%s\n\nOverride %s in `%s' buffers." | |
577 | docstring name mode) | |
578 | ;; The body for this implementation | |
579 | ,@body) | |
580 | ;; For find-func to locate the definition of NEWNAME. | |
581 | (put ',newname 'definition-name ',name)) | |
582 | (mode-local-bind '((,name . ,newname)) | |
583 | '(override-flag t) | |
584 | ',mode)) | |
585 | )) | |
586 | \f | |
587 | ;;; Read/Query Support | |
588 | (defun mode-local-read-function (prompt &optional initial hist default) | |
589 | "Interactively read in the name of a mode-local function. | |
590 | PROMPT, INITIAL, HIST, and DEFAULT are the same as for `completing-read'." | |
591 | (completing-read prompt obarray 'function-overload-p t initial hist default)) | |
592 | \f | |
593 | ;;; Help support | |
594 | ;; | |
595 | (defun overload-docstring-extension (overload) | |
596 | "Return the doc string that augments the description of OVERLOAD." | |
597 | (let ((doc "\n\This function can be overloaded\ | |
598 | with `define-mode-local-override'.") | |
599 | (sym (overload-obsoleted-by overload))) | |
600 | (when sym | |
5a916e35 SM |
601 | (setq doc (format "%s\nIt has made the overload `%s' obsolete since %s." |
602 | doc sym (get sym 'overload-obsoleted-since)))) | |
7b232be9 CY |
603 | (setq sym (overload-that-obsolete overload)) |
604 | (when sym | |
5a916e35 SM |
605 | (setq doc (format "%s\nThis overload is obsolete since %s;\nUse `%s' instead." |
606 | doc (get overload 'overload-obsoleted-since) sym))) | |
7b232be9 CY |
607 | doc)) |
608 | ||
609 | (defun mode-local-augment-function-help (symbol) | |
610 | "Augment the *Help* buffer for SYMBOL. | |
611 | SYMBOL is a function that can be overridden." | |
612 | (with-current-buffer "*Help*" | |
613 | (pop-to-buffer (current-buffer)) | |
d2ce10d2 GM |
614 | (goto-char (point-min)) |
615 | (unless (re-search-forward "^$" nil t) | |
616 | (goto-char (point-max)) | |
617 | (beginning-of-line) | |
618 | (forward-line -1)) | |
619 | (let ((inhibit-read-only t)) | |
620 | (insert (overload-docstring-extension symbol) "\n") | |
621 | ;; NOTE TO SELF: | |
622 | ;; LIST ALL LOADED OVERRIDES FOR SYMBOL HERE | |
623 | ))) | |
7b232be9 CY |
624 | |
625 | ;; Help for mode-local bindings. | |
626 | (defun mode-local-print-binding (symbol) | |
627 | "Print the SYMBOL binding." | |
628 | (let ((value (symbol-value symbol))) | |
629 | (princ (format "\n `%s' value is\n " symbol)) | |
630 | (if (and value (symbolp value)) | |
631 | (princ (format "`%s'" value)) | |
632 | (let ((pt (point))) | |
633 | (pp value) | |
634 | (save-excursion | |
635 | (goto-char pt) | |
636 | (indent-sexp)))) | |
637 | (or (bolp) (princ "\n")))) | |
638 | ||
639 | (defun mode-local-print-bindings (table) | |
640 | "Print bindings in TABLE." | |
641 | (let (us ;; List of unpecified symbols | |
642 | mc ;; List of mode local constants | |
643 | mv ;; List of mode local variables | |
644 | ov ;; List of overloaded functions | |
645 | fo ;; List of final overloaded functions | |
646 | ) | |
647 | ;; Order symbols by type | |
648 | (mapatoms | |
649 | #'(lambda (s) | |
650 | (add-to-list (cond | |
651 | ((get s 'mode-variable-flag) | |
652 | (if (get s 'constant-flag) 'mc 'mv)) | |
653 | ((get s 'override-flag) | |
654 | (if (get s 'constant-flag) 'fo 'ov)) | |
655 | ('us)) | |
656 | s)) | |
657 | table) | |
658 | ;; Print symbols by type | |
659 | (when us | |
660 | (princ "\n !! Unpecified symbols\n") | |
661 | (mapc 'mode-local-print-binding us)) | |
662 | (when mc | |
663 | (princ "\n ** Mode local constants\n") | |
664 | (mapc 'mode-local-print-binding mc)) | |
665 | (when mv | |
666 | (princ "\n ** Mode local variables\n") | |
667 | (mapc 'mode-local-print-binding mv)) | |
668 | (when fo | |
669 | (princ "\n ** Final overloaded functions\n") | |
670 | (mapc 'mode-local-print-binding fo)) | |
671 | (when ov | |
672 | (princ "\n ** Overloaded functions\n") | |
673 | (mapc 'mode-local-print-binding ov)) | |
674 | )) | |
675 | ||
676 | (defun mode-local-describe-bindings-2 (buffer-or-mode) | |
677 | "Display mode local bindings active in BUFFER-OR-MODE." | |
678 | (let (table mode) | |
679 | (princ "Mode local bindings active in ") | |
680 | (cond | |
681 | ((bufferp buffer-or-mode) | |
682 | (with-current-buffer buffer-or-mode | |
683 | (setq table mode-local-symbol-table | |
684 | mode major-mode)) | |
685 | (princ (format "%S\n" buffer-or-mode)) | |
686 | ) | |
687 | ((symbolp buffer-or-mode) | |
688 | (setq mode buffer-or-mode) | |
689 | (princ (format "`%s'\n" buffer-or-mode)) | |
690 | ) | |
691 | ((signal 'wrong-type-argument | |
692 | (list 'buffer-or-mode buffer-or-mode)))) | |
693 | (when table | |
694 | (princ "\n- Buffer local\n") | |
695 | (mode-local-print-bindings table)) | |
696 | (while mode | |
697 | (setq table (get mode 'mode-local-symbol-table)) | |
698 | (when table | |
699 | (princ (format "\n- From `%s'\n" mode)) | |
700 | (mode-local-print-bindings table)) | |
701 | (setq mode (get-mode-local-parent mode))))) | |
702 | ||
703 | (defun mode-local-describe-bindings-1 (buffer-or-mode &optional interactive-p) | |
704 | "Display mode local bindings active in BUFFER-OR-MODE. | |
705 | Optional argument INTERACTIVE-P is non-nil if the calling command was | |
706 | invoked interactively." | |
707 | (if (fboundp 'with-displaying-help-buffer) | |
708 | ;; XEmacs | |
709 | (with-displaying-help-buffer | |
710 | #'(lambda () | |
711 | (with-current-buffer standard-output | |
712 | (mode-local-describe-bindings-2 buffer-or-mode) | |
713 | (when (fboundp 'frob-help-extents) | |
714 | (goto-char (point-min)) | |
715 | (frob-help-extents standard-output))))) | |
716 | ;; GNU Emacs | |
717 | (when (fboundp 'help-setup-xref) | |
718 | (help-setup-xref | |
719 | (list 'mode-local-describe-bindings-1 buffer-or-mode) | |
720 | interactive-p)) | |
721 | (with-output-to-temp-buffer (help-buffer) ; "*Help*" | |
722 | (with-current-buffer standard-output | |
723 | (mode-local-describe-bindings-2 buffer-or-mode))))) | |
724 | ||
725 | (defun describe-mode-local-bindings (buffer) | |
726 | "Display mode local bindings active in BUFFER." | |
727 | (interactive "b") | |
728 | (when (setq buffer (get-buffer buffer)) | |
2054a44c | 729 | (mode-local-describe-bindings-1 buffer (called-interactively-p 'any)))) |
7b232be9 CY |
730 | |
731 | (defun describe-mode-local-bindings-in-mode (mode) | |
732 | "Display mode local bindings active in MODE hierarchy." | |
733 | (interactive | |
734 | (list (completing-read | |
735 | "Mode: " obarray | |
736 | #'(lambda (s) (get s 'mode-local-symbol-table)) | |
737 | t (symbol-name major-mode)))) | |
738 | (when (setq mode (intern-soft mode)) | |
2054a44c | 739 | (mode-local-describe-bindings-1 mode (called-interactively-p 'any)))) |
7b232be9 CY |
740 | \f |
741 | ;; ;;; find-func support (Emacs 21.4, or perhaps 22.1) | |
742 | ;; ;; | |
743 | ;; (condition-case nil | |
744 | ;; ;; Try to get find-func so we can modify it. | |
745 | ;; (require 'find-func) | |
746 | ;; (error nil)) | |
747 | ||
748 | ;; (when (boundp 'find-function-regexp) | |
749 | ;; (unless (string-match "ine-overload" find-function-regexp) | |
750 | ;; (if (string-match "(def\\\\(" find-function-regexp) | |
751 | ;; (let ((end (match-end 0)) | |
752 | ;; ) | |
753 | ;; (setq find-function-regexp | |
754 | ;; (concat (substring find-function-regexp 0 end) | |
755 | ;; "ine-overload\\|ine-mode-local-override\\|" | |
756 | ;; "ine-child-mode\\|" | |
757 | ;; (substring find-function-regexp end))))))) | |
758 | \f | |
759 | ;;; edebug support | |
760 | ;; | |
761 | (defun mode-local-setup-edebug-specs () | |
762 | "Define edebug specification for mode local macros." | |
763 | (def-edebug-spec setq-mode-local | |
764 | (symbolp &rest symbolp form)) | |
765 | (def-edebug-spec defvar-mode-local | |
766 | (&define symbolp name def-form [ &optional stringp ] )) | |
767 | (def-edebug-spec defconst-mode-local | |
768 | defvar-mode-local) | |
769 | (def-edebug-spec define-overload | |
770 | (&define name lambda-list stringp def-body)) | |
771 | (def-edebug-spec define-overloadable-function | |
772 | (&define name lambda-list stringp def-body)) | |
773 | (def-edebug-spec define-mode-local-override | |
774 | (&define name symbolp lambda-list stringp def-body))) | |
775 | ||
776 | (add-hook 'edebug-setup-hook 'mode-local-setup-edebug-specs) | |
777 | ||
778 | (add-hook 'find-file-hook 'mode-local-post-major-mode-change) | |
779 | (add-hook 'change-major-mode-hook 'mode-local-on-major-mode-change) | |
780 | ||
781 | (provide 'mode-local) | |
782 | ||
783 | ;;; mode-local.el ends here |