Initial revision

1 files changed, 323 insertions, 0 deletions

diff --git a/lisp/apropos.el b/lisp/apropos.el
new file mode 100644
index 00000000000..36e366e970b
--- /dev/null
+++ b/lisp/apropos.el
@@ -0,0 +1,323 @@
+;; Faster apropos commands.
+;; Copyright (C) 1989 Free Software Foundation, Inc.
+
+;; 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 1, 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; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;; Author: Joe Wells
+;; Last changed: Fri May  5 18:08:16 1989 by jbw (Joseph Wells) on bucsf
+;; jbw%bucsf.bu.edu@bu-it.bu.edu (school year)
+;; joew@uswest.com (summer)
+
+;; The ideas for this package were derived from the C code in
+;; src/keymap.c and elsewhere.  The functions in this file should
+;; always be byte-compiled for speed.  Someone should rewrite this in
+;; C (as part of src/keymap.c) for speed.
+
+;; The idea for super-apropos is based on the original implementation
+;; by Lynn Slater <lrs@esl.com>.
+
+;; History:
+;; Fixed bug, current-local-map can return nil.
+;; Change, doesn't calculate key-bindings unless needed.
+;; Added super-apropos capability, changed print functions.
+;; Made fast-apropos and super-apropos share code.
+;; Sped up fast-apropos again.
+;; Added apropos-do-all option.
+;; Added fast-command-apropos.
+;; Changed doc strings to comments for helping functions.
+;; Made doc file buffer read-only, buried it.
+;; Only call substitute-command-keys if do-all set.
+
+(defvar apropos-do-all nil
+  "*Whether `apropos' and `super-apropos' should do everything that they can.
+Makes them run 2 or 3 times slower.  Set this non-nil if you have a fast
+machine.")
+
+;; If there isn't already a lisp variable named internal-doc-file-name, create
+;; it and document it.  This is so the code will work right after RMS adds
+;; internal-doc-file-name.
+;(or (boundp 'internal-doc-file-name)
+;    (setq internal-doc-file-name (concat exec-directory "DOC")))
+;(or (documentation-property 'internal-doc-file-name 'variable-documentation)
+;    (put 'internal-doc-file-name 'variable-documentation
+;        "The complete pathname of the documentation file that contains all
+;documentation for functions and variables defined before Emacs is dumped."))
+
+;;;###autoload
+(defun apropos (regexp &optional do-all pred)
+  "Show all symbols whose names contain matches for REGEXP.
+If optional argument DO-ALL is non-nil, does more (time-consuming) work such as
+showing key bindings.  Optional argument PRED is called with each symbol, and
+if it returns nil, the symbol is not shown.
+
+Returns list of symbols and documentation found."
+  (interactive "sApropos (regexp): \nP")
+  (setq do-all (or apropos-do-all do-all))
+  (let ((apropos-accumulate (apropos-internal regexp pred)))
+    (if (null apropos-accumulate)
+        (message "No apropos matches for `%s'" regexp)
+      (apropos-get-doc apropos-accumulate)
+      (with-output-to-temp-buffer "*Help*"
+        (apropos-print-matches apropos-accumulate regexp nil do-all)))
+    apropos-accumulate))
+
+;; If "C-h a" still has its original binding of command-apropos, change it to
+;; use fast-command-apropos.  I don't use substitute-key-definition because
+;; it's slow.
+;(if (eq 'command-apropos (lookup-key help-map "a"))
+;    (define-key help-map "a" 'fast-command-apropos))
+
+;; Takes LIST of symbols and adds documentation.  Modifies LIST in place.
+;; Resulting alist is of form ((symbol fn-doc var-doc) ...).  Should only be
+;; called by apropos.  Returns LIST.
+
+(defun apropos-get-doc (list)
+  (let ((p list)
+        fn-doc var-doc symbol)
+    (while (consp p)
+      (setq symbol (car p)
+            fn-doc (and (fboundp symbol)
+                        (documentation symbol))
+            var-doc (documentation-property symbol 'variable-documentation)
+            fn-doc (and fn-doc
+                        (substring fn-doc 0 (string-match "\n" fn-doc)))
+            var-doc (and var-doc
+                         (substring var-doc 0 (string-match "\n" var-doc))))
+      (setcar p (list symbol fn-doc var-doc))
+      (setq p (cdr p)))
+    list))
+
+;;;###autoload
+(defun super-apropos (regexp &optional do-all)
+  "Show symbols whose names/documentation contain matches for REGEXP.
+If optional argument DO-ALL is non-nil, does more (time-consuming) work such as
+showing key bindings and documentation that is not stored in the documentation
+file.
+
+Returns list of symbols and documentation found."
+  (interactive "sSuper Apropos: \nP")
+  (setq do-all (or apropos-do-all do-all))
+  (let (apropos-accumulate fn-doc var-doc item)
+    (setq apropos-accumulate (super-apropos-check-doc-file regexp))
+    (if (null apropos-accumulate)
+        (message "No apropos matches for `%s'" regexp)
+      (if do-all (mapatoms 'super-apropos-accumulate))
+      (with-output-to-temp-buffer "*Help*"
+        (apropos-print-matches apropos-accumulate nil t do-all)))
+    apropos-accumulate))
+
+;; Finds all documentation related to REGEXP in internal-doc-file-name.
+;; Returns an alist of form ((symbol fn-doc var-doc) ...).
+
+(defun super-apropos-check-doc-file (regexp)
+  (let ((doc-buffer (find-file-noselect internal-doc-file-name t))
+        ;;      (doc-buffer (or (get-file-buffer internal-doc-file-name)
+        ;;                      (find-file-noselect internal-doc-file-name)))
+        type symbol doc sym-list)
+    (save-excursion
+      (set-buffer doc-buffer)
+      ;; a user said he might accidentally edit the doc file
+      (setq buffer-read-only t)
+      (bury-buffer doc-buffer)
+      (goto-char (point-min))
+      (while (re-search-forward regexp nil t)
+        (search-backward "\C-_")
+        (setq type (if (eq ?F (char-after (1+ (point))))
+                       1                ;function documentation
+                     2)                 ;variable documentation
+              symbol (progn
+                       (forward-char 2)
+                       (read doc-buffer))
+              doc (buffer-substring
+                   (point)
+                   (progn
+                     (if (search-forward "\C-_" nil 'move)
+                         (1- (point))
+                       (point))))
+              item (assq symbol sym-list))
+        (or item
+            (setq item (list symbol nil nil)
+                  sym-list (cons item sym-list)))
+        (setcar (nthcdr type item) doc)))
+    sym-list))
+
+;; This is passed as the argument to map-atoms, so it is called once for every
+;; symbol in obarray.  Takes one argument SYMBOL, and finds any memory-resident
+;; documentation on that symbol if it matches a variable regexp.  WARNING: this
+;; function depends on the symbols fn-doc var-doc regexp and item being bound
+;; correctly when it is called!"
+
+(defun super-apropos-accumulate (symbol)
+  (cond ((string-match regexp (symbol-name symbol))
+         (setq item (apropos-get-accum-item symbol))
+         (setcar (cdr item) (or (safe-documentation symbol)
+                                (nth 1 item)))
+         (setcar (nthcdr 2 item) (or (safe-documentation-property symbol)
+                                     (nth 2 item))))
+        (t
+         (and (setq fn-doc (safe-documentation symbol))
+              (string-match regexp fn-doc)
+              (setcar (cdr (apropos-get-accum-item symbol)) fn-doc))
+         (and (setq var-doc (safe-documentation-property symbol))
+              (string-match regexp var-doc)
+              (setcar (nthcdr 2 (apropos-get-accum-item symbol)) var-doc))))
+  nil)
+
+;; Prints the symbols and documentation in alist MATCHES of form ((symbol
+;; fn-doc var-doc) ...).  Uses optional argument REGEXP to speed up searching
+;; for keybindings.  The names of all symbols in MATCHES must match REGEXP.
+;; Displays in the buffer pointed to by standard-output.  Optional argument
+;; SPACING means put blank lines in between each symbol's documentation.
+;; Optional argument DO-ALL means do more time-consuming work, specifically,
+;; consulting key bindings.  Should only be called within a
+;; with-output-to-temp-buffer.
+
+(defun apropos-print-matches (matches &optional regexp spacing do-all)
+  (setq matches (sort matches (function
+                               (lambda (a b)
+                                 (string-lessp (car a) (car b))))))
+  (let ((p matches)
+        (old-buffer (current-buffer))
+        item keys-done symbol)
+    (save-excursion
+      (set-buffer standard-output)
+      (or matches (princ "No matches found."))
+      (while (consp p)
+        (setq item (car p)
+              symbol (car item)
+              p (cdr p))
+        (or (not spacing) (bobp) (terpri))
+        (princ symbol)                  ;print symbol name
+        ;; don't calculate key-bindings unless needed
+        (cond ((and do-all (commandp symbol) (not keys-done))
+               (save-excursion
+                 (set-buffer old-buffer)
+                 (apropos-match-keys matches regexp))
+               (setq keys-done t)))
+        (cond ((and do-all
+                    (or (setq tem (nthcdr 3 item))
+                        (commandp symbol)))
+               (indent-to 30 1)
+               (if tem
+                   (princ (mapconcat 'key-description tem ", "))
+                 (princ "(not bound to any keys)"))))
+        (terpri)
+        (cond ((setq tem (nth 1 item))
+               (princ "  Function: ")
+               (princ (if do-all (substitute-command-keys tem) tem))))
+        (or (bolp) (terpri))
+        (cond ((setq tem (nth 2 item))
+               (princ "  Variable: ")
+               (princ (if do-all (substitute-command-keys tem) tem))))
+        (or (bolp) (terpri)))))
+  t)
+
+;; Find key bindings for symbols that are cars in ALIST.  Optionally, first
+;; match the symbol name against REGEXP.  Modifies ALIST in place.  Each key
+;; binding is added as a string to the end of the list in ALIST whose car is
+;; the corresponding symbol.  The pointer to ALIST is returned.
+
+(defun apropos-match-keys (alist &optional regexp)
+  (let* ((current-local-map (current-local-map))
+         (maps (append (and current-local-map
+                            (accessible-keymaps current-local-map))
+                       (accessible-keymaps (current-global-map))))
+         map                            ;map we are now inspecting
+         sequence                       ;key sequence to reach map
+         i                              ;index into vector map
+         command                        ;what is bound to current keys
+         key                            ;last key to reach command
+         local                          ;local binding for sequence + key
+         item)                          ;symbol data item in alist
+    ;; examine all reachable keymaps
+    (while (consp maps)
+      (setq map (cdr (car maps))
+            sequence (car (car maps))   ;keys to reach this map
+            maps (cdr maps))
+      (setq i 0)
+      ;; In an alist keymap, skip the leading `keymap', doc string, etc.
+      (while (and (consp map) (not (consp (car map))))
+        (setq map (cdr map)))
+      (while (and map (< i 128))        ;vector keymaps have 128 entries
+        (cond ((consp map)
+               (setq command (cdr (car map))
+                     key (car (car map))
+                     map (cdr map))
+               ;; Skip any atoms in the keymap.
+               (while (and (consp map) (not (consp (car map))))
+                 (setq map (cdr map))))
+              ((vectorp map)
+               (setq command (aref map i)
+                     key i
+                     i (1+ i))))
+        ;; Skip any menu prompt in this key binding.
+        (and (consp command) (symbolp (cdr command))
+             (setq command (cdr command)))
+        ;; if is a symbol, and matches optional regexp, and is a car
+        ;; in alist, and is not shadowed by a different local binding,
+        ;; record it
+        (and (symbolp command)
+             (if regexp (string-match regexp (symbol-name command)))
+             (setq item (assq command alist))
+             (setq key (concat sequence (char-to-string key)))
+             ;; checking if shadowed by local binding.
+             ;; either no local map, no local binding, or runs off the
+             ;; binding tree (number), or is the same binding
+             (or (not current-local-map)
+                 (not (setq local (lookup-key current-local-map key)))
+                 (numberp local)
+                 (eq command local))
+             ;; add this key binding to the item in alist
+             (nconc item (cons key nil))))))
+  alist)
+
+;; Get an alist item in alist apropos-accumulate whose car is SYMBOL.  Creates
+;; the item if not already present.  Modifies apropos-accumulate in place.
+
+(defun apropos-get-accum-item (symbol)
+  (or (assq symbol apropos-accumulate)
+      (progn
+        (setq apropos-accumulate
+              (cons (list symbol nil nil) apropos-accumulate))
+        (assq symbol apropos-accumulate))))
+
+(defun safe-documentation (function)
+  "Like documentation, except it avoids calling `get_doc_string'.
+Will return nil instead."
+  (while (symbolp function)
+    (setq function (if (fboundp function)
+                       (symbol-function function)
+                     0)))
+  (if (not (consp function))
+      nil
+    (if (eq (car function) 'macro)
+        (setq function (cdr function)))
+    (if (not (memq (car function) '(lambda autoload)))
+        nil
+      (setq function (nth 2 function))
+      (if (stringp function)
+          function
+        nil))))
+
+(defun safe-documentation-property (symbol)
+  "Like documentation-property, except it avoids calling `get_doc_string'.
+Will return nil instead."
+  (setq symbol (get symbol 'variable-documentation))
+  (if (numberp symbol)
+      nil
+    symbol))
+