jbw%bucsf.BU.EDU@BU-CS.BU.EDU (Joe Wells) (03/24/89)
I got annoyed today at how long M-x apropos took on the simple request
"window". It took MINUTES! So I rewrote it.
This version is anywhere from 2 to 30 times faster than regular
apropos, even though it is in lisp and the original was in C. The
original version of apropos traversed the entire key-binding tree for
each symbol that your request found. This takes a LONG TIME. My
version traverses the key-binding tree just once, for all of the
symbols for which it wants to find key bindings. It should complete
any request in a few seconds.
Have fun, and of course, send bugs to me ...
--
Joe Wells
INTERNET: jbw%bucsf.bu.edu@bu-it.bu.edu IP: [128.197.10.201]
UUCP: ...!harvard!bu-cs!bucsf!jbw
----------------------------------------------------------------------
;; Faster apropos command.
;; 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
;; 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.
(defun fast-apropos (string &optional pred noprint)
"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: ")
(let ((list (apropos string pred t)))
(or noprint
(with-output-to-temp-buffer "*Help*"
(fast-apropos1 string pred list)))
list))
(defun fast-apropos1 (string pred list)
"Helping function for fast-apropos.
Equivalent to apropos1 in src/keymap.c except that it's a lot faster
and it's written in lisp. Using REGEXP and PRED, displays LIST of
symbols in the buffer pointed to by standard-output, along with neat
info like function and variable documentation and key bindings.
Should only be called by fast-apropos."
(let ((keys (match-all-keys string pred))
;; (current-local-map (current-local-map))
symbol tem)
(save-excursion
(set-buffer standard-output)
(while (consp list)
(setq symbol (car list)
list (cdr list))
(prin1 symbol nil)
(cond ((commandp symbol)
(indent-to 30 1)
;; (setq tem (where-is-internal symbol current-local-map nil))
(setq tem (assq symbol keys))
(if tem
(princ (mapconcat 'key-description
;; tem
(cdr tem)
", ") nil)
(insert "(not bound to any keys)"))))
(terpri nil)
(cond ((fboundp symbol)
(setq tem (documentation symbol))
(if (stringp tem)
(insert " Function: "
(substring tem 0 (string-match "\n" tem))
"\n"))))
(setq tem (documentation-property symbol 'variable-documentation))
(if (stringp tem)
(insert " Variable: "
(substring tem 0 (string-match "\n" tem))
"\n")))))
nil)
(defun match-all-keys (regexp pred)
"Find key bindings for symbols matching REGEXP and passing PRED.
If PRED is non-nil, (funcall PRED SYMBOL) is done before a symbol is
included in the list. The return value is in the form ((SYMBOL KEYS
...) ...)."
(let* ((current-local-map (current-local-map))
(maps (nconc (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
found ;key bindings found so far
command ;what is bound to current keys
key ;last key to reach command
local ;local binding for sequence + key
item) ;key binding in found list
;; 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 regexp, and passes pred, and is
;; not shadowed by a different local binding, record it
(and (symbolp command)
(string-match regexp (symbol-name command))
(if pred (funcall pred symbol) t)
(setq key (concat sequence (char-to-string key)))
;; checking if shadowed by local binding
;; either no local binding, or runs off the binding tree
;; (number), or is the same binding
(or (not (setq local (lookup-key current-local-map key)))
(numberp local)
(eq command local))
(setq key (cons key nil))
;; if this command is already in found, just add the key
;; sequence, else add the (command keys) item
(if (setq item (assq command found))
(nconc item key)
(setq found (cons (cons command key) found))))))
found))