;;; help-fns.el --- Complex help functions -*- lexical-binding: t -*-
-;; Copyright (C) 1985-1986, 1993-1994, 1998-2012
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985-1986, 1993-1994, 1998-2014 Free Software Foundation, Inc.
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: help, internal
;; Package: emacs
;;; Code:
+(defvar help-fns-describe-function-functions nil
+ "List of functions to run in help buffer in `describe-function'.
+Those functions will be run after the header line and argument
+list was inserted, and before the documentation will be inserted.
+The functions will receive the function name as argument.")
+
;; Functions
;;;###autoload
;; 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, where USAGE info
-is a string describing the argument list of DEF, such as
-\"(apply FUNCTION &rest ARGUMENTS)\".
-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))
- (unless (zerop (match-beginning 0))
- (substring docstring 0 (match-beginning 0))))))
-
-;; FIXME: Move to subr.el?
-(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 ""))
- (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))))))
-
-;; FIXME: Move to subr.el?
-(defun help-function-arglist (def &optional preserve-names)
- "Return a formal argument list for the function DEF.
-IF PRESERVE-NAMES is non-nil, return a formal arglist that uses
-the same names as used in the original source code, when possible."
- ;; 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
- ((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0))
- ((eq (car-safe def) 'lambda) (nth 1 def))
- ((eq (car-safe def) 'closure) (nth 2 def))
- ((or (and (byte-code-function-p def) (integerp (aref def 0)))
- (subrp def))
- (or (when preserve-names
- (let* ((doc (condition-case nil (documentation def) (error nil)))
- (docargs (if doc (car (help-split-fundoc doc nil))))
- (arglist (if docargs
- (cdar (read-from-string (downcase docargs)))))
- (valid t))
- ;; Check validity.
- (dolist (arg arglist)
- (unless (and (symbolp arg)
- (let ((name (symbol-name arg)))
- (if (eq (aref name 0) ?&)
- (memq arg '(&rest &optional))
- (not (string-match "\\." name)))))
- (setq valid nil)))
- (when valid arglist)))
- (let* ((args-desc (if (not (subrp def))
- (aref def 0)
- (let ((a (subr-arity def)))
- (logior (car a)
- (if (numberp (cdr a))
- (lsh (cdr a) 8)
- (lsh 1 7))))))
- (max (lsh args-desc -8))
- (min (logand args-desc 127))
- (rest (logand args-desc 128))
- (arglist ()))
- (dotimes (i min)
- (push (intern (concat "arg" (number-to-string (1+ i)))) arglist))
- (when (> max min)
- (push '&optional arglist)
- (dotimes (i (- max min))
- (push (intern (concat "arg" (number-to-string (+ 1 i min))))
- arglist)))
- (unless (zerop rest) (push '&rest arglist) (push 'rest arglist))
- (nreverse arglist))))
- ((and (autoloadp def) (not (eq (nth 4 def) 'keymap)))
- "[Arg list not available until function definition is loaded.]")
- (t t)))
-
-;; FIXME: Move to subr.el?
-(defun help-make-usage (function arglist)
- (cons (if (symbolp function) function 'anonymous)
- (mapcar (lambda (arg)
- (if (not (symbolp arg)) arg
- (let ((name (symbol-name arg)))
- (cond
- ((string-match "\\`&" name) arg)
- ((string-match "\\`_" name)
- (intern (upcase (substring name 1))))
- (t (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)
(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)))))
+ (concat "F" (subr-name (advice--cd*r subr-or-var))))))
(with-current-buffer docbuf
(goto-char (point-min))
(if (eobp)
;; If we don't have a file-name string by now, we lost.
nil)
;; Now, `file-name' should have become an absolute file name.
- ;; For files loaded from ~/.emacs.elc, try ~/.emacs.
+ ;; For files loaded from ~/.foo.elc, try ~/.foo.
+ ;; This applies to config files like ~/.emacs,
+ ;; which people sometimes compile.
((let (fn)
- (and (string-equal file-name
- (expand-file-name ".emacs.elc" "~"))
- (file-readable-p (setq fn (expand-file-name ".emacs" "~")))
+ (and (string-match "\\`\\..*\\.elc\\'"
+ (file-name-nondirectory file-name))
+ (string-equal (file-name-directory file-name)
+ (file-name-as-directory (expand-file-name "~")))
+ (file-readable-p (setq fn (file-name-sans-extension file-name)))
fn)))
;; When the Elisp source file can be found in the install
;; directory, return the name of that file.
(match-string 1 str))))
(and src-file (file-readable-p src-file) src-file))))))
-(declare-function ad-get-advice-info "advice" (function))
-
(defun help-fns--key-bindings (function)
(when (commandp function)
(let ((pt2 (with-current-buffer standard-output (point)))
(let ((handler (function-get function 'compiler-macro)))
(when handler
(insert "\nThis function has a compiler macro")
- (let ((lib (get function 'compiler-macro-file)))
- ;; FIXME: rather than look at the compiler-macro-file property,
- ;; just look at `handler' itself.
- (when (stringp lib)
- (insert (format " in `%s'" lib))
- (save-excursion
- (re-search-backward "`\\([^`']+\\)'" nil t)
- (help-xref-button 1 'help-function-cmacro function lib))))
+ (if (symbolp handler)
+ (progn
+ (insert (format " `%s'" handler))
+ (save-excursion
+ (re-search-backward "`\\([^`']+\\)'" nil t)
+ (help-xref-button 1 'help-function handler)))
+ ;; FIXME: Obsolete since 24.4.
+ (let ((lib (get function 'compiler-macro-file)))
+ (when (stringp lib)
+ (insert (format " in `%s'" lib))
+ (save-excursion
+ (re-search-backward "`\\([^`']+\\)'" nil t)
+ (help-xref-button 1 'help-function-cmacro function lib)))))
(insert ".\n"))))
(defun help-fns--signature (function doc real-def real-function)
;;;###autoload
(defun describe-function-1 (function)
- (let* ((advised (and (symbolp function) (featurep 'advice)
- (ad-get-advice-info function)))
+ (let* ((advised (and (symbolp function)
+ (featurep 'nadvice)
+ (advice--p (advice--symbol-function function))))
;; If the function is advised, use the symbol that has the
;; real definition, if that symbol is already set up.
(real-function
(or (and advised
- (let ((origname (cdr (assq 'origname advised))))
- (and (fboundp origname) origname)))
+ (advice--cd*r (advice--symbol-function function)))
function))
;; Get the real definition.
(def (if (symbolp real-function)
(symbol-function real-function)
- function))
- (aliased (symbolp def))
- (real-def (if aliased
- (let ((f def))
- (while (and (fboundp f)
- (symbolp (symbol-function f)))
- (setq f (symbol-function f)))
- f)
- def))
+ real-function))
+ (aliased (or (symbolp def)
+ ;; Advised & aliased function.
+ (and advised (symbolp real-function))))
+ (real-def (cond
+ (aliased (let ((f real-function))
+ (while (and (fboundp f)
+ (symbolp (symbol-function f)))
+ (setq f (symbol-function f)))
+ f))
+ ((subrp def) (intern (subr-name def)))
+ (t def)))
(file-name (find-lisp-object-file-name function def))
(pt1 (with-current-buffer (help-buffer) (point)))
(beg (if (and (or (byte-code-function-p def)
(keymapp def)
(memq (car-safe def) '(macro lambda closure)))
- file-name
+ (stringp file-name)
(help-fns--autoloaded-p function file-name))
(if (commandp def)
"an interactive autoloaded "
(if (eq 'unevalled (cdr (subr-arity def)))
(concat beg "special form")
(concat beg "built-in function")))
- ((byte-code-function-p def)
- (concat beg "compiled Lisp function"))
+ ;; Aliases are Lisp functions, so we need to check
+ ;; aliases before functions.
(aliased
(format "an alias for `%s'" real-def))
- ((eq (car-safe def) 'lambda)
- (concat beg "Lisp function"))
- ((eq (car-safe def) 'macro)
- (concat beg "Lisp macro"))
- ((eq (car-safe def) 'closure)
- (concat beg "Lisp closure"))
((autoloadp def)
(format "%s autoloaded %s"
(if (commandp def) "an interactive" "an")
(if (eq (nth 4 def) 'keymap) "keymap"
(if (nth 4 def) "Lisp macro" "Lisp function"))))
+ ((or (eq (car-safe def) 'macro)
+ ;; For advised macros, def is a lambda
+ ;; expression or a byte-code-function-p, so we
+ ;; need to check macros before functions.
+ (macrop function))
+ (concat beg "Lisp macro"))
+ ((byte-code-function-p def)
+ (concat beg "compiled Lisp function"))
+ ((eq (car-safe def) 'lambda)
+ (concat beg "Lisp function"))
+ ((eq (car-safe def) 'closure)
+ (concat beg "Lisp closure"))
((keymapp def)
(let ((is-full nil)
(elts (cdr-safe def)))
(help-fns--key-bindings function)
(with-current-buffer standard-output
(setq doc (help-fns--signature function doc real-def real-function))
-
- (help-fns--compiler-macro function)
- (help-fns--parent-mode function)
- (help-fns--obsolete function)
-
+ (run-hook-with-args 'help-fns-describe-function-functions function)
(insert "\n"
(or doc "Not documented.")))))))
+;; Add defaults to `help-fns-describe-function-functions'.
+(add-hook 'help-fns-describe-function-functions #'help-fns--obsolete)
+(add-hook 'help-fns-describe-function-functions #'help-fns--parent-mode)
+(add-hook 'help-fns-describe-function-functions #'help-fns--compiler-macro)
+
\f
;; Variables
(cond
((bufferp locus)
(princ (format "Local in buffer %s; "
- (buffer-name))))
+ (buffer-name buffer))))
((framep locus)
(princ (format "It is a frame-local variable; ")))
((terminal-live-p locus)
(princ "buffer-local when set.\n"))
((not permanent-local))
((bufferp locus)
+ (setq extra-line t)
(princ " This variable's buffer-local value is permanent.\n"))
(t
+ (setq extra-line t)
(princ " This variable's value is permanent \
if it is given a local binding.\n")))
(t ".")))
(terpri))
- (when (member (cons variable val) file-local-variables-alist)
+ (when (member (cons variable val)
+ (with-current-buffer buffer
+ file-local-variables-alist))
(setq extra-line t)
- (if (member (cons variable val) dir-local-variables-alist)
- (let ((file (and (buffer-file-name)
- (not (file-remote-p (buffer-file-name)))
+ (if (member (cons variable val)
+ (with-current-buffer buffer
+ dir-local-variables-alist))
+ (let ((file (and (buffer-file-name buffer)
+ (not (file-remote-p
+ (buffer-file-name buffer)))
(dir-locals-find-file
- (buffer-file-name))))
+ (buffer-file-name buffer))))
(dir-file t))
(princ " This variable's value is directory-local")
(if (null file)
(setq file (expand-file-name
dir-locals-file (car file)))
;; Otherwise, assume it was set directly.
- (setq dir-file nil)))
+ (setq file (car file)
+ dir-file nil)))
(princ (if dir-file
"by the file\n `"
"for the directory\n `"))
HCoop / bpt / emacs.git / blobdiff