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