X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/d76bf86f438d4f5f9fe493ab76f02ffc78f3ae2e..81ef756e6aea369ec78f19b3609f01ceddc5851f:/lisp/cedet/mode-local.el

diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el
index 7c75e3f9f3..c7e6615e0d 100644
--- a/lisp/cedet/mode-local.el
+++ b/lisp/cedet/mode-local.el
@@ -1,6 +1,6 @@
 ;;; mode-local.el --- Support for mode local facilities
 ;;
-;; Copyright (C) 2004-2005, 2007-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2005, 2007-2016 Free Software Foundation, Inc.
 ;;
 ;; Author: David Ponce <david@dponce.com>
 ;; Maintainer: David Ponce <david@dponce.com>
@@ -48,6 +48,13 @@
 
 (eval-when-compile (require 'cl))
 
+(require 'find-func)
+;; For find-function-regexp-alist. It is tempting to replace this
+;; ‘require’ by (defvar find-function-regexp-alist) and
+;; with-eval-after-load, but model-local.el is typically loaded when a
+;; semantic autoload is invoked, and something in semantic loads
+;; find-func.el before mode-local.el, so the eval-after-load is lost.
+
 ;;; Misc utilities
 ;;
 (defun mode-local-map-file-buffers (function &optional predicate buffers)
@@ -182,7 +189,7 @@ 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.
+- `constant-flag' if non-nil, prevent rebinding variables.
 - `mode-variable-flag' if non-nil, define mode variables.
 - `override-flag' if non-nil, define override functions.
 
@@ -537,7 +544,7 @@ 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
+BODY is specifically overridden.  This permits specifying common code
 run for both default and overridden implementations.
 An override form is one of:
 
@@ -597,7 +604,7 @@ PROMPT, INITIAL, HIST, and DEFAULT are the same as for `completing-read'."
 ;;
 (defun overload-docstring-extension (overload)
   "Return the doc string that augments the description of OVERLOAD."
-  (let ((doc "\n\This function can be overloaded\
+  (let ((doc "\nThis function can be overloaded\
  with `define-mode-local-override'.")
         (sym (overload-obsoleted-by overload)))
     (when sym
@@ -620,18 +627,147 @@ SYMBOL is a function that can be overridden."
       (beginning-of-line)
       (forward-line -1))
     (let ((inhibit-read-only t))
-      (insert (overload-docstring-extension symbol) "\n")
+      (insert (substitute-command-keys (overload-docstring-extension symbol))
+              "\n")
       ;; NOTE TO SELF:
       ;; LIST ALL LOADED OVERRIDES FOR SYMBOL HERE
       )))
 
+;; We are called from describe-function in help-fns.el, where this is defined.
+(defvar describe-function-orig-buffer)
+
+(defun describe-mode-local-overload (symbol)
+  "For `help-fns-describe-function-functions'; add overloads for SYMBOL."
+  (when (get symbol 'mode-local-overload)
+    (let ((default (or (intern-soft (format "%s-default" (symbol-name symbol)))
+		       symbol))
+	  (override (with-current-buffer describe-function-orig-buffer
+                      (fetch-overload symbol)))
+          modes)
+
+      (insert (substitute-command-keys (overload-docstring-extension symbol))
+              "\n\n")
+      (insert (format-message "default function: `%s'\n" default))
+      (if override
+	  (insert (format-message "\noverride in buffer `%s': `%s'\n"
+				  describe-function-orig-buffer override))
+	(insert (format-message "\nno override in buffer `%s'\n"
+				describe-function-orig-buffer)))
+
+      (mapatoms
+       (lambda (sym) (when (get sym 'mode-local-symbol-table) (push sym modes)))
+       obarray)
+
+      (dolist (mode modes)
+	(let* ((major-mode mode)
+	       (override (fetch-overload symbol)))
+
+	  (when override
+	    (insert (format-message "\noverride in mode `%s': `%s'\n"
+				    major-mode override))
+            )))
+      )))
+
+(add-hook 'help-fns-describe-function-functions 'describe-mode-local-overload)
+
+(declare-function xref-item-location "xref" (xref) t)
+
+(defun xref-mode-local--override-present (sym xrefs)
+  "Return non-nil if SYM is in XREFS."
+  (let (result)
+    (while (and (null result)
+		xrefs)
+      (when (equal sym (car (xref-elisp-location-symbol (xref-item-location (pop xrefs)))))
+	(setq result t)))
+    result))
+
+(defun xref-mode-local-overload (symbol)
+  "For `elisp-xref-find-def-functions'; add overloads for SYMBOL."
+  ;; Current buffer is the buffer where xref-find-definitions was invoked.
+  (when (get symbol 'mode-local-overload)
+    (let* ((symbol-file (find-lisp-object-file-name symbol (symbol-function symbol)))
+	   (default (intern-soft (format "%s-default" (symbol-name symbol))))
+	   (default-file (when default (find-lisp-object-file-name default (symbol-function default))))
+	   modes
+	   xrefs)
+
+      (mapatoms
+       (lambda (sym) (when (get sym 'mode-local-symbol-table) (push sym modes)))
+       obarray)
+
+      ;; mode-local-overrides are inherited from parent modes; we
+      ;; don't want to list the same function twice. So order ‘modes’
+      ;; with parents first, and check for duplicates.
+
+      (setq modes
+	    (sort modes
+		  (lambda (a b)
+		    (not (equal b (get a 'mode-local-parent)))))) ;; a is not a child, or not a child of b
+
+      (dolist (mode modes)
+	(let* ((major-mode mode)
+	       (override (fetch-overload symbol))
+	       (override-file (when override (find-lisp-object-file-name override (symbol-function override)))))
+
+	  (when (and override override-file)
+	    (let ((meta-name (cons override major-mode))
+		  ;; For the declaration:
+		  ;;
+		  ;;(define-mode-local-override xref-elisp-foo c-mode
+		  ;;
+		  ;; The override symbol name is
+		  ;; "xref-elisp-foo-c-mode". The summary should match
+		  ;; the declaration, so strip the mode from the
+		  ;; symbol name.
+		  (summary (format elisp--xref-format-extra
+				   'define-mode-local-override
+				   (substring (symbol-name override) 0 (- (1+ (length (symbol-name major-mode)))))
+				   major-mode)))
+
+	      (unless (xref-mode-local--override-present override xrefs)
+		(push (elisp--xref-make-xref
+		       'define-mode-local-override meta-name override-file summary)
+		      xrefs))))))
+
+      ;; %s-default is interned whether it is a separate function or
+      ;; not, so we have to check that here.
+      (when (and (functionp default) default-file)
+	(push (elisp--xref-make-xref nil default default-file) xrefs))
+
+      (when symbol-file
+	(push (elisp--xref-make-xref 'define-overloadable-function symbol symbol-file) xrefs))
+
+      xrefs)))
+
+(add-hook 'elisp-xref-find-def-functions 'xref-mode-local-overload)
+
+(defconst xref-mode-local-find-overloadable-regexp
+  "(\\(\\(define-overloadable-function\\)\\|\\(define-overload\\)\\) +%s"
+  "Regexp used by `xref-find-definitions' when searching for a
+  mode-local overloadable function definition.")
+
+(defun xref-mode-local-find-override (meta-name)
+  "Function used by `xref-find-definitions' when searching for an
+  override of a mode-local overloadable function.
+META-NAME is a cons (OVERLOADABLE-SYMBOL . MAJOR-MODE)."
+  (let* ((override (car meta-name))
+	 (mode (cdr meta-name))
+	 (regexp (format "(define-mode-local-override +%s +%s"
+			 (substring (symbol-name override) 0 (- (1+ (length (symbol-name mode)))))
+			 mode)))
+    (re-search-forward regexp nil t)
+    ))
+
+(add-to-list 'find-function-regexp-alist '(define-overloadable-function . xref-mode-local-find-overloadable-regexp))
+(add-to-list 'find-function-regexp-alist (cons 'define-mode-local-override #'xref-mode-local-find-override))
+
 ;; 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))
+    (princ (format-message "\n     `%s' value is\n       " symbol))
     (if (and value (symbolp value))
-        (princ (format "`%s'" value))
+        (princ (format-message "`%s'" value))
       (let ((pt (point)))
         (pp value)
         (save-excursion
@@ -689,7 +825,7 @@ SYMBOL is a function that can be overridden."
       )
      ((symbolp buffer-or-mode)
       (setq mode buffer-or-mode)
-      (princ (format "`%s'\n" buffer-or-mode))
+      (princ (format-message "`%s'\n" buffer-or-mode))
       )
      ((signal 'wrong-type-argument
               (list 'buffer-or-mode buffer-or-mode))))
@@ -699,7 +835,7 @@ SYMBOL is a function that can be overridden."
     (while mode
       (setq table (get mode 'mode-local-symbol-table))
       (when table
-        (princ (format "\n- From `%s'\n" mode))
+        (princ (format-message "\n- From `%s'\n" mode))
         (mode-local-print-bindings table))
       (setq mode (get-mode-local-parent mode)))))
 
@@ -741,24 +877,6 @@ invoked interactively."
   (when (setq mode (intern-soft mode))
     (mode-local-describe-bindings-1 mode (called-interactively-p 'any))))
 
-;; ;;; 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)))))))
-
 ;;; edebug support
 ;;
 (defun mode-local-setup-edebug-specs ()