+ (save-excursion
+ (with-output-to-temp-buffer (help-buffer)
+ (prin1 function)
+ ;; Use " is " instead of a colon so that
+ ;; it is easier to get out the function name using forward-sexp.
+ (princ " is ")
+ (describe-function-1 function)
+ (print-help-return-message)
+ (with-current-buffer standard-output
+ ;; Return the text we displayed.
+ (buffer-string))))))
+
+(defun help-split-fundoc (docstring def)
+ "Split a function DOCSTRING into the actual doc and the usage info.
+Return (USAGE . DOC) or nil if there's no usage info.
+DEF is the function whose usage we're looking for in DOCSTRING."
+ ;; Functions can get the calling sequence at the end of the doc string.
+ ;; In cases where `function' has been fset to a subr we can't search for
+ ;; function's name in the doc string so we use `fn' as the anonymous
+ ;; function name instead.
+ (when (and docstring (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring))
+ (cons (format "(%s%s"
+ ;; Replace `fn' with the actual function name.
+ (if (consp def) "anonymous" def)
+ (match-string 1 docstring))
+ (substring docstring 0 (match-beginning 0)))))
+
+(defun help-add-fundoc-usage (docstring arglist)
+ "Add the usage info to DOCSTRING.
+If DOCSTRING already has a usage info, then just return it unchanged.
+The usage info is built from ARGLIST. DOCSTRING can be nil.
+ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
+ (unless (stringp docstring) (setq docstring "Not documented"))
+ (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) (eq arglist t))
+ docstring
+ (concat docstring
+ (if (string-match "\n?\n\\'" docstring)
+ (if (< (- (match-end 0) (match-beginning 0)) 2) "\n" "")
+ "\n\n")
+ (if (and (stringp arglist)
+ (string-match "\\`([^ ]+\\(.*\\))\\'" arglist))
+ (concat "(fn" (match-string 1 arglist) ")")
+ (format "%S" (help-make-usage 'fn arglist))))))
+
+(defun help-function-arglist (def)
+ ;; Handle symbols aliased to other symbols.
+ (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def)))
+ ;; If definition is a macro, find the function inside it.
+ (if (eq (car-safe def) 'macro) (setq def (cdr def)))
+ (cond
+ ((byte-code-function-p def) (aref def 0))
+ ((eq (car-safe def) 'lambda) (nth 1 def))
+ ((and (eq (car-safe def) 'autoload) (not (eq (nth 4 def) 'keymap)))
+ "[Arg list not available until function definition is loaded.]")
+ (t t)))
+
+(defun help-make-usage (function arglist)
+ (cons (if (symbolp function) function 'anonymous)
+ (mapcar (lambda (arg)
+ (if (not (symbolp arg))
+ (if (and (consp arg) (symbolp (car arg)))
+ ;; CL style default values for optional args.
+ (cons (intern (upcase (symbol-name (car arg))))
+ (cdr arg))
+ arg)
+ (let ((name (symbol-name arg)))
+ (if (string-match "\\`&" name) arg
+ (intern (upcase name))))))
+ arglist)))
+
+;; Could be this, if we make symbol-file do the work below.
+;; (defun help-C-file-name (subr-or-var kind)
+;; "Return the name of the C file where SUBR-OR-VAR is defined.
+;; KIND should be `var' for a variable or `subr' for a subroutine."
+;; (symbol-file (if (symbolp subr-or-var) subr-or-var
+;; (subr-name subr-or-var))
+;; (if (eq kind 'var) 'defvar 'defun)))
+;;;###autoload
+(defun help-C-file-name (subr-or-var kind)
+ "Return the name of the C file where SUBR-OR-VAR is defined.
+KIND should be `var' for a variable or `subr' for a subroutine."
+ (let ((docbuf (get-buffer-create " *DOC*"))
+ (name (if (eq 'var kind)
+ (concat "V" (symbol-name subr-or-var))
+ (concat "F" (subr-name subr-or-var)))))
+ (with-current-buffer docbuf
+ (goto-char (point-min))
+ (if (eobp)
+ (insert-file-contents-literally
+ (expand-file-name internal-doc-file-name doc-directory)))
+ (let ((file (catch 'loop
+ (while t
+ (let ((pnt (search-forward (concat "\1f" name "\n"))))
+ (re-search-backward "\1fS\\(.*\\)")
+ (let ((file (match-string 1)))
+ (if (member file build-files)
+ (throw 'loop file)
+ (goto-char pnt))))))))
+ (if (string-match "\\.\\(o\\|obj\\)\\'" file)
+ (setq file (replace-match ".c" t t file)))
+ (if (string-match "\\.c\\'" file)
+ (concat "src/" file)
+ file)))))
+
+;;;###autoload
+(defface help-argument-name '((((supports :slant italic)) :inherit italic))
+ "Face to highlight argument names in *Help* buffers."
+ :group 'help)
+
+(defun help-default-arg-highlight (arg)
+ "Default function to highlight arguments in *Help* buffers.
+It returns ARG in face `help-argument-name'; ARG is also
+downcased if it displays differently than the default
+face (according to `face-differs-from-default-p')."
+ (propertize (if (face-differs-from-default-p 'help-argument-name)
+ (downcase arg)
+ arg)
+ 'face 'help-argument-name))
+
+(defun help-do-arg-highlight (doc args)
+ (with-syntax-table (make-syntax-table emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?\- "w")
+ (while args
+ (let ((arg (prog1 (car args) (setq args (cdr args)))))
+ (setq doc (replace-regexp-in-string
+ ;; This is heuristic, but covers all common cases
+ ;; except ARG1-ARG2
+ (concat "\\<" ; beginning of word
+ "\\(?:[a-z-]*-\\)?" ; for xxx-ARG
+ "\\("
+ (regexp-quote arg)
+ "\\)"
+ "\\(?:es\\|s\\|th\\)?" ; for ARGth, ARGs
+ "\\(?:-[a-z-]+\\)?" ; for ARG-xxx
+ "\\>") ; end of word
+ (help-default-arg-highlight arg)
+ doc t t 1))))
+ doc))
+
+(defun help-highlight-arguments (usage doc &rest args)
+ (when usage
+ (with-temp-buffer
+ (insert usage)
+ (goto-char (point-min))
+ (let ((case-fold-search nil)
+ (next (not (or args (looking-at "\\["))))
+ (opt nil))
+ ;; Make a list of all arguments
+ (skip-chars-forward "^ ")
+ (while next
+ (or opt (not (looking-at " &")) (setq opt t))
+ (if (not (re-search-forward " \\([\\[(]*\\)\\([^] &)\.]+\\)" nil t))
+ (setq next nil)
+ (setq args (cons (match-string 2) args))
+ (when (and opt (string= (match-string 1) "("))
+ ;; A pesky CL-style optional argument with default value,
+ ;; so let's skip over it
+ (search-backward "(")
+ (goto-char (scan-sexps (point) 1)))))
+ ;; Highlight aguments in the USAGE string
+ (setq usage (help-do-arg-highlight (buffer-string) args))
+ ;; Highlight arguments in the DOC string
+ (setq doc (and doc (help-do-arg-highlight doc args))))))
+ ;; Return value is like the one from help-split-fundoc, but highlighted
+ (cons usage doc))