Merge from origin/emacs-25

[gnu-emacs] / lisp / apropos.el

diff --git a/lisp/apropos.el b/lisp/apropos.el
index 000d2d87d056d490f2cb605f3172b7919274c4ae..7c9ec12c2e0bb7601a8f9f5bd9ebaa074f8e118b 100644 (file)
--- a/lisp/apropos.el
+++ b/lisp/apropos.el
@@ -1,6 +1,6 @@
 ;;; apropos.el --- apropos commands for users and programmers
 
 ;;; apropos.el --- apropos commands for users and programmers
 

-;; Copyright (C) 1989, 1994-1995, 2001-2013 Free Software Foundation,
+;; Copyright (C) 1989, 1994-1995, 2001-2016 Free Software Foundation,

 ;; Inc.
 
 ;; Author: Joe Wells <jbw@bigbird.bu.edu>
 ;; Inc.
 
 ;; Author: Joe Wells <jbw@bigbird.bu.edu>


@@ -99,7 +99,7 @@ include key-binding information in its output."
 
 (defface apropos-property
   '((t (:inherit font-lock-builtin-face)))
 
 (defface apropos-property
   '((t (:inherit font-lock-builtin-face)))

-  "Face for property name in apropos output, or nil for none."
+  "Face for property name in Apropos output, or nil for none."

   :group 'apropos
   :version "24.3")
 
   :group 'apropos
   :version "24.3")
 


@@ -131,6 +131,7 @@ include key-binding information in its output."
   "Face for matching text in Apropos documentation/value, or nil for none.
 This applies when you look for matches in the documentation or variable value
 for the pattern; the part that matches gets displayed in this font."
   "Face for matching text in Apropos documentation/value, or nil for none.
 This applies when you look for matches in the documentation or variable value
 for the pattern; the part that matches gets displayed in this font."

+  :type '(choice (const nil) face)

   :group 'apropos
   :version "24.3")
 
   :group 'apropos
   :version "24.3")
 


@@ -181,7 +182,7 @@ If value is `verbose', the computed score is shown for each match."
   "Regexp used in current apropos run.")
 
 (defvar apropos-all-words-regexp nil
   "Regexp used in current apropos run.")
 
 (defvar apropos-all-words-regexp nil

-  "Regexp matching apropos-all-words.")
+  "Regexp matching `apropos-all-words'.")

 
 (defvar apropos-files-scanned ()
   "List of elc files already scanned in current run of `apropos-documentation'.")
 
 (defvar apropos-files-scanned ()
   "List of elc files already scanned in current run of `apropos-documentation'.")


@@ -341,16 +342,21 @@ before finding a label."
 
 \f
 (defun apropos-words-to-regexp (words wild)
 
 \f
 (defun apropos-words-to-regexp (words wild)

-  "Make regexp matching any two of the words in WORDS."
-  (concat "\\("
-         (mapconcat 'identity words "\\|")
-         "\\)"
-         (if (cdr words)
-             (concat wild
-                     "\\("
-                     (mapconcat 'identity words "\\|")
-                     "\\)")
-           "")))
+  "Make regexp matching any two of the words in WORDS.
+WILD should be a subexpression matching wildcards between matches."
+  (setq words (delete-dups (copy-sequence words)))
+  (if (null (cdr words))
+      (car words)
+    (mapconcat
+     (lambda (w)
+       (concat "\\(?:" w "\\)" ;; parens for synonyms
+               wild "\\(?:"
+               (mapconcat 'identity
+                         (delq w (copy-sequence words))
+                         "\\|")
+               "\\)"))
+     words
+     "\\|")))

 
 ;;;###autoload
 (defun apropos-read-pattern (subject)
 
 ;;;###autoload
 (defun apropos-read-pattern (subject)


@@ -364,7 +370,8 @@ kind of objects to search."
         (read-string (concat "Search for " subject " (word list or regexp): "))))
     (if (string-equal (regexp-quote pattern) pattern)
        ;; Split into words
         (read-string (concat "Search for " subject " (word list or regexp): "))))
     (if (string-equal (regexp-quote pattern) pattern)
        ;; Split into words

-       (split-string pattern "[ \t]+" t)
+       (or (split-string pattern "[ \t]+" t)
+           (user-error "No word list given"))

       pattern)))
 
 (defun apropos-parse-pattern (pattern)
       pattern)))
 
 (defun apropos-parse-pattern (pattern)


@@ -404,7 +411,6 @@ This updates variables `apropos-pattern', `apropos-pattern-quoted',
          apropos-pattern pattern
          apropos-regexp pattern)))
 
          apropos-pattern pattern
          apropos-regexp pattern)))
 

