| 1 | ;;; mode-local.el --- Support for mode local facilities |
| 2 | ;; |
| 3 | ;; Copyright (C) 2004-2005, 2007-2012 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 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 given 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 returns 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 | |
| 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. |
| 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 inherit 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. |
| 383 | This is like `with-mode-local-symbol', except that MODE is quoted |
| 384 | and is not evaluated." |
| 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 | ;; |
| 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." |
| 451 | (put old 'overload-obsoleted-by new) |
| 452 | (put old 'overload-obsoleted-since when) |
| 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 | ;;;###autoload |
| 526 | (put 'define-overloadable-function 'doc-string-elt 3) |
| 527 | |
| 528 | (defmacro define-overloadable-function (name args docstring &rest body) |
| 529 | "Define a new function, as with `defun', which can be overloaded. |
| 530 | NAME is the name of the function to create. |
| 531 | ARGS are the arguments to the function. |
| 532 | DOCSTRING is a documentation string to describe the function. The |
| 533 | docstring will automatically have details about its overload symbol |
| 534 | appended to the end. |
| 535 | BODY is code that would be run when there is no override defined. The |
| 536 | default is to call the function `NAME-default' with the appropriate |
| 537 | arguments. |
| 538 | |
| 539 | BODY can also include an override form that specifies which part of |
| 540 | BODY is specifically overridden. This permits to specify common code |
| 541 | run for both default and overridden implementations. |
| 542 | An override form is one of: |
| 543 | |
| 544 | 1. (:override [OVERBODY]) |
| 545 | 2. (:override-with-args OVERARGS [OVERBODY]) |
| 546 | |
| 547 | OVERBODY is the code that would be run when there is no override |
| 548 | defined. The default is to call the function `NAME-default' with the |
| 549 | appropriate arguments deduced from ARGS. |
| 550 | OVERARGS is a list of arguments passed to the override and |
| 551 | `NAME-default' function, in place of those deduced from ARGS." |
| 552 | (declare (doc-string 3)) |
| 553 | `(eval-and-compile |
| 554 | (defun ,name ,args |
| 555 | ,docstring |
| 556 | ,@(mode-local--overload-body name args body)) |
| 557 | (put ',name 'mode-local-overload t))) |
| 558 | (put :override-with-args 'lisp-indent-function 1) |
| 559 | |
| 560 | (defalias 'define-overload 'define-overloadable-function) |
| 561 | |
| 562 | (defsubst function-overload-p (symbol) |
| 563 | "Return non-nil if SYMBOL is a function which can be overloaded." |
| 564 | (and symbol (symbolp symbol) (get symbol 'mode-local-overload))) |
| 565 | |
| 566 | (defmacro define-mode-local-override |
| 567 | (name mode args docstring &rest body) |
| 568 | "Define a mode specific override of the function overload NAME. |
| 569 | Has meaning only if NAME has been created with `define-overload'. |
| 570 | MODE is the major mode this override is being defined for. |
| 571 | ARGS are the function arguments, which should match those of the same |
| 572 | named function created with `define-overload'. |
| 573 | DOCSTRING is the documentation string. |
| 574 | BODY is the implementation of this function." |
| 575 | (let ((newname (intern (format "%s-%s" name mode)))) |
| 576 | `(progn |
| 577 | (eval-and-compile |
| 578 | (defun ,newname ,args |
| 579 | ,(format "%s\n\nOverride %s in `%s' buffers." |
| 580 | docstring name mode) |
| 581 | ;; The body for this implementation |
| 582 | ,@body) |
| 583 | ;; For find-func to locate the definition of NEWNAME. |
| 584 | (put ',newname 'definition-name ',name)) |
| 585 | (mode-local-bind '((,name . ,newname)) |
| 586 | '(override-flag t) |
| 587 | ',mode)) |
| 588 | )) |
| 589 | \f |
| 590 | ;;; Read/Query Support |
| 591 | (defun mode-local-read-function (prompt &optional initial hist default) |
| 592 | "Interactively read in the name of a mode-local function. |
| 593 | PROMPT, INITIAL, HIST, and DEFAULT are the same as for `completing-read'." |
| 594 | (completing-read prompt obarray 'function-overload-p t initial hist default)) |
| 595 | \f |
| 596 | ;;; Help support |
| 597 | ;; |
| 598 | (defun overload-docstring-extension (overload) |
| 599 | "Return the doc string that augments the description of OVERLOAD." |
| 600 | (let ((doc "\n\This function can be overloaded\ |
| 601 | with `define-mode-local-override'.") |
| 602 | (sym (overload-obsoleted-by overload))) |
| 603 | (when sym |
| 604 | (setq doc (format "%s\nIt has made the overload `%s' obsolete since %s." |
| 605 | doc sym (get sym 'overload-obsoleted-since)))) |
| 606 | (setq sym (overload-that-obsolete overload)) |
| 607 | (when sym |
| 608 | (setq doc (format "%s\nThis overload is obsolete since %s;\nUse `%s' instead." |
| 609 | doc (get overload 'overload-obsoleted-since) sym))) |
| 610 | doc)) |
| 611 | |
| 612 | (defun mode-local-augment-function-help (symbol) |
| 613 | "Augment the *Help* buffer for SYMBOL. |
| 614 | SYMBOL is a function that can be overridden." |
| 615 | (with-current-buffer "*Help*" |
| 616 | (pop-to-buffer (current-buffer)) |
| 617 | (goto-char (point-min)) |
| 618 | (unless (re-search-forward "^$" nil t) |
| 619 | (goto-char (point-max)) |
| 620 | (beginning-of-line) |
| 621 | (forward-line -1)) |
| 622 | (let ((inhibit-read-only t)) |
| 623 | (insert (overload-docstring-extension symbol) "\n") |
| 624 | ;; NOTE TO SELF: |
| 625 | ;; LIST ALL LOADED OVERRIDES FOR SYMBOL HERE |
| 626 | ))) |
| 627 | |
| 628 | ;; Help for mode-local bindings. |
| 629 | (defun mode-local-print-binding (symbol) |
| 630 | "Print the SYMBOL binding." |
| 631 | (let ((value (symbol-value symbol))) |
| 632 | (princ (format "\n `%s' value is\n " symbol)) |
| 633 | (if (and value (symbolp value)) |
| 634 | (princ (format "`%s'" value)) |
| 635 | (let ((pt (point))) |
| 636 | (pp value) |
| 637 | (save-excursion |
| 638 | (goto-char pt) |
| 639 | (indent-sexp)))) |
| 640 | (or (bolp) (princ "\n")))) |
| 641 | |
| 642 | (defun mode-local-print-bindings (table) |
| 643 | "Print bindings in TABLE." |
| 644 | (let (us ;; List of unspecified symbols |
| 645 | mc ;; List of mode local constants |
| 646 | mv ;; List of mode local variables |
| 647 | ov ;; List of overloaded functions |
| 648 | fo ;; List of final overloaded functions |
| 649 | ) |
| 650 | ;; Order symbols by type |
| 651 | (mapatoms |
| 652 | #'(lambda (s) |
| 653 | (add-to-list (cond |
| 654 | ((get s 'mode-variable-flag) |
| 655 | (if (get s 'constant-flag) 'mc 'mv)) |
| 656 | ((get s 'override-flag) |
| 657 | (if (get s 'constant-flag) 'fo 'ov)) |
| 658 | ('us)) |
| 659 | s)) |
| 660 | table) |
| 661 | ;; Print symbols by type |
| 662 | (when us |
| 663 | (princ "\n !! Unspecified symbols\n") |
| 664 | (mapc 'mode-local-print-binding us)) |
| 665 | (when mc |
| 666 | (princ "\n ** Mode local constants\n") |
| 667 | (mapc 'mode-local-print-binding mc)) |
| 668 | (when mv |
| 669 | (princ "\n ** Mode local variables\n") |
| 670 | (mapc 'mode-local-print-binding mv)) |
| 671 | (when fo |
| 672 | (princ "\n ** Final overloaded functions\n") |
| 673 | (mapc 'mode-local-print-binding fo)) |
| 674 | (when ov |
| 675 | (princ "\n ** Overloaded functions\n") |
| 676 | (mapc 'mode-local-print-binding ov)) |
| 677 | )) |
| 678 | |
| 679 | (defun mode-local-describe-bindings-2 (buffer-or-mode) |
| 680 | "Display mode local bindings active in BUFFER-OR-MODE." |
| 681 | (let (table mode) |
| 682 | (princ "Mode local bindings active in ") |
| 683 | (cond |
| 684 | ((bufferp buffer-or-mode) |
| 685 | (with-current-buffer buffer-or-mode |
| 686 | (setq table mode-local-symbol-table |
| 687 | mode major-mode)) |
| 688 | (princ (format "%S\n" buffer-or-mode)) |
| 689 | ) |
| 690 | ((symbolp buffer-or-mode) |
| 691 | (setq mode buffer-or-mode) |
| 692 | (princ (format "`%s'\n" buffer-or-mode)) |
| 693 | ) |
| 694 | ((signal 'wrong-type-argument |
| 695 | (list 'buffer-or-mode buffer-or-mode)))) |
| 696 | (when table |
| 697 | (princ "\n- Buffer local\n") |
| 698 | (mode-local-print-bindings table)) |
| 699 | (while mode |
| 700 | (setq table (get mode 'mode-local-symbol-table)) |
| 701 | (when table |
| 702 | (princ (format "\n- From `%s'\n" mode)) |
| 703 | (mode-local-print-bindings table)) |
| 704 | (setq mode (get-mode-local-parent mode))))) |
| 705 | |
| 706 | (defun mode-local-describe-bindings-1 (buffer-or-mode &optional interactive-p) |
| 707 | "Display mode local bindings active in BUFFER-OR-MODE. |
| 708 | Optional argument INTERACTIVE-P is non-nil if the calling command was |
| 709 | invoked interactively." |
| 710 | (if (fboundp 'with-displaying-help-buffer) |
| 711 | ;; XEmacs |
| 712 | (with-displaying-help-buffer |
| 713 | #'(lambda () |
| 714 | (with-current-buffer standard-output |
| 715 | (mode-local-describe-bindings-2 buffer-or-mode) |
| 716 | (when (fboundp 'frob-help-extents) |
| 717 | (goto-char (point-min)) |
| 718 | (frob-help-extents standard-output))))) |
| 719 | ;; GNU Emacs |
| 720 | (when (fboundp 'help-setup-xref) |
| 721 | (help-setup-xref |
| 722 | (list 'mode-local-describe-bindings-1 buffer-or-mode) |
| 723 | interactive-p)) |
| 724 | (with-output-to-temp-buffer (help-buffer) ; "*Help*" |
| 725 | (with-current-buffer standard-output |
| 726 | (mode-local-describe-bindings-2 buffer-or-mode))))) |
| 727 | |
| 728 | (defun describe-mode-local-bindings (buffer) |
| 729 | "Display mode local bindings active in BUFFER." |
| 730 | (interactive "b") |
| 731 | (when (setq buffer (get-buffer buffer)) |
| 732 | (mode-local-describe-bindings-1 buffer (called-interactively-p 'any)))) |
| 733 | |
| 734 | (defun describe-mode-local-bindings-in-mode (mode) |
| 735 | "Display mode local bindings active in MODE hierarchy." |
| 736 | (interactive |
| 737 | (list (completing-read |
| 738 | "Mode: " obarray |
| 739 | #'(lambda (s) (get s 'mode-local-symbol-table)) |
| 740 | t (symbol-name major-mode)))) |
| 741 | (when (setq mode (intern-soft mode)) |
| 742 | (mode-local-describe-bindings-1 mode (called-interactively-p 'any)))) |
| 743 | \f |
| 744 | ;; ;;; find-func support (Emacs 21.4, or perhaps 22.1) |
| 745 | ;; ;; |
| 746 | ;; (condition-case nil |
| 747 | ;; ;; Try to get find-func so we can modify it. |
| 748 | ;; (require 'find-func) |
| 749 | ;; (error nil)) |
| 750 | |
| 751 | ;; (when (boundp 'find-function-regexp) |
| 752 | ;; (unless (string-match "ine-overload" find-function-regexp) |
| 753 | ;; (if (string-match "(def\\\\(" find-function-regexp) |
| 754 | ;; (let ((end (match-end 0)) |
| 755 | ;; ) |
| 756 | ;; (setq find-function-regexp |
| 757 | ;; (concat (substring find-function-regexp 0 end) |
| 758 | ;; "ine-overload\\|ine-mode-local-override\\|" |
| 759 | ;; "ine-child-mode\\|" |
| 760 | ;; (substring find-function-regexp end))))))) |
| 761 | \f |
| 762 | ;;; edebug support |
| 763 | ;; |
| 764 | (defun mode-local-setup-edebug-specs () |
| 765 | "Define edebug specification for mode local macros." |
| 766 | (def-edebug-spec setq-mode-local |
| 767 | (symbolp &rest symbolp form)) |
| 768 | (def-edebug-spec defvar-mode-local |
| 769 | (&define symbolp name def-form [ &optional stringp ] )) |
| 770 | (def-edebug-spec defconst-mode-local |
| 771 | defvar-mode-local) |
| 772 | (def-edebug-spec define-overload |
| 773 | (&define name lambda-list stringp def-body)) |
| 774 | (def-edebug-spec define-overloadable-function |
| 775 | (&define name lambda-list stringp def-body)) |
| 776 | (def-edebug-spec define-mode-local-override |
| 777 | (&define name symbolp lambda-list stringp def-body))) |
| 778 | |
| 779 | (add-hook 'edebug-setup-hook 'mode-local-setup-edebug-specs) |
| 780 | |
| 781 | (add-hook 'find-file-hook 'mode-local-post-major-mode-change) |
| 782 | (add-hook 'change-major-mode-hook 'mode-local-on-major-mode-change) |
| 783 | |
| 784 | (provide 'mode-local) |
| 785 | |
| 786 | ;;; mode-local.el ends here |