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