From 02f122ca26158bbb650d6a416437cbdc8808ff89 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Tue, 25 Aug 2009 04:19:35 +0000 Subject: [PATCH] Initial version. --- lisp/cedet/mode-local.el | 889 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 889 insertions(+) create mode 100644 lisp/cedet/mode-local.el diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el new file mode 100644 index 00000000000..4712c9309ff --- /dev/null +++ b/lisp/cedet/mode-local.el @@ -0,0 +1,889 @@ +;;; mode-local.el --- Support for mode local facilities +;; +;; Copyright (C) 2004, 2005, 2007, 2008, 2009 Free Software Foundation, Inc. +;; +;; Author: David Ponce +;; Maintainer: David Ponce +;; Created: 27 Apr 2004 +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Each major mode will want to support a specific set of behaviors. +;; Usually generic behaviors that need just a little bit of local +;; specifics. +;; +;; This library permits the setting of override functions for tasks of +;; that nature, and also provides reasonable defaults. +;; +;; There are buffer local variables, and frame local variables. +;; This library give the illusion of mode specific variables. +;; +;; You should use a mode-local variable or override to allow extension +;; only if you expect a mode author to provide that extension. If a +;; user might wish to customize a give variable or function then +;; the existing customization mechanism should be used. + +;; To Do: +;; Allow customization of a variable for a specific mode? +;; +;; Add mecro for defining the '-default' functionality. + +;;; History: +;; + +;;; Code: +(eval-when-compile (require 'cl)) + +;;; Compatibility +;; +(defun mode-local-define-derived-mode-needed-p () + "Return non-nil if mode local has to fix `define-derived-mode'. +That is, if `define-derived-mode' does not set `derived-mode-parent'." + (let ((body (cdr (macroexpand '(define-derived-mode c p "")))) + (bad t)) + (while (and body bad) + (if (equal (car body) '(put 'c 'derived-mode-parent 'p)) + (setq bad nil) + (setq body (cdr body)))) + bad)) + +(when (mode-local-define-derived-mode-needed-p) + ;; Workaround a bug in some (XEmacs) versions of + ;; `define-derived-mode' that don't set the `derived-mode-parent' + ;; property, and break mode-local. + (defadvice define-derived-mode + (after mode-local-define-derived-mode activate) + "Fix missing `derived-mode-parent' property on child." + (unless (eq 'fundamental-mode (ad-get-arg 1)) + (let ((form (cdr ad-return-value))) + (setq ad-return-value nil) + (while form + (and (eq 'defun (car-safe (car form))) + (eq (ad-get-arg 0) (car (cdr-safe (car form)))) + (push `(or (get ',(ad-get-arg 0) 'derived-mode-parent) + (put ',(ad-get-arg 0) 'derived-mode-parent + ',(ad-get-arg 1))) + ad-return-value)) + (push (car form) ad-return-value) + (setq form (cdr form))) + (setq ad-return-value `(progn ,@(nreverse ad-return-value))) + ))) + ) + +;;; Misc utilities +;; +(defun mode-local-map-file-buffers (function &optional predicate buffers) + "Run FUNCTION on every file buffer found. +FUNCTION does not have arguments; when it is entered `current-buffer' +is the currently selected file buffer. +If optional argument PREDICATE is non nil, only select file buffers +for which the function PREDICATE return non-nil. +If optional argument BUFFERS is non-nil, it is a list of buffers to +walk through. It defaults to `buffer-list'." + (dolist (b (or buffers (buffer-list))) + (and (buffer-live-p b) (buffer-file-name b) + (with-current-buffer b + (when (or (not predicate) (funcall predicate)) + (funcall function)))))) + +(defsubst get-mode-local-parent (mode) + "Return the mode parent of the major mode MODE. +Return nil if MODE has no parent." + (or (get mode 'mode-local-parent) + (get mode 'derived-mode-parent))) + +(defun mode-local-equivalent-mode-p (mode) + "Is the major-mode in the current buffer equivalent to a mode in MODES." + (let ((modes nil)) + (while mode + (setq modes (cons mode modes) + mode (get-mode-local-parent mode))) + modes)) + +(defun mode-local-map-mode-buffers (function modes) + "Run FUNCTION on every file buffer with major mode in MODES. +MODES can be a symbol or a list of symbols. +FUNCTION does not have arguments." + (or (listp modes) (setq modes (list modes))) + (mode-local-map-file-buffers + function #'(lambda () + (let ((mm (mode-local-equivalent-mode-p major-mode)) + (ans nil)) + (while (and (not ans) mm) + (setq ans (memq (car mm) modes) + mm (cdr mm)) ) + ans)))) + +;;; Hook machinery +;; +(defvar mode-local-init-hook nil + "Hook run after a new file buffer is created. +The current buffer is the newly created file buffer.") + +(defvar mode-local-changed-mode-buffers nil + "List of buffers whose `major-mode' has changed recently.") + +(defvar mode-local--init-mode nil) + +(defsubst mode-local-initialized-p () + "Return non-nil if mode local is initialized in current buffer. +That is, if the current `major-mode' is equal to the major mode for +which mode local bindings have been activated." + (eq mode-local--init-mode major-mode)) + +(defun mode-local-post-major-mode-change () + "`post-command-hook' run when there is a `major-mode' change. +This makes sure mode local init type stuff can occur." + (remove-hook 'post-command-hook 'mode-local-post-major-mode-change nil) + (let ((buffers mode-local-changed-mode-buffers)) + (setq mode-local-changed-mode-buffers nil) + (mode-local-map-file-buffers + #'(lambda () + ;; Make sure variables are set up for this mode. + (activate-mode-local-bindings) + (run-hooks 'mode-local-init-hook)) + #'(lambda () + (not (mode-local-initialized-p))) + buffers))) + +(defun mode-local-on-major-mode-change () + "Function called in `change-major-mode-hook'." + (add-to-list 'mode-local-changed-mode-buffers (current-buffer)) + (add-hook 'post-command-hook 'mode-local-post-major-mode-change t nil)) + +(add-hook 'find-file-hooks 'mode-local-post-major-mode-change) +(add-hook 'change-major-mode-hook 'mode-local-on-major-mode-change) + +;;; Mode lineage +;; +(defsubst set-mode-local-parent (mode parent) + "Set parent of major mode MODE to PARENT mode. +To work properly, this function should be called after PARENT mode +local variables have been defined." + (put mode 'mode-local-parent parent) + ;; Refresh mode bindings to get mode local variables inherited from + ;; PARENT. To work properly, the following should be called after + ;; PARENT mode local variables have been defined. + (mode-local-map-mode-buffers #'activate-mode-local-bindings mode)) + +(defmacro define-child-mode (mode parent &optional docstring) + "Make major mode MODE inherits behavior from PARENT mode. +DOCSTRING is optional and not used. +To work properly, this should be put after PARENT mode local variables +definition." + `(set-mode-local-parent ',mode ',parent)) + +(defun mode-local-use-bindings-p (this-mode desired-mode) + "Return non-nil if THIS-MODE can use bindings of DESIRED-MODE." + (let ((ans nil)) + (while (and (not ans) this-mode) + (setq ans (eq this-mode desired-mode)) + (setq this-mode (get-mode-local-parent this-mode))) + ans)) + + +;;; Core bindings API +;; +(defvar mode-local-symbol-table nil + "Buffer local mode bindings. +These symbols provide a hook for a `major-mode' to specify specific +behaviors. Use the function `mode-local-bind' to define new bindings.") +(make-variable-buffer-local 'mode-local-symbol-table) + +(defvar mode-local-active-mode nil + "Major mode in which bindings are active.") + +(defsubst new-mode-local-bindings () + "Return a new empty mode bindings symbol table." + (make-vector 13 0)) + +(defun mode-local-bind (bindings &optional plist mode) + "Define BINDINGS in the specified environment. +BINDINGS is a list of (VARIABLE . VALUE). +Optional argument PLIST is a property list each VARIABLE symbol will +be set to. The following properties have special meaning: + +- `constant-flag' if non-nil, prevent to rebind variables. +- `mode-variable-flag' if non-nil, define mode variables. +- `override-flag' if non-nil, define override functions. + +The `override-flag' and `mode-variable-flag' properties are mutually +exclusive. + +If optional argument MODE is non-nil, it must be a major mode symbol. +BINDINGS will be defined globally for this major mode. If MODE is +nil, BINDINGS will be defined locally in the current buffer, in +variable `mode-local-symbol-table'. The later should be done in MODE +hook." + ;; Check plist consistency + (and (plist-get plist 'mode-variable-flag) + (plist-get plist 'override-flag) + (error "Bindings can't be both overrides and mode variables")) + (let (table variable varname value binding) + (if mode + (progn + ;; Install in given MODE symbol table. Create a new one if + ;; needed. + (setq table (or (get mode 'mode-local-symbol-table) + (new-mode-local-bindings))) + (put mode 'mode-local-symbol-table table)) + ;; Fail if trying to bind mode variables in local context! + (if (plist-get plist 'mode-variable-flag) + (error "Mode required to bind mode variables")) + ;; Install in buffer local symbol table. Create a new one if + ;; needed. + (setq table (or mode-local-symbol-table + (setq mode-local-symbol-table + (new-mode-local-bindings))))) + (while bindings + (setq binding (car bindings) + bindings (cdr bindings) + varname (symbol-name (car binding)) + value (cdr binding)) + (if (setq variable (intern-soft varname table)) + ;; Binding already exists + ;; Check rebind consistency + (cond + ((equal (symbol-value variable) value) + ;; Just ignore rebind with the same value. + ) + ((get variable 'constant-flag) + (error "Can't change the value of constant `%s'" + variable)) + ((and (get variable 'mode-variable-flag) + (plist-get plist 'override-flag)) + (error "Can't rebind override `%s' as a mode variable" + variable)) + ((and (get variable 'override-flag) + (plist-get plist 'mode-variable-flag)) + (error "Can't rebind mode variable `%s' as an override" + variable)) + (t + ;; Merge plist and assign new value + (setplist variable (append plist (symbol-plist variable))) + (set variable value))) + ;; New binding + (setq variable (intern varname table)) + ;; Set new plist and assign initial value + (setplist variable plist) + (set variable value))) + ;; Return the symbol table used + table)) + +(defsubst mode-local-symbol (symbol &optional mode) + "Return the mode local symbol bound with SYMBOL's name. +Return nil if the mode local symbol doesn't exist. +If optional argument MODE is nil, lookup first into locally bound +symbols, then in those bound in current `major-mode' and its parents. +If MODE is non-nil, lookup into symbols bound in that major mode and +its parents." + (let ((name (symbol-name symbol)) bind) + (or mode + (setq mode mode-local-active-mode) + (setq mode major-mode + bind (and mode-local-symbol-table + (intern-soft name mode-local-symbol-table)))) + (while (and mode (not bind)) + (or (and (get mode 'mode-local-symbol-table) + (setq bind (intern-soft + name (get mode 'mode-local-symbol-table)))) + (setq mode (get-mode-local-parent mode)))) + bind)) + +(defsubst mode-local-symbol-value (symbol &optional mode property) + "Return the value of the mode local symbol bound with SYMBOL's name. +If optional argument MODE is non-nil, restrict lookup to that mode and +its parents (see the function `mode-local-symbol' for more details). +If optional argument PROPERTY is non-nil the mode local symbol must +have that property set. Return nil if the symbol doesn't exist, or +doesn't have PROPERTY set." + (and (setq symbol (mode-local-symbol symbol mode)) + (or (not property) (get symbol property)) + (symbol-value symbol))) + +;;; Mode local variables +;; +(defun activate-mode-local-bindings (&optional mode) + "Activate variables defined locally in MODE and its parents. +That is, copy mode local bindings into corresponding buffer local +variables. +If MODE is not specified it defaults to current `major-mode'. +Return the alist of buffer-local variables that have been changed. +Elements are (SYMBOL . PREVIOUS-VALUE), describing one variable." + ;; Hack - + ;; do not do this if we are inside set-auto-mode as we may be in + ;; an initialization race condition. + (if (or (and (featurep 'emacs) (boundp 'keep-mode-if-same)) + (and (featurep 'xemacs) (boundp 'just-from-file-name))) + ;; We are inside set-auto-mode, as this is an argument that is + ;; vaguely unique. + + ;; This will make sure that when everything is over, this will get + ;; called and we won't be under set-auto-mode anymore. + (mode-local-on-major-mode-change) + + ;; Do the normal thing. + (let (modes table old-locals) + (unless mode + (set (make-local-variable 'mode-local--init-mode) major-mode) + (setq mode major-mode)) + ;; Get MODE's parents & MODE in the right order. + (while mode + (setq modes (cons mode modes) + mode (get-mode-local-parent mode))) + ;; Activate mode bindings following parent modes order. + (dolist (mode modes) + (when (setq table (get mode 'mode-local-symbol-table)) + (mapatoms + #'(lambda (var) + (when (get var 'mode-variable-flag) + (let ((v (intern (symbol-name var)))) + ;; Save the current buffer-local value of the + ;; mode-local variable. + (and (local-variable-p v (current-buffer)) + (push (cons v (symbol-value v)) old-locals)) + (set (make-local-variable v) (symbol-value var))))) + table))) + old-locals))) + +(defun deactivate-mode-local-bindings (&optional mode) + "Deactivate variables defined locally in MODE and its parents. +That is, kill buffer local variables set from the corresponding mode +local bindings. +If MODE is not specified it defaults to current `major-mode'." + (unless mode + (kill-local-variable 'mode-local--init-mode) + (setq mode major-mode)) + (let (table) + (while mode + (when (setq table (get mode 'mode-local-symbol-table)) + (mapatoms + #'(lambda (var) + (when (get var 'mode-variable-flag) + (kill-local-variable (intern (symbol-name var))))) + table)) + (setq mode (get-mode-local-parent mode))))) + +(defmacro with-mode-local-symbol (mode &rest body) + "With the local bindings of MODE symbol, evaluate BODY. +The current mode bindings are saved, BODY is evaluated, and the saved +bindings are restored, even in case of an abnormal exit. +Value is what BODY returns. +This is like `with-mode-local', except that MODE's value is used. +To use the symbol MODE (quoted), use `with-mode-local'." + (let ((old-mode (make-symbol "mode")) + (old-locals (make-symbol "old-locals")) + (new-mode (make-symbol "new-mode")) + (local (make-symbol "local"))) + `(let ((,old-mode mode-local-active-mode) + (,old-locals nil) + (,new-mode ,mode) + ) + (unwind-protect + (progn + (deactivate-mode-local-bindings ,old-mode) + (setq mode-local-active-mode ,new-mode) + ;; Save the previous value of buffer-local variables + ;; changed by `activate-mode-local-bindings'. + (setq ,old-locals (activate-mode-local-bindings ,new-mode)) + ,@body) + (deactivate-mode-local-bindings ,new-mode) + ;; Restore the previous value of buffer-local variables. + (dolist (,local ,old-locals) + (set (car ,local) (cdr ,local))) + ;; Restore the mode local variables. + (setq mode-local-active-mode ,old-mode) + (activate-mode-local-bindings ,old-mode))))) +(put 'with-mode-local-symbol 'lisp-indent-function 1) + +(defmacro with-mode-local (mode &rest body) + "With the local bindings of MODE, evaluate BODY. +The current mode bindings are saved, BODY is evaluated, and the saved +bindings are restored, even in case of an abnormal exit. +Value is what BODY returns. +This lis like `with-mode-local-symbol', except that MODE is quoted +and is note evaluated." + `(with-mode-local-symbol ',mode ,@body)) +(put 'with-mode-local 'lisp-indent-function 1) + + +(defsubst mode-local-value (mode sym) + "Return the value of the MODE local variable SYM." + (or mode (error "Missing major mode symbol")) + (mode-local-symbol-value sym mode 'mode-variable-flag)) + +(defmacro setq-mode-local (mode &rest args) + "Assign new values to variables local in MODE. +MODE must be a major mode symbol. +ARGS is a list (SYM VAL SYM VAL ...). +The symbols SYM are variables; they are literal (not evaluated). +The values VAL are expressions; they are evaluated. +Set each SYM to the value of its VAL, locally in buffers already in +MODE, or in buffers switched to that mode. +Return the value of the last VAL." + (when args + (let (i ll bl sl tmp sym val) + (setq i 0) + (while args + (setq tmp (make-symbol (format "tmp%d" i)) + i (1+ i) + sym (car args) + val (cadr args) + ll (cons (list tmp val) ll) + bl (cons `(cons ',sym ,tmp) bl) + sl (cons `(set (make-local-variable ',sym) ,tmp) sl) + args (cddr args))) + `(let* ,(nreverse ll) + ;; Save mode bindings + (mode-local-bind (list ,@bl) '(mode-variable-flag t) ',mode) + ;; Assign to local variables in all existing buffers in MODE + (mode-local-map-mode-buffers #'(lambda () ,@sl) ',mode) + ;; Return the last value + ,tmp) + ))) + +(defmacro defvar-mode-local (mode sym val &optional docstring) + "Define MODE local variable SYM with value VAL. +DOCSTRING is optional." + `(progn + (setq-mode-local ,mode ,sym ,val) + (put (mode-local-symbol ',sym ',mode) + 'variable-documentation ,docstring) + ',sym)) +(put 'defvar-mode-local 'lisp-indent-function 'defun) + +(defmacro defconst-mode-local (mode sym val &optional docstring) + "Define MODE local constant SYM with value VAL. +DOCSTRING is optional." + (let ((tmp (make-symbol "tmp"))) + `(let (,tmp) + (setq-mode-local ,mode ,sym ,val) + (setq ,tmp (mode-local-symbol ',sym ',mode)) + (put ,tmp 'constant-flag t) + (put ,tmp 'variable-documentation ,docstring) + ',sym))) +(put 'defconst-mode-local 'lisp-indent-function 'defun) + +;;; Function overloading +;; +(defun make-obsolete-overload (old new) + "Mark OLD overload as obsoleted by NEW overload." + (put old 'overload-obsoleted-by new) + (put old 'mode-local-overload t) + (put new 'overload-obsolete old)) + +(defsubst overload-obsoleted-by (overload) + "Get the overload symbol obsoleted by OVERLOAD. +Return the obsolete symbol or nil if not found." + (get overload 'overload-obsolete)) + +(defsubst overload-that-obsolete (overload) + "Return the overload symbol that obsoletes OVERLOAD. +Return the symbol found or nil if OVERLOAD is not obsolete." + (get overload 'overload-obsoleted-by)) + +(defsubst fetch-overload (overload) + "Return the current OVERLOAD function, or nil if not found. +First, lookup for OVERLOAD into locally bound mode local symbols, then +in those bound in current `major-mode' and its parents." + (or (mode-local-symbol-value overload nil 'override-flag) + ;; If an obsolete overload symbol exists, try it. + (and (overload-obsoleted-by overload) + (mode-local-symbol-value + (overload-obsoleted-by overload) nil 'override-flag)))) + +(defun mode-local--override (name args body) + "Return the form that handles overloading of function NAME. +ARGS are the arguments to the function. +BODY is code that would be run when there is no override defined. The +default is to call the function `NAME-default' with the appropriate +arguments. +See also the function `define-overload'." + (let* ((default (intern (format "%s-default" name))) + (overargs (delq '&rest (delq '&optional (copy-sequence args)))) + (override (make-symbol "override"))) + `(let ((,override (fetch-overload ',name))) + (if ,override + (funcall ,override ,@overargs) + ,@(or body `((,default ,@overargs))))) + )) + +(defun mode-local--expand-overrides (name args body) + "Expand override forms that overload function NAME. +ARGS are the arguments to the function NAME. +BODY is code where override forms are searched for expansion. +Return result of expansion, or BODY if no expansion occurred. +See also the function `define-overload'." + (let ((forms body) + (ditto t) + form xbody) + (while forms + (setq form (car forms)) + (cond + ((atom form)) + ((eq (car form) :override) + (setq form (mode-local--override name args (cdr form)))) + ((eq (car form) :override-with-args) + (setq form (mode-local--override name (cadr form) (cddr form)))) + ((setq form (mode-local--expand-overrides name args form)))) + (setq ditto (and ditto (eq (car forms) form)) + xbody (cons form xbody) + forms (cdr forms))) + (if ditto body (nreverse xbody)))) + +(defun mode-local--overload-body (name args body) + "Return the code that implements overloading of function NAME. +ARGS are the arguments to the function NAME. +BODY specifies the overload code. +See also the function `define-overload'." + (let ((result (mode-local--expand-overrides name args body))) + (if (eq body result) + (list (mode-local--override name args body)) + result))) + +(defmacro define-overloadable-function (name args docstring &rest body) + "Define a new function, as with `defun' which can be overloaded. +NAME is the name of the function to create. +ARGS are the arguments to the function. +DOCSTRING is a documentation string to describe the function. The +docstring will automatically had details about its overload symbol +appended to the end. +BODY is code that would be run when there is no override defined. The +default is to call the function `NAME-default' with the appropriate +arguments. + +BODY can also include an override form that specifies which part of +BODY is specifically overridden. This permits to specify common code +run for both default and overridden implementations. +An override form is one of: + + 1. (:override [OVERBODY]) + 2. (:override-with-args OVERARGS [OVERBODY]) + +OVERBODY is the code that would be run when there is no override +defined. The default is to call the function `NAME-default' with the +appropriate arguments deduced from ARGS. +OVERARGS is a list of arguments passed to the override and +`NAME-default' function, in place of those deduced from ARGS." + `(eval-and-compile + (defun ,name ,args + ,docstring + ,@(mode-local--overload-body name args body)) + (put ',name 'mode-local-overload t))) +(put :override-with-args 'lisp-indent-function 1) + +(defalias 'define-overload 'define-overloadable-function) + +(defsubst function-overload-p (symbol) + "Return non-nil if SYMBOL is a function which can be overloaded." + (and symbol (symbolp symbol) (get symbol 'mode-local-overload))) + +(defmacro define-mode-local-override + (name mode args docstring &rest body) + "Define a mode specific override of the function overload NAME. +Has meaning only if NAME has been created with `define-overload'. +MODE is the major mode this override is being defined for. +ARGS are the function arguments, which should match those of the same +named function created with `define-overload'. +DOCSTRING is the documentation string. +BODY is the implementation of this function." + (let ((newname (intern (format "%s-%s" name mode)))) + `(progn + (eval-and-compile + (defun ,newname ,args + ,(format "%s\n\nOverride %s in `%s' buffers." + docstring name mode) + ;; The body for this implementation + ,@body) + ;; For find-func to locate the definition of NEWNAME. + (put ',newname 'definition-name ',name)) + (mode-local-bind '((,name . ,newname)) + '(override-flag t) + ',mode)) + )) + +;;; Read/Query Support +(defun mode-local-read-function (prompt &optional initial hist default) + "Interactively read in the name of a mode-local function. +PROMPT, INITIAL, HIST, and DEFAULT are the same as for `completing-read'." + (completing-read prompt obarray 'function-overload-p t initial hist default)) + +;;; Help support +;; +(defun overload-docstring-extension (overload) + "Return the doc string that augments the description of OVERLOAD." + (let ((doc "\n\This function can be overloaded\ + (see `define-mode-local-override' for details).") + (sym (overload-obsoleted-by overload))) + (when sym + (setq doc (format "%s\nIt makes the overload `%s' obsolete." + doc sym))) + (setq sym (overload-that-obsolete overload)) + (when sym + (setq doc (format "%s\nThis overload is obsoletes;\nUse `%s' instead." + doc sym))) + doc)) + +(defun mode-local-augment-function-help (symbol) + "Augment the *Help* buffer for SYMBOL. +SYMBOL is a function that can be overridden." + (with-current-buffer "*Help*" + (pop-to-buffer (current-buffer)) + (unwind-protect + (progn + (toggle-read-only -1) + (goto-char (point-min)) + (unless (re-search-forward "^$" nil t) + (goto-char (point-max)) + (beginning-of-line) + (forward-line -1)) + (insert (overload-docstring-extension symbol) "\n") + ;; NOTE TO SELF: + ;; LIST ALL LOADED OVERRIDES FOR SYMBOL HERE + ) + (toggle-read-only 1)))) + +;; Help for Overload functions. Need to advise help. +(defadvice describe-function (around mode-local-help activate) + "Display the full documentation of FUNCTION (a symbol). +Returns the documentation as a string, also." + (prog1 + ad-do-it + (if (function-overload-p (ad-get-arg 0)) + (mode-local-augment-function-help (ad-get-arg 0))))) + +;; Help for mode-local bindings. +(defun mode-local-print-binding (symbol) + "Print the SYMBOL binding." + (let ((value (symbol-value symbol))) + (princ (format "\n `%s' value is\n " symbol)) + (if (and value (symbolp value)) + (princ (format "`%s'" value)) + (let ((pt (point))) + (pp value) + (save-excursion + (goto-char pt) + (indent-sexp)))) + (or (bolp) (princ "\n")))) + +(defun mode-local-print-bindings (table) + "Print bindings in TABLE." + (let (us ;; List of unpecified symbols + mc ;; List of mode local constants + mv ;; List of mode local variables + ov ;; List of overloaded functions + fo ;; List of final overloaded functions + ) + ;; Order symbols by type + (mapatoms + #'(lambda (s) + (add-to-list (cond + ((get s 'mode-variable-flag) + (if (get s 'constant-flag) 'mc 'mv)) + ((get s 'override-flag) + (if (get s 'constant-flag) 'fo 'ov)) + ('us)) + s)) + table) + ;; Print symbols by type + (when us + (princ "\n !! Unpecified symbols\n") + (mapc 'mode-local-print-binding us)) + (when mc + (princ "\n ** Mode local constants\n") + (mapc 'mode-local-print-binding mc)) + (when mv + (princ "\n ** Mode local variables\n") + (mapc 'mode-local-print-binding mv)) + (when fo + (princ "\n ** Final overloaded functions\n") + (mapc 'mode-local-print-binding fo)) + (when ov + (princ "\n ** Overloaded functions\n") + (mapc 'mode-local-print-binding ov)) + )) + +(defun mode-local-describe-bindings-2 (buffer-or-mode) + "Display mode local bindings active in BUFFER-OR-MODE." + (let (table mode) + (princ "Mode local bindings active in ") + (cond + ((bufferp buffer-or-mode) + (with-current-buffer buffer-or-mode + (setq table mode-local-symbol-table + mode major-mode)) + (princ (format "%S\n" buffer-or-mode)) + ) + ((symbolp buffer-or-mode) + (setq mode buffer-or-mode) + (princ (format "`%s'\n" buffer-or-mode)) + ) + ((signal 'wrong-type-argument + (list 'buffer-or-mode buffer-or-mode)))) + (when table + (princ "\n- Buffer local\n") + (mode-local-print-bindings table)) + (while mode + (setq table (get mode 'mode-local-symbol-table)) + (when table + (princ (format "\n- From `%s'\n" mode)) + (mode-local-print-bindings table)) + (setq mode (get-mode-local-parent mode))))) + +(defun mode-local-describe-bindings-1 (buffer-or-mode &optional interactive-p) + "Display mode local bindings active in BUFFER-OR-MODE. +Optional argument INTERACTIVE-P is non-nil if the calling command was +invoked interactively." + (if (fboundp 'with-displaying-help-buffer) + ;; XEmacs + (with-displaying-help-buffer + #'(lambda () + (with-current-buffer standard-output + (mode-local-describe-bindings-2 buffer-or-mode) + (when (fboundp 'frob-help-extents) + (goto-char (point-min)) + (frob-help-extents standard-output))))) + ;; GNU Emacs + (when (fboundp 'help-setup-xref) + (help-setup-xref + (list 'mode-local-describe-bindings-1 buffer-or-mode) + interactive-p)) + (with-output-to-temp-buffer (help-buffer) ; "*Help*" + (with-current-buffer standard-output + (mode-local-describe-bindings-2 buffer-or-mode))))) + +(defun describe-mode-local-bindings (buffer) + "Display mode local bindings active in BUFFER." + (interactive "b") + (when (setq buffer (get-buffer buffer)) + (mode-local-describe-bindings-1 buffer (interactive-p)))) + +(defun describe-mode-local-bindings-in-mode (mode) + "Display mode local bindings active in MODE hierarchy." + (interactive + (list (completing-read + "Mode: " obarray + #'(lambda (s) (get s 'mode-local-symbol-table)) + t (symbol-name major-mode)))) + (when (setq mode (intern-soft mode)) + (mode-local-describe-bindings-1 mode (interactive-p)))) + +;;; Font-lock support +;; +(defconst mode-local-font-lock-keywords + (eval-when-compile + (let* ( + ;; Variable declarations + (kv (regexp-opt + '( + "defconst-mode-local" + "defvar-mode-local" + ) t)) + ;; Function declarations + (kf (regexp-opt + '( + "define-mode-local-override" + "define-child-mode" + "define-overload" + "define-overloadable-function" + ;;"make-obsolete-overload" + "with-mode-local" + ) t)) + ;; Regexp depths + (kv-depth (regexp-opt-depth kv)) + (kf-depth (regexp-opt-depth kf)) + ) + `((,(concat + ;; Declarative things + "(\\(" kv "\\|" kf "\\)" + ;; Whitespaces & names + "\\>[ \t]*\\(\\sw+\\)?[ \t]*\\(\\sw+\\)?" + ) + (1 font-lock-keyword-face) + (,(+ 1 kv-depth kf-depth 1) + (cond ((match-beginning 2) + font-lock-type-face) + ((match-beginning ,(+ 1 kv-depth 1)) + font-lock-function-name-face) + ) + nil t) + (,(+ 1 kv-depth kf-depth 1 1) + (cond ((match-beginning 2) + font-lock-variable-name-face) + ) + nil t))) + )) + "Highlighted keywords.") + + +;;; find-func support (Emacs 21.4, or perhaps 22.1) +;; +(condition-case nil + ;; Try to get find-func so we can modify it. + (require 'find-func) + (error nil)) + +(when (boundp 'find-function-regexp) + (unless (string-match "ine-overload" find-function-regexp) + (if (string-match "(def\\\\(" find-function-regexp) + (let ((end (match-end 0)) + ) + (setq find-function-regexp + (concat (substring find-function-regexp 0 end) + "ine-overload\\|ine-mode-local-override\\|" + "ine-child-mode\\|" + (substring find-function-regexp end))))) + ) + ;; The regexp for variables is a little more kind. + ) + +;; TODO: Add XEmacs support +;; (when (fboundp 'font-lock-add-keywords) +;; (font-lock-add-keywords 'emacs-lisp-mode +;; mode-local-font-lock-keywords)) + +;;; edebug support +;; +(defun mode-local-setup-edebug-specs () + "Define edebug specification for mode local macros." + (def-edebug-spec setq-mode-local + (symbolp &rest symbolp form) + ) + (def-edebug-spec defvar-mode-local + (&define symbolp name def-form [ &optional stringp ] ) + ) + (def-edebug-spec defconst-mode-local + defvar-mode-local + ) + (def-edebug-spec define-overload + (&define name lambda-list stringp def-body) + ) + (def-edebug-spec define-overloadable-function + (&define name lambda-list stringp def-body) + ) + (def-edebug-spec define-mode-local-override + (&define name symbolp lambda-list stringp def-body) + ) + ) + +(add-hook 'edebug-setup-hook 'mode-local-setup-edebug-specs) + +(provide 'mode-local) + +;;; mode-local.el ends here -- 2.39.2