code.delx.au - gnu-emacs/blob - lisp/cedet/mode-local.el

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