jbw%bucsf.BU.EDU@BU-CS.BU.EDU (Joe Wells) (04/24/89)
Here is the second release of fast-apropos. The only change is that
by default, it doesn't look up key bindings, and thus runs twice as
fast. The default can be changed by setting a variable.
In addition, I am including my version of super-apropos (idea from
Lynn Slater). It is substantially faster now, since it avoids about 2000
extra system calls by examining the DOC file directly.
fast-apropos displays the documentation for symbols whose names match a
regular expression. super-apropos displays the documentation for
symbols whose names or documentation match a regular expression.
Enjoy, and as usual, send me bug reports.
--
Joe Wells <jbw@bucsf.bu.edu>
jbw%bucsf.bu.edu@bu-it.bu.edu
...!harvard!bu-cs!bucsf!jbw
----------------------------------------------------------------------
;; Faster apropos commands.
;; Copyright (C) 1989 Free Software Foundation, Inc.
;; This file is not officially part of GNU Emacs, but is being donated
;; to the Free Software Foundation.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY. No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing. Refer to the GNU Emacs General Public
;; License for full details.
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License. A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities. It should be in a
;; file named COPYING. Among other things, the copyright notice
;; and this notice must be preserved on all copies.
;; Author: Joe Wells
;; Last changed: Sun Apr 23 22:00:27 1989 by jbw (Joseph Wells) on bucsf
;; jbw%bucsf.bu.edu@bu-it.bu.edu (school year)
;; joew%uswest@boulder.colorado.edu (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.
;; 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.
;; The idea for super-apropos is based on the original implementation
;; by Lynn Slater <address unknown>.
(defvar apropos-do-all nil
"*Should fast-apropos and super-apropos do everything that they can
by default. Makes them run 2 or 3 times slower.")
(defvar doc-file-name (concat exec-directory "DOC")
"The complete pathname of the documentation file that contains all
documentation for functions and variables defined before Emacs is
dumped.")
(defun fast-apropos (regexp &optional do-all)
"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. Returns list of symbols and
documentation found."
"Show all symbols whose names contain match for REGEXP.
If optional arg PRED is non-nil, (funcall PRED SYM) is done
for each symbol and a symbol is mentioned if that returns non-nil.
Returns list of symbols found; if third arg NOPRINT is non-nil,
does not display them, just returns the list."
(interactive "sFast-Apropos: \nP")
(setq do-all (or apropos-do-all do-all))
(let ((apropos-accumulate (apropos regexp nil t)))
(fast-apropos-get-doc apropos-accumulate)
(with-output-to-temp-buffer "*Help*"
(apropos-print-matches apropos-accumulate regexp nil do-all))
apropos-accumulate))
(defun fast-apropos-get-doc (list)
"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 fast-apropos."
(let (fn-doc var-doc symbol)
(while (consp list)
(setq symbol (car list)
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 list (list symbol fn-doc var-doc))
(setq list (cdr list))))
nil)
(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 do-all (mapatoms 'super-apropos-accumulate))
(with-output-to-temp-buffer "*Help*"
(apropos-print-matches apropos-accumulate nil t do-all))
apropos-accumulate))
(defun super-apropos-check-doc-file (regexp)
"Finds all documentation related to REGEXP in doc-file-name.
Returns an alist of form ((symbol fn-doc var-doc) ...)."
(let ((doc-buffer (or (get-file-buffer doc-file-name)
(find-file-noselect doc-file-name)))
type symbol doc sym-list)
(save-excursion
(set-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
2)
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))
(defun super-apropos-accumulate (symbol)
"DON'T USE THIS!
Helping function for super-apropos. 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!"
;; Uses these variables: fn-doc var-doc regexp item
(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)
(defun apropos-print-matches (matches &optional regexp spacing do-all)
"Helping function for fast-apropos and super-apropos. 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. Should only be called within a
with-output-to-temp-buffer."
(setq matches (sort matches (function
(lambda (a b)
(string-lessp (car a) (car b))))))
(save-excursion
(set-buffer standard-output)
(let ((p matches)
item keys-done symbol)
(while (consp p)
(setq item (car p)
symbol (car item)
p (cdr p))
(or (not spacing) (bobp) (terpri))
(prin1 symbol nil) ;print symbol name
;; don't calculate key-bindings unless needed
(cond ((and do-all (commandp symbol) (not keys-done))
(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 ", "))
(insert "(not bound to any keys)"))))
(terpri)
(if (setq tem (nth 1 item))
(insert " Function: " (substitute-command-keys tem)))
(or (bolp) (terpri))
(if (setq tem (nth 2 item))
(insert " Variable: " (substitute-command-keys tem)))
(or (bolp) (terpri)))))
nil)
(defun apropos-match-keys (alist &optional regexp)
"Find key bindings for symbols that are cars in ALIST. Optionally,
first match the symbol name against REGEXP. 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."
(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))
(cond ((consp map)
(setq map (cdr map)))) ;skip keymap symbol
(setq i 0)
(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)))
((vectorp map)
(setq command (aref map i)
key i
i (1+ i))))
;; 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)
(defun apropos-get-accum-item (symbol)
"DON'T USE THIS!
Get an alist item in alist apropos-accumulate whose car is SYMBOL.
Creates the item if not already present."
(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 will return nil instead of calling
get_doc_string()."
(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 will return nil instead of
calling get_doc_string()."
(setq symbol (get symbol 'variable-documentation))
(if (numberp symbol)
nil
symbol))