Mercurial > emacs
annotate lisp/cedet/mode-local.el @ 104511:afd748c5780c
Use find-file-hook instead of obsolete name find-file-hooks.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Mon, 21 Sep 2009 18:24:56 +0000 |
parents | 32af6b5a433d |
children |
rev | line source |
---|---|
104410 | 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 ;;; Misc utilities | |
54 ;; | |
55 (defun mode-local-map-file-buffers (function &optional predicate buffers) | |
56 "Run FUNCTION on every file buffer found. | |
57 FUNCTION does not have arguments; when it is entered `current-buffer' | |
58 is the currently selected file buffer. | |
59 If optional argument PREDICATE is non nil, only select file buffers | |
60 for which the function PREDICATE return non-nil. | |
61 If optional argument BUFFERS is non-nil, it is a list of buffers to | |
62 walk through. It defaults to `buffer-list'." | |
63 (dolist (b (or buffers (buffer-list))) | |
64 (and (buffer-live-p b) (buffer-file-name b) | |
65 (with-current-buffer b | |
66 (when (or (not predicate) (funcall predicate)) | |
67 (funcall function)))))) | |
68 | |
69 (defsubst get-mode-local-parent (mode) | |
70 "Return the mode parent of the major mode MODE. | |
71 Return nil if MODE has no parent." | |
72 (or (get mode 'mode-local-parent) | |
73 (get mode 'derived-mode-parent))) | |
74 | |
75 (defun mode-local-equivalent-mode-p (mode) | |
76 "Is the major-mode in the current buffer equivalent to a mode in MODES." | |
77 (let ((modes nil)) | |
78 (while mode | |
79 (setq modes (cons mode modes) | |
80 mode (get-mode-local-parent mode))) | |
81 modes)) | |
82 | |
83 (defun mode-local-map-mode-buffers (function modes) | |
84 "Run FUNCTION on every file buffer with major mode in MODES. | |
85 MODES can be a symbol or a list of symbols. | |
86 FUNCTION does not have arguments." | |
87 (or (listp modes) (setq modes (list modes))) | |
88 (mode-local-map-file-buffers | |
89 function #'(lambda () | |
90 (let ((mm (mode-local-equivalent-mode-p major-mode)) | |
91 (ans nil)) | |
92 (while (and (not ans) mm) | |
93 (setq ans (memq (car mm) modes) | |
94 mm (cdr mm)) ) | |
95 ans)))) | |
96 | |
97 ;;; Hook machinery | |
98 ;; | |
99 (defvar mode-local-init-hook nil | |
100 "Hook run after a new file buffer is created. | |
101 The current buffer is the newly created file buffer.") | |
102 | |
103 (defvar mode-local-changed-mode-buffers nil | |
104 "List of buffers whose `major-mode' has changed recently.") | |
105 | |
106 (defvar mode-local--init-mode nil) | |
107 | |
108 (defsubst mode-local-initialized-p () | |
109 "Return non-nil if mode local is initialized in current buffer. | |
110 That is, if the current `major-mode' is equal to the major mode for | |
111 which mode local bindings have been activated." | |
112 (eq mode-local--init-mode major-mode)) | |
113 | |
114 (defun mode-local-post-major-mode-change () | |
115 "`post-command-hook' run when there is a `major-mode' change. | |
116 This makes sure mode local init type stuff can occur." | |
117 (remove-hook 'post-command-hook 'mode-local-post-major-mode-change nil) | |
118 (let ((buffers mode-local-changed-mode-buffers)) | |
119 (setq mode-local-changed-mode-buffers nil) | |
120 (mode-local-map-file-buffers | |
121 #'(lambda () | |
122 ;; Make sure variables are set up for this mode. | |
123 (activate-mode-local-bindings) | |
124 (run-hooks 'mode-local-init-hook)) | |
125 #'(lambda () | |
126 (not (mode-local-initialized-p))) | |
127 buffers))) | |
128 | |
129 (defun mode-local-on-major-mode-change () | |
130 "Function called in `change-major-mode-hook'." | |
131 (add-to-list 'mode-local-changed-mode-buffers (current-buffer)) | |
132 (add-hook 'post-command-hook 'mode-local-post-major-mode-change t nil)) | |
133 | |
104511
afd748c5780c
Use find-file-hook instead of obsolete name find-file-hooks.
Chong Yidong <cyd@stupidchicken.com>
parents:
104509
diff
changeset
|
134 (add-hook 'find-file-hook 'mode-local-post-major-mode-change) |
104410 | 135 (add-hook 'change-major-mode-hook 'mode-local-on-major-mode-change) |
136 | |
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 | |
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 | |
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. | |
384 This lis like `with-mode-local-symbol', except that MODE is quoted | |
385 and is note evaluated." | |
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 | |
447 ;;; Function overloading | |
448 ;; | |
449 (defun make-obsolete-overload (old new) | |
450 "Mark OLD overload as obsoleted by NEW overload." | |
451 (put old 'overload-obsoleted-by new) | |
452 (put old 'mode-local-overload t) | |
453 (put new 'overload-obsolete old)) | |
454 | |
455 (defsubst overload-obsoleted-by (overload) | |
456 "Get the overload symbol obsoleted by OVERLOAD. | |
457 Return the obsolete symbol or nil if not found." | |
458 (get overload 'overload-obsolete)) | |
459 | |
460 (defsubst overload-that-obsolete (overload) | |
461 "Return the overload symbol that obsoletes OVERLOAD. | |
462 Return the symbol found or nil if OVERLOAD is not obsolete." | |
463 (get overload 'overload-obsoleted-by)) | |
464 | |
465 (defsubst fetch-overload (overload) | |
466 "Return the current OVERLOAD function, or nil if not found. | |
467 First, lookup for OVERLOAD into locally bound mode local symbols, then | |
468 in those bound in current `major-mode' and its parents." | |
469 (or (mode-local-symbol-value overload nil 'override-flag) | |
470 ;; If an obsolete overload symbol exists, try it. | |
471 (and (overload-obsoleted-by overload) | |
472 (mode-local-symbol-value | |
473 (overload-obsoleted-by overload) nil 'override-flag)))) | |
474 | |
475 (defun mode-local--override (name args body) | |
476 "Return the form that handles overloading of function NAME. | |
477 ARGS are the arguments to the function. | |
478 BODY is code that would be run when there is no override defined. The | |
479 default is to call the function `NAME-default' with the appropriate | |
480 arguments. | |
481 See also the function `define-overload'." | |
482 (let* ((default (intern (format "%s-default" name))) | |
483 (overargs (delq '&rest (delq '&optional (copy-sequence args)))) | |
484 (override (make-symbol "override"))) | |
485 `(let ((,override (fetch-overload ',name))) | |
486 (if ,override | |
487 (funcall ,override ,@overargs) | |
488 ,@(or body `((,default ,@overargs))))) | |
489 )) | |
490 | |
491 (defun mode-local--expand-overrides (name args body) | |
492 "Expand override forms that overload function NAME. | |
493 ARGS are the arguments to the function NAME. | |
494 BODY is code where override forms are searched for expansion. | |
495 Return result of expansion, or BODY if no expansion occurred. | |
496 See also the function `define-overload'." | |
497 (let ((forms body) | |
498 (ditto t) | |
499 form xbody) | |
500 (while forms | |
501 (setq form (car forms)) | |
502 (cond | |
503 ((atom form)) | |
504 ((eq (car form) :override) | |
505 (setq form (mode-local--override name args (cdr form)))) | |
506 ((eq (car form) :override-with-args) | |
507 (setq form (mode-local--override name (cadr form) (cddr form)))) | |
508 ((setq form (mode-local--expand-overrides name args form)))) | |
509 (setq ditto (and ditto (eq (car forms) form)) | |
510 xbody (cons form xbody) | |
511 forms (cdr forms))) | |
512 (if ditto body (nreverse xbody)))) | |
513 | |
514 (defun mode-local--overload-body (name args body) | |
515 "Return the code that implements overloading of function NAME. | |
516 ARGS are the arguments to the function NAME. | |
517 BODY specifies the overload code. | |
518 See also the function `define-overload'." | |
519 (let ((result (mode-local--expand-overrides name args body))) | |
520 (if (eq body result) | |
521 (list (mode-local--override name args body)) | |
522 result))) | |
523 | |
524 (defmacro define-overloadable-function (name args docstring &rest body) | |
525 "Define a new function, as with `defun' which can be overloaded. | |
526 NAME is the name of the function to create. | |
527 ARGS are the arguments to the function. | |
528 DOCSTRING is a documentation string to describe the function. The | |
529 docstring will automatically had details about its overload symbol | |
530 appended to the end. | |
531 BODY is code that would be run when there is no override defined. The | |
532 default is to call the function `NAME-default' with the appropriate | |
533 arguments. | |
534 | |
535 BODY can also include an override form that specifies which part of | |
536 BODY is specifically overridden. This permits to specify common code | |
537 run for both default and overridden implementations. | |
538 An override form is one of: | |
539 | |
540 1. (:override [OVERBODY]) | |
541 2. (:override-with-args OVERARGS [OVERBODY]) | |
542 | |
543 OVERBODY is the code that would be run when there is no override | |
544 defined. The default is to call the function `NAME-default' with the | |
545 appropriate arguments deduced from ARGS. | |
546 OVERARGS is a list of arguments passed to the override and | |
547 `NAME-default' function, in place of those deduced from ARGS." | |
548 `(eval-and-compile | |
549 (defun ,name ,args | |
550 ,docstring | |
551 ,@(mode-local--overload-body name args body)) | |
552 (put ',name 'mode-local-overload t))) | |
553 (put :override-with-args 'lisp-indent-function 1) | |
554 | |
555 (defalias 'define-overload 'define-overloadable-function) | |
556 | |
557 (defsubst function-overload-p (symbol) | |
558 "Return non-nil if SYMBOL is a function which can be overloaded." | |
559 (and symbol (symbolp symbol) (get symbol 'mode-local-overload))) | |
560 | |
561 (defmacro define-mode-local-override | |
562 (name mode args docstring &rest body) | |
563 "Define a mode specific override of the function overload NAME. | |
564 Has meaning only if NAME has been created with `define-overload'. | |
565 MODE is the major mode this override is being defined for. | |
566 ARGS are the function arguments, which should match those of the same | |
567 named function created with `define-overload'. | |
568 DOCSTRING is the documentation string. | |
569 BODY is the implementation of this function." | |
570 (let ((newname (intern (format "%s-%s" name mode)))) | |
571 `(progn | |
572 (eval-and-compile | |
573 (defun ,newname ,args | |
574 ,(format "%s\n\nOverride %s in `%s' buffers." | |
575 docstring name mode) | |
576 ;; The body for this implementation | |
577 ,@body) | |
578 ;; For find-func to locate the definition of NEWNAME. | |
579 (put ',newname 'definition-name ',name)) | |
580 (mode-local-bind '((,name . ,newname)) | |
581 '(override-flag t) | |
582 ',mode)) | |
583 )) | |
584 | |
585 ;;; Read/Query Support | |
586 (defun mode-local-read-function (prompt &optional initial hist default) | |
587 "Interactively read in the name of a mode-local function. | |
588 PROMPT, INITIAL, HIST, and DEFAULT are the same as for `completing-read'." | |
589 (completing-read prompt obarray 'function-overload-p t initial hist default)) | |
590 | |
591 ;;; Help support | |
592 ;; | |
593 (defun overload-docstring-extension (overload) | |
594 "Return the doc string that augments the description of OVERLOAD." | |
595 (let ((doc "\n\This function can be overloaded\ | |
104509
32af6b5a433d
* help-fns.el (describe-function-1): Call
Chong Yidong <cyd@stupidchicken.com>
parents:
104410
diff
changeset
|
596 with `define-mode-local-override'.") |
104410 | 597 (sym (overload-obsoleted-by overload))) |
598 (when sym | |
599 (setq doc (format "%s\nIt makes the overload `%s' obsolete." | |
600 doc sym))) | |
601 (setq sym (overload-that-obsolete overload)) | |
602 (when sym | |
603 (setq doc (format "%s\nThis overload is obsoletes;\nUse `%s' instead." | |
604 doc sym))) | |
605 doc)) | |
606 | |
607 (defun mode-local-augment-function-help (symbol) | |
608 "Augment the *Help* buffer for SYMBOL. | |
609 SYMBOL is a function that can be overridden." | |
610 (with-current-buffer "*Help*" | |
611 (pop-to-buffer (current-buffer)) | |
612 (unwind-protect | |
613 (progn | |
614 (toggle-read-only -1) | |
615 (goto-char (point-min)) | |
616 (unless (re-search-forward "^$" nil t) | |
617 (goto-char (point-max)) | |
618 (beginning-of-line) | |
619 (forward-line -1)) | |
620 (insert (overload-docstring-extension symbol) "\n") | |
621 ;; NOTE TO SELF: | |
622 ;; LIST ALL LOADED OVERRIDES FOR SYMBOL HERE | |
623 ) | |
624 (toggle-read-only 1)))) | |
625 | |
626 ;; Help for mode-local bindings. | |
627 (defun mode-local-print-binding (symbol) | |
628 "Print the SYMBOL binding." | |
629 (let ((value (symbol-value symbol))) | |
630 (princ (format "\n `%s' value is\n " symbol)) | |
631 (if (and value (symbolp value)) | |
632 (princ (format "`%s'" value)) | |
633 (let ((pt (point))) | |
634 (pp value) | |
635 (save-excursion | |
636 (goto-char pt) | |
637 (indent-sexp)))) | |
638 (or (bolp) (princ "\n")))) | |
639 | |
640 (defun mode-local-print-bindings (table) | |
641 "Print bindings in TABLE." | |
642 (let (us ;; List of unpecified symbols | |
643 mc ;; List of mode local constants | |
644 mv ;; List of mode local variables | |
645 ov ;; List of overloaded functions | |
646 fo ;; List of final overloaded functions | |
647 ) | |
648 ;; Order symbols by type | |
649 (mapatoms | |
650 #'(lambda (s) | |
651 (add-to-list (cond | |
652 ((get s 'mode-variable-flag) | |
653 (if (get s 'constant-flag) 'mc 'mv)) | |
654 ((get s 'override-flag) | |
655 (if (get s 'constant-flag) 'fo 'ov)) | |
656 ('us)) | |
657 s)) | |
658 table) | |
659 ;; Print symbols by type | |
660 (when us | |
661 (princ "\n !! Unpecified symbols\n") | |
662 (mapc 'mode-local-print-binding us)) | |
663 (when mc | |
664 (princ "\n ** Mode local constants\n") | |
665 (mapc 'mode-local-print-binding mc)) | |
666 (when mv | |
667 (princ "\n ** Mode local variables\n") | |
668 (mapc 'mode-local-print-binding mv)) | |
669 (when fo | |
670 (princ "\n ** Final overloaded functions\n") | |
671 (mapc 'mode-local-print-binding fo)) | |
672 (when ov | |
673 (princ "\n ** Overloaded functions\n") | |
674 (mapc 'mode-local-print-binding ov)) | |
675 )) | |
676 | |
677 (defun mode-local-describe-bindings-2 (buffer-or-mode) | |
678 "Display mode local bindings active in BUFFER-OR-MODE." | |
679 (let (table mode) | |
680 (princ "Mode local bindings active in ") | |
681 (cond | |
682 ((bufferp buffer-or-mode) | |
683 (with-current-buffer buffer-or-mode | |
684 (setq table mode-local-symbol-table | |
685 mode major-mode)) | |
686 (princ (format "%S\n" buffer-or-mode)) | |
687 ) | |
688 ((symbolp buffer-or-mode) | |
689 (setq mode buffer-or-mode) | |
690 (princ (format "`%s'\n" buffer-or-mode)) | |
691 ) | |
692 ((signal 'wrong-type-argument | |
693 (list 'buffer-or-mode buffer-or-mode)))) | |
694 (when table | |
695 (princ "\n- Buffer local\n") | |
696 (mode-local-print-bindings table)) | |
697 (while mode | |
698 (setq table (get mode 'mode-local-symbol-table)) | |
699 (when table | |
700 (princ (format "\n- From `%s'\n" mode)) | |
701 (mode-local-print-bindings table)) | |
702 (setq mode (get-mode-local-parent mode))))) | |
703 | |
704 (defun mode-local-describe-bindings-1 (buffer-or-mode &optional interactive-p) | |
705 "Display mode local bindings active in BUFFER-OR-MODE. | |
706 Optional argument INTERACTIVE-P is non-nil if the calling command was | |
707 invoked interactively." | |
708 (if (fboundp 'with-displaying-help-buffer) | |
709 ;; XEmacs | |
710 (with-displaying-help-buffer | |
711 #'(lambda () | |
712 (with-current-buffer standard-output | |
713 (mode-local-describe-bindings-2 buffer-or-mode) | |
714 (when (fboundp 'frob-help-extents) | |
715 (goto-char (point-min)) | |
716 (frob-help-extents standard-output))))) | |
717 ;; GNU Emacs | |
718 (when (fboundp 'help-setup-xref) | |
719 (help-setup-xref | |
720 (list 'mode-local-describe-bindings-1 buffer-or-mode) | |
721 interactive-p)) | |
722 (with-output-to-temp-buffer (help-buffer) ; "*Help*" | |
723 (with-current-buffer standard-output | |
724 (mode-local-describe-bindings-2 buffer-or-mode))))) | |
725 | |
726 (defun describe-mode-local-bindings (buffer) | |
727 "Display mode local bindings active in BUFFER." | |
728 (interactive "b") | |
729 (when (setq buffer (get-buffer buffer)) | |
730 (mode-local-describe-bindings-1 buffer (interactive-p)))) | |
731 | |
732 (defun describe-mode-local-bindings-in-mode (mode) | |
733 "Display mode local bindings active in MODE hierarchy." | |
734 (interactive | |
735 (list (completing-read | |
736 "Mode: " obarray | |
737 #'(lambda (s) (get s 'mode-local-symbol-table)) | |
738 t (symbol-name major-mode)))) | |
739 (when (setq mode (intern-soft mode)) | |
740 (mode-local-describe-bindings-1 mode (interactive-p)))) | |
741 | |
742 ;;; Font-lock support | |
743 ;; | |
744 (defconst mode-local-font-lock-keywords | |
745 (eval-when-compile | |
746 (let* ( | |
747 ;; Variable declarations | |
748 (kv (regexp-opt | |
749 '( | |
750 "defconst-mode-local" | |
751 "defvar-mode-local" | |
752 ) t)) | |
753 ;; Function declarations | |
754 (kf (regexp-opt | |
755 '( | |
756 "define-mode-local-override" | |
757 "define-child-mode" | |
758 "define-overload" | |
759 "define-overloadable-function" | |
760 ;;"make-obsolete-overload" | |
761 "with-mode-local" | |
762 ) t)) | |
763 ;; Regexp depths | |
764 (kv-depth (regexp-opt-depth kv)) | |
765 (kf-depth (regexp-opt-depth kf)) | |
766 ) | |
767 `((,(concat | |
768 ;; Declarative things | |
769 "(\\(" kv "\\|" kf "\\)" | |
770 ;; Whitespaces & names | |
771 "\\>[ \t]*\\(\\sw+\\)?[ \t]*\\(\\sw+\\)?" | |
772 ) | |
773 (1 font-lock-keyword-face) | |
774 (,(+ 1 kv-depth kf-depth 1) | |
775 (cond ((match-beginning 2) | |
776 font-lock-type-face) | |
777 ((match-beginning ,(+ 1 kv-depth 1)) | |
778 font-lock-function-name-face) | |
779 ) | |
780 nil t) | |
781 (,(+ 1 kv-depth kf-depth 1 1) | |
782 (cond ((match-beginning 2) | |
783 font-lock-variable-name-face) | |
784 ) | |
785 nil t))) | |
786 )) | |
787 "Highlighted keywords.") | |
788 | |
789 | |
790 ;;; find-func support (Emacs 21.4, or perhaps 22.1) | |
791 ;; | |
792 (condition-case nil | |
793 ;; Try to get find-func so we can modify it. | |
794 (require 'find-func) | |
795 (error nil)) | |
796 | |
797 (when (boundp 'find-function-regexp) | |
798 (unless (string-match "ine-overload" find-function-regexp) | |
799 (if (string-match "(def\\\\(" find-function-regexp) | |
800 (let ((end (match-end 0)) | |
801 ) | |
802 (setq find-function-regexp | |
803 (concat (substring find-function-regexp 0 end) | |
804 "ine-overload\\|ine-mode-local-override\\|" | |
805 "ine-child-mode\\|" | |
806 (substring find-function-regexp end))))) | |
807 ) | |
808 ;; The regexp for variables is a little more kind. | |
809 ) | |
810 | |
811 ;; TODO: Add XEmacs support | |
812 ;; (when (fboundp 'font-lock-add-keywords) | |
813 ;; (font-lock-add-keywords 'emacs-lisp-mode | |
814 ;; mode-local-font-lock-keywords)) | |
815 | |
816 ;;; edebug support | |
817 ;; | |
818 (defun mode-local-setup-edebug-specs () | |
819 "Define edebug specification for mode local macros." | |
820 (def-edebug-spec setq-mode-local | |
821 (symbolp &rest symbolp form) | |
822 ) | |
823 (def-edebug-spec defvar-mode-local | |
824 (&define symbolp name def-form [ &optional stringp ] ) | |
825 ) | |
826 (def-edebug-spec defconst-mode-local | |
827 defvar-mode-local | |
828 ) | |
829 (def-edebug-spec define-overload | |
830 (&define name lambda-list stringp def-body) | |
831 ) | |
832 (def-edebug-spec define-overloadable-function | |
833 (&define name lambda-list stringp def-body) | |
834 ) | |
835 (def-edebug-spec define-mode-local-override | |
836 (&define name symbolp lambda-list stringp def-body) | |
837 ) | |
838 ) | |
839 | |
840 (add-hook 'edebug-setup-hook 'mode-local-setup-edebug-specs) | |
841 | |
842 (provide 'mode-local) | |
843 | |
844 ;;; mode-local.el ends here |