-

 (defun apropos-calc-scores (str words)
   "Return apropos scores for string STR matching WORDS.
 Value is a list of offsets of the words into the string."
 (defun apropos-calc-scores (str words)
   "Return apropos scores for string STR matching WORDS.
 Value is a list of offsets of the words into the string."


@@ -448,7 +454,7 @@ Value is a list of offsets of the words into the string."
 (defun apropos-true-hit (str words)
   "Return t if STR is a genuine hit.
 This may fail if only one of the keywords is matched more than once.
 (defun apropos-true-hit (str words)
   "Return t if STR is a genuine hit.
 This may fail if only one of the keywords is matched more than once.

-This requires that at least 2 keywords (unless only one was given)."
+This requires at least two keywords (unless only one was given)."

   (or (not str)
       (not words)
       (not (cdr words))
   (or (not str)
       (not words)
       (not (cdr words))


@@ -499,8 +505,9 @@ variables, not just user options."
 ;;;###autoload
 (defun apropos-variable (pattern &optional do-not-all)
   "Show variables that match PATTERN.
 ;;;###autoload
 (defun apropos-variable (pattern &optional do-not-all)
   "Show variables that match PATTERN.

-When DO-NOT-ALL is not-nil, show user options only, i.e. behave
-like `apropos-user-option'."
+With the optional argument DO-NOT-ALL non-nil (or when called
+interactively with the prefix \\[universal-argument]), show user
+options only, i.e. behave like `apropos-user-option'."

   (interactive (list (apropos-read-pattern
                      (if current-prefix-arg "user option" "variable"))
                      current-prefix-arg))
   (interactive (list (apropos-read-pattern
                      (if current-prefix-arg "user option" "variable"))
                      current-prefix-arg))


@@ -670,12 +677,17 @@ the output includes key-bindings of commands."
        ;; (autoload (push (cdr x) autoloads))
        (`require (push (cdr x) requires))
        (`provide (push (cdr x) provides))
        ;; (autoload (push (cdr x) autoloads))
        (`require (push (cdr x) requires))
        (`provide (push (cdr x) provides))

+        (`t nil) ; Skip "was an autoload" entries.
+        ;; FIXME: Print information about each individual method: both
+        ;; its docstring and specializers (bug#21422).
+        (`cl-defmethod (push (cadr x) provides))

        (_ (push (or (cdr-safe x) x) symbols))))
     (let ((apropos-pattern "")) ;Dummy binding for apropos-symbols-internal.
       (apropos-symbols-internal
        symbols apropos-do-all
        (concat
        (_ (push (or (cdr-safe x) x) symbols))))
     (let ((apropos-pattern "")) ;Dummy binding for apropos-symbols-internal.
       (apropos-symbols-internal
        symbols apropos-do-all
        (concat

-        (format "Library `%s' provides: %s\nand requires: %s"
+        (format-message
+                "Library `%s' provides: %s\nand requires: %s"

                 file
                 (mapconcat 'apropos-library-button
                            (or provides '(nil)) " and ")
                 file
                 (mapconcat 'apropos-library-button
                            (or provides '(nil)) " and ")


@@ -712,7 +724,7 @@ the output includes key-bindings of commands."
                 (setq doc (list (car properties)))
                 (while (setq properties (cdr (cdr properties)))
                   (setq doc (cons (car properties) doc)))
                 (setq doc (list (car properties)))
                 (while (setq properties (cdr (cdr properties)))
                   (setq doc (cons (car properties) doc)))

-                (mapconcat #'symbol-name (nreverse doc) " "))
+                (mapconcat (lambda (p) (format "%s" p)) (nreverse doc) " "))

               (when (get symbol 'widget-type)
                 (apropos-documentation-property
                  symbol 'widget-documentation t))
               (when (get symbol 'widget-type)
                 (apropos-documentation-property
                  symbol 'widget-documentation t))


@@ -720,11 +732,10 @@ the output includes key-bindings of commands."
                 (let ((alias (get symbol 'face-alias)))
                   (if alias
                       (if (facep alias)
                 (let ((alias (get symbol 'face-alias)))
                   (if alias
                       (if (facep alias)

-                          (format "%slias for the face `%s'."
-                                  (if (get symbol 'obsolete-face)
-                                      "Obsolete a"
-                                    "A")
-                                  alias)
+                          (format-message
+                           "%slias for the face `%s'."
+                           (if (get symbol 'obsolete-face) "Obsolete a" "A")
+                           alias)

                         ;; Never happens in practice because fails
                         ;; (facep symbol) test.
                         "(alias for undefined face)")
                         ;; Never happens in practice because fails
                         ;; (facep symbol) test.
                         "(alias for undefined face)")


@@ -817,7 +828,7 @@ Returns list of symbols and documentation found."
               (lambda (symbol)
                 (setq f (apropos-safe-documentation symbol)
                       v (get symbol 'variable-documentation))
               (lambda (symbol)
                 (setq f (apropos-safe-documentation symbol)
                       v (get symbol 'variable-documentation))

-                (if (integerp v) (setq v))
+                (if (integerp v) (setq v nil))

                 (setq f (apropos-documentation-internal f)
                       v (apropos-documentation-internal v))
                 (setq sf (apropos-score-doc f)
                 (setq f (apropos-documentation-internal f)
                       v (apropos-documentation-internal v))
                 (setq sf (apropos-score-doc f)


@@ -856,19 +867,23 @@ Returns list of symbols and documentation found."
              symbol)))))
 
 (defun apropos-documentation-internal (doc)
              symbol)))))
 
 (defun apropos-documentation-internal (doc)

-  (if (consp doc)
-      (apropos-documentation-check-elc-file (car doc))
-    (if (and doc
-            (string-match apropos-all-words-regexp doc)
-            (apropos-true-hit-doc doc))
-       (when apropos-match-face
-         (setq doc (substitute-command-keys (copy-sequence doc)))
-         (if (or (string-match apropos-pattern-quoted doc)
-                 (string-match apropos-all-words-regexp doc))
-             (put-text-property (match-beginning 0)
-                                (match-end 0)
-                                'face apropos-match-face doc))
-         doc))))
+  (cond
+   ((consp doc)
+    (apropos-documentation-check-elc-file (car doc)))
+   ((and doc
+         ;; Sanity check in case bad data sneaked into the
+         ;; documentation slot.
+         (stringp doc)
+         (string-match apropos-all-words-regexp doc)
+         (apropos-true-hit-doc doc))
+    (when apropos-match-face
+      (setq doc (substitute-command-keys (copy-sequence doc)))
+      (if (or (string-match apropos-pattern-quoted doc)
+              (string-match apropos-all-words-regexp doc))
+          (put-text-property (match-beginning 0)
+                             (match-end 0)
+                             'face apropos-match-face doc))
+      doc))))

 
 (defun apropos-format-plist (pl sep &optional compare)
   (setq pl (symbol-plist pl))
 
 (defun apropos-format-plist (pl sep &optional compare)
   (setq pl (symbol-plist pl))


@@ -1000,8 +1015,7 @@ Returns list of symbols and documentation found."
   "Like `documentation', except it avoids calling `get_doc_string'.
 Will return nil instead."
   (while (and function (symbolp function))
   "Like `documentation', except it avoids calling `get_doc_string'.
 Will return nil instead."
   (while (and function (symbolp function))

-    (setq function (if (fboundp function)
-                      (symbol-function function))))
+    (setq function (symbol-function function)))

   (if (eq (car-safe function) 'macro)
       (setq function (cdr function)))
   (setq function (if (byte-code-function-p function)
   (if (eq (car-safe function) 'macro)
       (setq function (cdr function)))
   (setq function (if (byte-code-function-p function)


@@ -1030,16 +1044,17 @@ Each element should have the format
 The return value is the list that was in `apropos-accumulator', sorted
 alphabetically by symbol name; but this function also sets
 `apropos-accumulator' to nil before returning.
 The return value is the list that was in `apropos-accumulator', sorted
 alphabetically by symbol name; but this function also sets
 `apropos-accumulator' to nil before returning.

-
-If SPACING is non-nil, it should be a string; separate items with that string.
-If non-nil TEXT is a string that will be printed as a heading."
+If DO-KEYS is non-nil, output the key bindings.  If NOSUBST is
+nil, substitute \"ASCII quotes\" (i.e., grace accent and
+apostrophe) with curly quotes), and if non-nil, leave them alone.
+If SPACING is non-nil, it should be a string; separate items with
+that string.  If non-nil, TEXT is a string that will be printed
+as a heading."

   (if (null apropos-accumulator)
       (message "No apropos matches for `%s'" apropos-pattern)
     (setq apropos-accumulator
          (sort apropos-accumulator
                (lambda (a b)
   (if (null apropos-accumulator)
       (message "No apropos matches for `%s'" apropos-pattern)
     (setq apropos-accumulator
          (sort apropos-accumulator
                (lambda (a b)

-                 ;; Don't sort by score if user can't see the score.
-                 ;; It would be confusing.  -- rms.

                  (if apropos-sort-by-scores
                      (or (> (cadr a) (cadr b))
                          (and (= (cadr a) (cadr b))
                  (if apropos-sort-by-scores
                      (or (> (cadr a) (cadr b))
                          (and (= (cadr a) (cadr b))


@@ -1049,6 +1064,7 @@ If non-nil TEXT is a string that will be printed as a heading."
       (let ((p apropos-accumulator)
            (old-buffer (current-buffer))
            (inhibit-read-only t)
       (let ((p apropos-accumulator)
            (old-buffer (current-buffer))
            (inhibit-read-only t)

+           (button-end 0)

            symbol item)
        (set-buffer standard-output)
        (apropos-mode)
            symbol item)
        (set-buffer standard-output)
        (apropos-mode)


@@ -1066,10 +1082,12 @@ If non-nil TEXT is a string that will be printed as a heading."
              (setq apropos-item
                    (cons (car apropos-item)
                          (cons nil (cdr apropos-item)))))
              (setq apropos-item
                    (cons (car apropos-item)
                          (cons nil (cdr apropos-item)))))

+         (when (= (point) button-end) (terpri))

          (insert-text-button (symbol-name symbol)
                              'type 'apropos-symbol
                              'skip apropos-multi-type
                              'face 'apropos-symbol)
          (insert-text-button (symbol-name symbol)
                              'type 'apropos-symbol
                              'skip apropos-multi-type
                              'face 'apropos-symbol)

+         (setq button-end (point))

          (if (and (eq apropos-sort-by-scores 'verbose)
                   (cadr apropos-item))
              (insert " (" (number-to-string (cadr apropos-item)) ") "))
          (if (and (eq apropos-sort-by-scores 'verbose)
                   (cadr apropos-item))
              (insert " (" (number-to-string (cadr apropos-item)) ") "))


@@ -1121,7 +1139,7 @@ If non-nil TEXT is a string that will be printed as a heading."
          (apropos-print-doc 2
                             (if (commandp symbol)
                                 'apropos-command
          (apropos-print-doc 2
                             (if (commandp symbol)
                                 'apropos-command

-                              (if (apropos-macrop symbol)
+                              (if (macrop symbol)

                                   'apropos-macro
                                 'apropos-function))
                             (not nosubst))
                                   'apropos-macro
                                 'apropos-function))
                             (not nosubst))


@@ -1139,17 +1157,6 @@ If non-nil TEXT is a string that will be printed as a heading."
   (prog1 apropos-accumulator
     (setq apropos-accumulator ())))    ; permit gc
 
   (prog1 apropos-accumulator
     (setq apropos-accumulator ())))    ; permit gc
 

-(defun apropos-macrop (symbol)
-  "Return t if SYMBOL is a Lisp macro."
-  (and (fboundp symbol)
-       (consp (setq symbol
-                   (symbol-function symbol)))
-       (or (eq (car symbol) 'macro)
-          (if (autoloadp symbol)
-              (memq (nth 4 symbol)
-                    '(macro t))))))
-
-

 (defun apropos-print-doc (i type do-keys)
   (let ((doc (nth i apropos-item)))
     (when (stringp doc)
 (defun apropos-print-doc (i type do-keys)
   (let ((doc (nth i apropos-item)))
     (when (stringp doc)


@@ -1210,7 +1217,7 @@ If non-nil TEXT is a string that will be printed as a heading."
     (set-buffer standard-output)
     (princ "Symbol ")
     (prin1 symbol)
     (set-buffer standard-output)
     (princ "Symbol ")
     (prin1 symbol)

-    (princ "'s plist is\n (")
+    (princ (substitute-command-keys "'s plist is\n ("))

     (put-text-property (+ (point-min) 7) (- (point) 14)
                       'face 'apropos-symbol)
     (insert (apropos-format-plist symbol "\n  "))
     (put-text-property (+ (point-min) 7) (- (point) 14)
                       'face 'apropos-symbol)
     (insert (apropos-format-plist symbol "\n  "))