--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/packages/hyper-apropos.el	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,888 @@
+;;; hyper-apropos.el --- Hypertext emacs lisp documentation interface.
+
+;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp.
+;; Copyright (C) 1995 Sun Microsystems.
+;; Copyright (C) 1996 Ben Wing.
+
+;; Maintainer: Jonathan Stigelman <Stig@hackvan.com>
+;; Keywords: lisp, tools, help, docs, matching
+
+;; This file is part of XEmacs.
+
+;; XEmacs 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 2 of the License, or
+;; (at your option) any later version.
+;; 
+;; XEmacs 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 XEmacs; if not, write to the Free Software
+;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Synched up with: Not in FSF.
+
+;;; Commentary:
+
+;;  based upon emacs-apropos.el by Frank C. Guida <fcg@philabs.philips.com>
+;;
+;;  Rather than run apropos and print all the documentation at once,
+;;  I find it easier to view a "table of contents" first, then
+;;  get the details for symbols as you need them.
+;;
+;;  This version of apropos prints two lists of symbols matching the
+;;  given regexp:  functions/macros and variables/constants.
+;;
+;;  The user can then do the following:
+;;
+;;      - add an additional regexp to narrow the search
+;;      - display documentation for the current symbol
+;;      - find the tag for the current symbol
+;;      - show any keybindings if the current symbol is a command
+;;	- invoke functions
+;;	- set variables
+;;
+;;  An additional feature is the ability to search the current tags
+;;  table, allowing you to interrogate functions not yet loaded (this
+;;  isn't available with the standard package).
+;;
+;;  Mouse bindings and menus are provided for XEmacs.
+;;
+;; additions by Ben Wing <wing@666.com> July 1995:
+;; added support for function aliases, made programmer's apropos be the
+;; default, various other hacking.
+
+;;; Code:
+
+(or (fboundp 'pprint)
+    (progn (autoload 'pp "pp")
+	   (fset 'pprint 'pp)))
+;;(require 'tags "etags")
+
+;;;###autoload
+(defvar hypropos-show-brief-docs t
+  "*If non-nil, `hyper-apropos' will display some documentation in the
+\"*Hyper Apropos*\" buffer.  Setting this to nil will speed up searches.")
+
+(defvar hypropos-prettyprint-long-values t
+  "*If non-nil, then try to beautify the printing of very long values.")
+
+;; I changed this to true because I think it's more useful this way. --ben
+
+(defvar hypropos-programming-apropos t
+  "*If non-nil, then `hyper-apropos' takes a bit longer and generates more
+output.  If nil, then only functions that are interactive and variables that
+are user variables are found by `hyper-apropos'.")
+
+(defvar hypropos-prev-wconfig)
+
+;; #### - move this to subr.el
+(or (fboundp 'event-buffer)
+    (defun event-buffer (event)
+      "Returns the buffer associated with event, or nil."
+      (let ((win (event-window event)))
+	(and win (window-buffer win)))))
+
+(defmacro eval-in-buffer (buffer &rest forms)
+  "Evaluate FORMS in BUFFER."
+  (` (let ((_unwind_buf_ (current-buffer)))
+       (unwind-protect
+	   (progn (set-buffer (, buffer))
+		  (,@ forms))
+	 (set-buffer _unwind_buf_)))))
+(put 'eval-in-buffer 'lisp-indent-function 'defun)
+	 
+;; #### - move to faces.el
+(defmacro init-face (face &rest init-forms)
+  "Make a FACE if it doesn't already exist.  Then if it does not differ from
+the default face, execute INIT-FORMS to initialize the face.  While the
+init-forms are executing, the symbol `this' is bound to the face-object
+being initialized." 
+  (` (let ((this (make-face (, face))))	; harmless if the face is already there
+     (or (face-differs-from-default-p this)
+	 (, (cons 'progn init-forms))))))
+(put 'init-face 'lisp-indent-function 'defun)
+
+(init-face 'hyperlink
+  (copy-face 'bold this)
+  ;;(set-face-underline-p this nil) -- dog slow and ugly
+  (condition-case nil
+      (set-face-foreground this "blue")
+    (error nil)))
+(init-face 'documentation
+  (let* ((ff-instance (face-font-instance 'default))
+	(ff (and ff-instance (font-instance-name ff-instance))))
+    (cond ((and ff (string-match "courier" ff))
+	   ;; too wide unless you shrink it
+	   ;; (copy-face 'italic this) fugly.
+	   ;; (make-face-smaller this) fugly.
+	   ))
+    (condition-case nil
+	(set-face-foreground this "firebrick")
+      (error (copy-face 'italic this)))))
+
+;; mucking with the sizes of fonts (perhaps with the exception of courier or
+;; misc) is a generally losing thing to do.  Changing the size of 'clean'
+;; really loses, for instance...
+
+(init-face 'major-heading
+  (copy-face 'bold this)
+  (make-face-larger this)
+  (make-face-larger this))
+(init-face 'section-heading
+  (copy-face 'bold this)
+  (make-face-larger this))
+(init-face 'heading
+  (copy-face 'bold this))
+(init-face 'standout
+  (copy-face 'italic this))
+
+(init-face 'warning
+  (copy-face 'bold this)
+  (and (eq (device-type) 'x)
+       (eq (device-class) 'color)
+       (set-face-foreground this "red")))
+
+(defvar hypropos-help-map (let ((map (make-sparse-keymap)))
+			    (suppress-keymap map)
+			    (set-keymap-name map 'hypropos-help-map)
+			    ;; movement
+			    (define-key map " "     'scroll-up)
+			    (define-key map "b"     'scroll-down)
+			    (define-key map "/"     'isearch-forward)
+			    (define-key map "?"     'isearch-backward)
+			    ;; follow links
+			    (define-key map "\r"    'hypropos-get-doc)
+			    (define-key map "s"     'hypropos-set-variable)
+			    (define-key map "t"     'hypropos-find-tag)
+			    (define-key map "l"     'hypropos-last-help)
+			    (define-key map [button2] 'hypropos-mouse-get-doc)
+			    (define-key map [button3] 'hypropos-popup-menu)
+			    ;; for the totally hardcore...
+			    (define-key map "D"     'hypropos-disassemble)
+			    ;; administrativa
+			    (define-key map "a"     'hyper-apropos)
+			    (define-key map "n"     'hyper-apropos)
+			    (define-key map "q"     'hypropos-quit)
+			    map
+			    )
+  "Keybindings for both the *Hyper Help* buffer and the *Hyper Apropos* buffer")
+
+(defvar hypropos-map (let ((map (make-sparse-keymap)))
+		       (set-keymap-name map 'hypropos-map)
+		       (set-keymap-parents map (list hypropos-help-map))
+		       ;; slightly differrent scrolling...
+		       (define-key map " "     'hypropos-scroll-up)
+		       (define-key map "b"     'hypropos-scroll-down)
+		       ;; act on the current line...
+		       (define-key map "w"     'hypropos-where-is)
+		       (define-key map "i"     'hypropos-invoke-fn)
+		       (define-key map "s"     'hypropos-set-variable)
+		       ;; more administrativa...
+		       (define-key map "P"     'hypropos-toggle-programming-flag)
+		       (define-key map "k"     'hypropos-add-keyword)
+		       (define-key map "e"     'hypropos-eliminate-keyword)
+		       map
+		       )
+  "Keybindings for the *Hyper Apropos* buffer.
+This map inherits from `hypropos-help-map.'")
+
+(defvar hyper-apropos-mode-hook nil
+  "*User function run after hyper-apropos mode initialization.  Usage:
+\(setq hyper-apropos-mode-hook '(lambda () ... your init forms ...)).")
+
+;; ---------------------------------------------------------------------- ;;
+
+(defconst hypropos-junk-regexp "^Apropos\\|^Functions\\|^Variables\\|^$")
+
+(defvar hypropos-currently-showing nil)	; symbol documented in help buffer now
+(defvar hypropos-help-history nil)	; chain of symbols followed as links in
+					; help buffer
+(defvar hypropos-last-regexp nil)	; regex used for last apropos
+(defconst hypropos-apropos-buf "*Hyper Apropos*")
+(defconst hypropos-help-buf "*Hyper Help*")
+
+;;;###autoload
+(defun hyper-apropos (regexp toggle-apropos)
+  "Display lists of functions and variables matching REGEXP
+in buffer \"*Hyper Apropos*\".  If optional prefix arg is given, then the value
+of `hypropos-programming-apropos' is toggled for this search.
+See also `hyper-apropos-mode'."
+  (interactive "sList symbols matching regexp: \nP")
+  (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
+      (setq hypropos-prev-wconfig (current-window-configuration)))
+  (if (string= "" regexp)
+      (if (get-buffer hypropos-apropos-buf)
+	  (if toggle-apropos
+	      (hypropos-toggle-programming-flag)
+	    (message "Using last search results"))
+	(error "Be more specific..."))
+    (let (flist vlist)
+      (set-buffer (get-buffer-create hypropos-apropos-buf))
+      (setq buffer-read-only nil)
+      (erase-buffer)
+      (if toggle-apropos
+	  (set (make-local-variable 'hypropos-programming-apropos)
+	       (not (default-value 'hypropos-programming-apropos))))
+      (if (not hypropos-programming-apropos)
+	  (setq flist (apropos-internal regexp 'commandp)
+		vlist (apropos-internal regexp 'user-variable-p))
+	;; #### - add obsolete functions/variables here...
+	;; #### - 'variables' may be unbound !!!
+	(setq flist (apropos-internal regexp 'fboundp)
+	      vlist (apropos-internal regexp 'boundp)))
+      (insert-face (format "Apropos search for: %S\n\n" regexp) 'major-heading)
+      (insert-face "* = command (M-x) or user-variable.\n" 'documentation)
+      (insert-face "a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.\n\n" 'documentation)
+      (insert-face "Functions and Macros:\n\n" 'major-heading)
+      (hypropos-grok-functions flist)
+      (insert-face "\n\nVariables and Constants:\n\n" 'major-heading)
+      (hypropos-grok-variables vlist)
+      (goto-char (point-min))
+      ))
+  (switch-to-buffer hypropos-apropos-buf)
+  (hyper-apropos-mode regexp))
+
+(defun hypropos-toggle-programming-flag ()
+  (interactive)
+  (eval-in-buffer hypropos-apropos-buf
+    (set (make-local-variable 'hypropos-programming-apropos)
+	 (not hypropos-programming-apropos)))
+  (message "Re-running apropos...")
+  (hyper-apropos hypropos-last-regexp nil))
+
+(defun hypropos-grok-functions (fns)
+  (let (fn bind type)
+    (while (setq fn (car fns))
+      (setq bind (symbol-function fn)
+	    type (cond ((subrp bind) ?i)
+		       ((compiled-function-p bind) ?b)
+		       ((consp bind) (or (cdr
+					  (assq (car bind) '((autoload . ?a)
+							     (lambda . ?l)
+							     (macro . ?m))))
+					 ??))
+		       (t ? )))
+      (insert type (if (commandp fn) "* " "  "))
+      (insert-face (format "%-30S" fn) 'hyperlink)
+      (and hypropos-show-brief-docs
+	   (if (function-obsolete-p fn)
+	       (insert-face " - Obsolete." 'documentation)
+	     (let ((doc (documentation fn)))
+	       (if (not doc)
+		   (insert-face " - Not documented." 'documentation)
+		 (insert-face (concat " - "
+				      (substring doc 0
+						 (string-match "\n" doc)))
+			      'documentation)))))
+      (insert ?\n)
+      (setq fns (cdr fns))
+      )))
+
+(defun hypropos-grok-variables (vars)
+  (let (var userp)
+    (while (setq var (car vars))
+      (setq userp (user-variable-p var)
+	    vars (cdr vars))
+      (insert (if userp " * " "   "))
+      (insert-face (format "%-30S" var) 'hyperlink)
+      (and hypropos-show-brief-docs
+	   (if (variable-obsolete-p var)
+	       (insert-face " - Obsolete." 'documentation)
+	     (let ((doc (documentation-property var 'variable-documentation)))
+	       (if (not doc)
+		   (insert-face " - Not documented." 'documentation)
+		 (insert-face (concat " - "
+				      (substring doc (if userp 1 0)
+						 (string-match "\n" doc)))
+			      'documentation)))))
+      (insert ?\n)
+      )))
+
+;; ---------------------------------------------------------------------- ;;
+
+(defun hyper-apropos-mode (regexp)
+  "Improved apropos mode for displaying Emacs documentation.  Function and
+variable names are displayed in the buffer \"*Hyper Apropos*\".  
+
+Functions are preceded by a single character to indicates their types:
+    a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.
+Interactive functions are also preceded by an asterisk.
+Variables are preceded by an asterisk if they are user variables.
+
+General Commands:
+
+  	SPC	- scroll documentation or apropos window forward
+  	  b	- scroll documentation or apropos window backward
+	  k     - eliminate all hits that don't contain keyword
+	  n	- new search
+  	  /	- isearch-forward
+  	  q	- quit and restore previous window configuration
+  
+  Operations for Symbol on Current Line:
+  
+      	RET 	- toggle display of symbol's documentation
+		  (also on button2 in xemacs)
+  	  w     - show the keybinding if symbol is a command
+  	  i	- invoke function on current line
+  	  s	- set value of variable on current line
+	  t	- display the C or lisp source (find-tag)"
+  (delete-other-windows)
+  (setq mode-name "Hyper-Apropos"
+	major-mode 'hyper-apropos-mode
+	buffer-read-only t
+	truncate-lines t
+	hypropos-last-regexp regexp
+	modeline-buffer-identification (concat "Hyper Apropos: "
+					       "\"" regexp "\""))
+  (setq mode-motion-hook 'mode-motion-highlight-line)
+  (use-local-map hypropos-map)
+  (run-hooks 'hyper-apropos-mode-hook))
+
+;; ---------------------------------------------------------------------- ;;
+
+;;;###autoload
+(defun hyper-describe-variable (symbol)
+  "Hypertext drop-in replacement for `describe-variable'.
+See also `hyper-apropos' and `hyper-describe-function'."
+  ;; #### - perhaps a prefix arg should suppress the prompt...
+  (interactive 
+   (let* ((v (variable-at-point))
+          (val (let ((enable-recursive-minibuffers t))
+                 (completing-read
+		  (if v
+		      (format "Describe variable (default %s): " v)
+		    "Describe variable: ")
+		  obarray 'boundp t))))
+     (list (if (string= val "") v (intern-soft val)))))
+  (if (null symbol)
+      (message "Sorry, nothing to describe.")
+    (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
+	(setq hypropos-prev-wconfig (current-window-configuration)))
+    (hypropos-get-doc symbol t)))
+
+;;;###autoload
+(defun hyper-describe-function (symbol)
+  "Hypertext replacement for `describe-function'.  Unlike `describe-function'
+in that the symbol under the cursor is the default if it is a function.
+See also `hyper-apropos' and `hyper-describe-variable'."
+  ;; #### - perhaps a prefix arg should suppress the prompt...
+  (interactive
+   (let (fn val)
+     (setq fn (hypropos-this-symbol))	; symbol under point
+     (or (fboundp fn)
+	 (setq fn (function-called-at-point)))
+     (setq val (let ((enable-recursive-minibuffers t))
+		 (completing-read
+		  (if fn 
+		      (format "Describe function (default %s): " fn)
+		    "Describe function: ")
+		  obarray 'fboundp t)))
+     (list (if (equal val "") fn (intern-soft val)))))
+  (if (null symbol)
+      (message "Sorry, nothing to describe.")
+    (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
+	(setq hypropos-prev-wconfig (current-window-configuration)))
+    (hypropos-get-doc symbol t)))
+
+(defun hypropos-last-help (arg)
+  "Go back to the last symbol documented in the *Hyper Help* buffer."
+  (interactive "P")
+  (let ((win (get-buffer-window hypropos-help-buf))
+	(n (prefix-numeric-value arg)))
+    (cond ((and (not win) (not arg))
+	   ;; don't alter the help-history, just redisplay
+	   )
+	  ((<= (length hypropos-help-history) n)
+	   ;; go back as far as we can...
+	   (setcdr (nreverse hypropos-help-history) nil))
+	  (t
+	   (setq hypropos-help-history (nthcdr n hypropos-help-history))))
+    (hypropos-get-doc (car hypropos-help-history) t)))
+
+(defun hypropos-get-doc (&optional symbol force type)
+  ;; #### - update this docstring
+  "Toggle display of documentation for the symbol on the current line."
+  ;; SYMBOL is the symbol to document.  FORCE, if non-nil, means to
+  ;; regenerate the documentation even if it already seems to be there.  And
+  ;; TYPE, if present, forces the generation of only variable documentation
+  ;; or only function documentation.  Normally, if both are present, then
+  ;; both will be generated.
+  ;;
+  ;; TYPES TO IMPLEMENT: obsolete face
+  ;;
+  (interactive)
+  (or symbol
+      (setq symbol (hypropos-this-symbol)))
+  (or type
+      (setq type '(function variable face)))
+  (if (and (eq hypropos-currently-showing symbol)
+	   (get-buffer hypropos-help-buf)
+	   (get-buffer-window hypropos-help-buf)
+	   (not force))
+      ;; we're already displaying this help, so toggle its display.
+      (delete-windows-on hypropos-help-buf)
+    ;; OK, we've got to refresh and display it...
+    (or (eq symbol (car hypropos-help-history))
+	(setq hypropos-help-history
+	      (if (eq major-mode 'hyper-help-mode)
+		  ;; if we're following a link in the help buffer, then
+		  ;; record that in the help history.
+		  (cons symbol hypropos-help-history)
+		;; otherwise clear the history because it's a new search.
+		(list symbol))))
+    (save-excursion
+      (set-buffer (get-buffer-create hypropos-help-buf))
+      (setq buffer-read-only nil)
+      (erase-buffer)
+      (let ((standard-output (current-buffer))
+	    ok beg desc
+	    ftype macrop fndef
+	    keys val doc
+	    obsolete aliases alias-desc)
+	(insert-face (format "`%s'\n\n" symbol) 'major-heading)
+	(and (memq 'function type)
+	     (fboundp symbol)
+	     (progn 
+	       (setq ok t
+		     fndef (symbol-function symbol))
+	       (while (symbolp fndef)
+		 (setq aliases (cons fndef aliases))
+		 (setq fndef (symbol-function fndef)))
+	       (if (eq 'macro (car-safe fndef))
+		   (setq macrop t
+			 fndef (cdr fndef)))
+	       (setq aliases (nreverse aliases))
+	       ;; #### - the gods of internationalization shall strike me down!
+	       (while aliases
+		 (if alias-desc
+		     (setq alias-desc (concat alias-desc ",\nwhich is ")))
+		 (setq alias-desc (concat alias-desc
+					  (format "an alias for `%s'"
+						  (car aliases))))
+		 (setq aliases (cdr aliases)))
+	       (setq ftype (cond ((subrp fndef)                   'subr)
+				 ((compiled-function-p fndef)     'bytecode)
+				 ((eq (car-safe fndef) 'autoload) 'autoload)
+				 ((eq (car-safe fndef) 'lambda)	  'lambda))
+		     desc (concat (if (commandp symbol) "interactive ")
+				  (cdr (assq ftype
+					     '((subr     . "built-in ")
+					       (bytecode . "compiled Lisp ")
+					       (autoload . "autoloaded Lisp ")
+					       (lambda   . "Lisp "))))
+				  (if macrop "macro" "function")
+				  ))
+	       (if alias-desc
+		   (setq desc (concat alias-desc
+				      (if (memq (aref desc 0)
+						'(?a ?e ?i ?o ?u))
+					  ", an " ", a ")
+				      desc)))
+	       (aset desc 0 (upcase (aref desc 0))) ; capitalize
+	       (insert-face desc 'section-heading)
+	       (and (eq ftype 'autoload)
+		    (insert (format ", (autoloaded from \"%s\")"
+				    (nth 1 fndef))))
+	       ;; #### - should also show local binding in some other
+	       ;; buffer so that this function can be used in place of
+	       ;; describe-function and describe-variable.
+	       (if (setq keys (where-is-internal symbol (current-global-map)
+						 nil nil nil))
+		   (insert (format ", (globally bound to %s)"
+				   (mapconcat
+				    #'(lambda (x)
+					(format "\"%s\""
+						(key-description x)))
+				    (sort keys #'(lambda (x y)
+						   (< (length x) (length y))))
+				    ", "))))
+	       (insert ":\n\n")
+	       (setq beg (point)
+		     doc (or (documentation symbol) "function not documented"))
+	       (insert-face "arguments: " 'heading)
+	       (cond ((eq ftype 'lambda)
+		      (princ (or (nth 1 fndef) "()")))
+		     ((eq ftype 'bytecode)
+		      (princ (or (if (fboundp 'compiled-function-arglist)
+				     (compiled-function-arglist fndef)
+				   (aref fndef 0)) "()")))
+		     ((and (eq ftype 'subr)
+			   (string-match
+			    "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'"
+			    doc))
+		      (insert (substring doc
+					 (match-beginning 1)
+					 (match-end 1)))
+		      (setq doc (substring doc 0 (match-beginning 0))))
+		     (t (princ "[not available]")))
+	       (insert "\n\n")
+	       (let ((new
+		      ;; cookbook from bytecomp.el
+		      (get symbol 'byte-obsolete-info)))
+		 (and new
+		      (insert-face
+		       (format "%s is an obsolete function; %s\n\n" symbol
+			       (if (stringp (car new))
+				   (car new)
+				 (format "use %s instead." (car new))))
+		       'warning)))
+	       (insert-face doc 'documentation)
+	       (indent-rigidly beg (point) 1)
+	       (insert"\n\n")
+	       ))
+	(and (memq 'variable type)
+	     (boundp symbol)
+	     (progn 
+	       (setq ok t)
+	       (insert-face (if (user-variable-p symbol)
+				"User variable"
+			      "Variable")
+			    'section-heading)
+	       (and (local-variable-p symbol nil t)
+		    (insert ", local when set"))
+	       (insert ":\n\n")
+	       (setq beg (point)
+		     val (prin1-to-string (symbol-value symbol))
+		     doc (or (documentation-property
+			      symbol 'variable-documentation)
+			     "variable not documented"))
+	       
+	       (let ((ob (get symbol 'byte-obsolete-variable)))
+		 (setq obsolete
+		       (and ob (format "%s is an obsolete variable; %s\n\n"
+				       symbol
+				       (if (stringp ob)
+					   ob
+					 (format "use %s instead." ob))))))
+	       ;; generally, the value of the variable is short and the
+	       ;; documentation of the variable long, so it's desirable
+	       ;; to see all of the value and the start of the
+	       ;; documentation.  Some variables, though, have huge and
+	       ;; nearly meaningless values that force you to page
+	       ;; forward just to find the doc string.  That is
+	       ;; undesirable.
+	       (if (< (length val) 69)	; 80 cols.  docstrings assume this.
+		   (progn (insert-face "value: " 'heading)
+			  (insert (format "%s\n\n" val))
+			  (and obsolete (insert-face obsolete 'warning))
+			  (insert-face doc 'documentation))
+		 (insert "(see below for value)\n\n")
+		 (and obsolete (insert-face obsolete 'warning))
+		 (insert-face doc 'documentation)
+		 (insert "\n\n")
+		 (insert-face "value: " 'heading)
+		 (if hypropos-prettyprint-long-values
+		     (let ((pp-print-readably nil))
+		       (pprint (symbol-value symbol)))
+		   (insert val)))
+	       (indent-rigidly beg (point) 2)
+	       ))
+	(and (memq 'face type)
+	     (find-face symbol)
+	     (progn
+	       (setq ok t)
+	       ;; #### - add some code here
+	       (insert "Face documentation is \"To be implemented.\"\n\n")
+	       )
+	     )
+	(or ok (insert-face "symbol is not currently bound" 'heading)))
+      (goto-char (point-min)) 
+      ;; pop up window and shrink it if it's wasting space
+      (shrink-window-if-larger-than-buffer
+       (display-buffer (current-buffer))) 
+      (hyper-help-mode))    )
+  (setq hypropos-currently-showing symbol))
+
+; -----------------------------------------------------------------------------
+
+(defun hyper-help-mode ()
+  "Major mode for hypertext XEmacs help.  In this mode, you can quickly
+follow links between back and forth between the documentation strings for
+different variables and functions.  Common commands:
+
+\\{hypropos-help-map}"
+  (setq mode-motion-hook 'hypropos-highlight-lisp-symbol
+	buffer-read-only t
+	major-mode	     'hyper-help-mode
+	mode-name	     "Hyper-Help")
+  (set-syntax-table emacs-lisp-mode-syntax-table)
+  (use-local-map hypropos-help-map))
+
+(defun hypropos-highlight-lisp-symbol (event)
+  ;; mostly copied from mode-motion-highlight-internal
+  (let* ((window (event-window event))
+	 (buffer (and window (window-buffer window)))
+	 (point (and buffer (event-point event)))
+	 st en sym highlight-p)
+    (if buffer
+	(progn
+	  (set-buffer buffer)
+	  (if point
+	      (save-excursion
+		(goto-char point)
+		(setq st (save-excursion
+			   (skip-syntax-backward "w_")
+			   (skip-chars-forward "`")
+			   (point))
+		      en (save-excursion
+			   (goto-char st)
+			   (skip-syntax-forward "w_")
+			   (skip-chars-backward ".")
+			   (point))
+		      sym (and (not (eq st en))
+			       (intern-soft (buffer-substring st en)))
+		      highlight-p (and sym
+				       (or (boundp sym)
+					   (fboundp sym))))
+		(if highlight-p
+		    (if mode-motion-extent
+		      (set-extent-endpoints mode-motion-extent st en)
+		    (setq mode-motion-extent (make-extent st en))
+		    (set-extent-property mode-motion-extent 'highlight t))
+		  (and mode-motion-extent
+			 (progn (delete-extent mode-motion-extent)
+				(setq mode-motion-extent nil)))
+		  ))
+	    ;; not over text; zero the extent.
+	    (if (and mode-motion-extent (extent-buffer mode-motion-extent)
+		     (not (eq (extent-start-position mode-motion-extent)
+			      (extent-end-position mode-motion-extent))))
+		(set-extent-endpoints mode-motion-extent 1 1)))))))
+
+
+;; ---------------------------------------------------------------------- ;;
+
+(defun hypropos-scroll-up ()
+  "Scroll up the \"*Hyper Help*\" buffer if it's visible, or scroll this window up."
+  (interactive)
+  (let ((win (get-buffer-window hypropos-help-buf))
+	(owin (selected-window)))
+    (if win
+	(progn
+	  (select-window win)
+	  (condition-case nil
+	       (scroll-up nil)
+	      (error (goto-char (point-max))))
+	  (select-window owin))
+      (scroll-up nil))))
+
+(defun hypropos-scroll-down ()
+  "Scroll down the \"*Hyper Help*\" buffer if it's visible, or scroll this window down."
+  (interactive)
+  (let ((win (get-buffer-window hypropos-help-buf))
+	(owin (selected-window)))
+    (if win
+	(progn
+	  (select-window win)
+	  (condition-case nil
+	       (scroll-down nil)
+	      (error (goto-char (point-max))))
+	  (select-window owin))
+      (scroll-down nil))))
+
+;; ---------------------------------------------------------------------- ;;
+
+(defun hypropos-mouse-get-doc (event)
+  "Get the documentation for the symbol the mouse is on."
+  (interactive "e")
+  (mouse-set-point event)
+  (save-excursion
+    (let ((symbol (hypropos-this-symbol)))
+      (if symbol
+	  (hypropos-get-doc symbol)
+	(error "Click on a symbol")))))
+
+;; ---------------------------------------------------------------------- ;;
+
+(defun hypropos-add-keyword (pattern)
+  "Use additional keyword to narrow regexp match.
+Deletes lines which don't match PATTERN."
+  (interactive "sAdditional Keyword: ")
+  (save-excursion
+    (goto-char (point-min))
+    (let (buffer-read-only)
+      (keep-lines (concat pattern "\\|" hypropos-junk-regexp))
+      )))
+
+(defun hypropos-eliminate-keyword (pattern)
+  "Use additional keyword to eliminate uninteresting matches.
+Deletes lines which match PATTERN."
+  (interactive "sKeyword to eliminate: ")
+  (save-excursion
+    (goto-char (point-min))
+    (let (buffer-read-only)
+      (flush-lines pattern))
+      ))
+
+;; ---------------------------------------------------------------------- ;;
+
+(defun hypropos-this-symbol ()
+  (save-excursion
+    (cond ((eq major-mode 'hyper-apropos-mode)
+	   (beginning-of-line)
+	   (if (looking-at hypropos-junk-regexp)
+	       nil
+	     (forward-char 3)
+	     (read (point-marker))))
+	  (t
+	   (let* ((st (progn
+			(skip-syntax-backward "w_")
+			;; !@(*$^%%# stupid backquote implementation!!!
+			(skip-chars-forward "`")
+			(point)))
+		  (en (progn
+			(skip-syntax-forward "w_")
+			(skip-chars-backward ".")
+			(point))))
+	     (and (not (eq st en))
+		  (intern-soft (buffer-substring st en))))))))
+
+(defun hypropos-where-is (symbol)
+  "Find keybinding for symbol on current line."
+  (interactive (list (hypropos-this-symbol)))
+  (where-is symbol))
+
+(defun hypropos-invoke-fn (fn)
+  "Interactively invoke the function on the current line."
+  (interactive (list (hypropos-this-symbol)))
+  (cond ((not (fboundp fn))
+	 (error "%S is not a function" fn))
+	(t (call-interactively fn))))
+
+;;;###autoload
+(defun hypropos-set-variable (var val)
+  "Interactively set the variable on the current line."
+  (interactive
+   (let ((var (save-excursion
+		(and (eq major-mode 'hypropos-help-mode)
+		     (goto-char (point-min)))
+		(hypropos-this-symbol))))
+     (or (boundp var)
+	 (setq var (completing-read "Set variable: "
+				    obarray 'boundp t)))
+     (hypropos-get-doc var t)
+     (list var
+	   (let ((prop (get var 'variable-interactive))
+		 (print-readably t)
+		 (val (symbol-value var)))
+	     (if prop
+		 (call-interactively (list 'lambda '(arg)
+					   (list 'interactive prop)
+					   'arg))
+	       (eval-minibuffer
+		(format "Set `%s' to value (evaluated): " var)
+		(format (if (or (consp val)
+				(and (symbolp val)
+				     (not (memq val '(t nil)))))
+			    "'%s" "%s")
+			(prin1-to-string val))))))
+     ))
+  (set var val)
+  (hypropos-get-doc var t))
+
+;; ---------------------------------------------------------------------- ;;
+
+(defun hypropos-find-tag (&optional tag-name)
+  "Find the tag for the symbol on the current line in other window.  In
+order for this to work properly, the variable `tag-table-alist' or
+`tags-file-name' must be set so that a TAGS file with tags for the emacs
+source is found for the \"*Hyper Apropos*\" buffer."
+  (interactive)
+  ;; there ought to be a default tags file for this...
+  (or tag-name (setq tag-name (symbol-name (hypropos-this-symbol))))
+  (find-tag-other-window (list tag-name)))
+
+;; ---------------------------------------------------------------------- ;;
+
+(defun hypropos-disassemble (sym)
+  "Disassemble FUN if it is byte-coded.  If it's a lambda, prettyprint it."
+  (interactive (list (hypropos-this-symbol)))
+  (let ((fun sym) (trail nil) macrop)
+    (while (and (symbolp fun) (not (memq fun trail)))
+      (setq trail (cons fun trail)
+	    fun (symbol-function fun)))
+    (and (symbolp fun)
+	 (error "Loop detected in function binding of `%s'" fun))
+    (setq macrop (and  (consp fun)
+		       (eq 'macro (car fun))))
+    (cond ((compiled-function-p (if macrop (cdr fun) fun))
+	   (disassemble fun)
+	   (set-buffer "*Disassemble*")
+	   (goto-char (point-min))
+	   (forward-sexp 2)
+	   (insert (format " for function `%S'" sym))
+	   )
+	  ((consp fun)
+	   (with-output-to-temp-buffer "*Disassemble*"
+	     (pprint (if macrop
+			 (cons 'defmacro (cons sym (cdr (cdr fun))))
+		       (cons 'defun (cons sym (cdr fun))))))
+	   (set-buffer "*Disassemble*")
+	   (emacs-lisp-mode))
+	  ((or (vectorp fun) (stringp fun))
+	   ;; #### - do something fancy here
+	   (with-output-to-temp-buffer "*Disassemble*"
+	     (princ (format "%s is a keyboard macro:\n\n\t" sym))
+	     (prin1 fun)))
+	  (t
+	   (error "Sorry, cannot disassemble `%s'" sym)))))
+
+;; ---------------------------------------------------------------------- ;;
+
+(defun hypropos-quit ()
+  (interactive)
+  "Quit Hyper Apropos and restore original window config."
+  (let ((buf (get-buffer hypropos-apropos-buf)))
+    (and buf (bury-buffer buf)))
+  (set-window-configuration hypropos-prev-wconfig))
+
+;; ---------------------------------------------------------------------- ;;
+
+;;;###autoload
+(defun hypropos-popup-menu (event)
+  (interactive "e")
+  (mouse-set-point event)
+  (let* ((sym (hypropos-this-symbol))
+	 (notjunk (not (null sym)))
+	 (command-p (commandp sym))
+	 (variable-p (and sym (boundp sym)))
+	 (function-p (fboundp sym))
+	 (apropos-p (eq 'hyper-apropos-mode
+			(save-excursion (set-buffer (event-buffer event))
+					major-mode)))
+	 (name (if sym (symbol-name sym) ""))
+	 (hypropos-menu
+	  (delete
+	   nil
+	   (list (concat "Hyper-Help: " name)
+	    (vector "Display documentation" 'hypropos-get-doc   notjunk)
+	    (vector "Set variable"	'hypropos-set-variable	variable-p)
+	    (vector "Show keys for"     'hypropos-where-is      command-p)
+	    (vector "Invoke command"	'hypropos-invoke-fn	command-p)
+	    (vector "Find tag"		'hypropos-find-tag	notjunk)
+	    (and apropos-p
+		 ["Add keyword..." hypropos-add-keyword	t])
+	    (and apropos-p
+		 ["Eliminate keyword..." hypropos-eliminate-keyword  t])
+	    (if apropos-p
+		["Programmers' Apropos" hypropos-toggle-programming-flag
+		 :style toggle :selected hypropos-programming-apropos]
+	      ["Programmers' Help" hypropos-toggle-programming-flag
+	       :style toggle :selected hypropos-programming-apropos])
+	    (and hypropos-programming-apropos
+		 (vector "Disassemble function"
+			 'hypropos-disassemble
+			 function-p))
+	    ["Help"                     describe-mode           t]
+	    ["Quit"			hypropos-quit		t]
+	    ))))
+    (popup-menu hypropos-menu)))
+
+(provide 'hyper-apropos)
+
+;; end of hyper-apropos.el
+