X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/23aba0ea0e4922cfd8534f43667d3a758f2d2974..8137e7b3165ea5dffc66a0a49f34716df0c00c2d:/lisp/help-fns.el diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 8209cdebd3..2e56da0bca 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -1,6 +1,6 @@ -;;; help-fns.el --- Complex help functions +;;; help-fns.el --- Complex help functions -*- lexical-binding: t -*- -;; Copyright (C) 1985-1986, 1993-1994, 1998-2011 +;; Copyright (C) 1985-1986, 1993-1994, 1998-2012 ;; Free Software Foundation, Inc. ;; Maintainer: FSF @@ -65,7 +65,9 @@ (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. +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 @@ -99,46 +101,55 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." (format "%S" (help-make-usage 'fn arglist)))))) ;; FIXME: Move to subr.el? -(defun help-function-arglist (def) +(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) (integerp (aref def 0))) - (let* ((args-desc (aref def 0)) - (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))) - ((byte-code-function-p def) (aref def 0)) + ((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)) - ((subrp def) - (let ((arity (subr-arity def)) - (arglist ())) - (dotimes (i (car arity)) - (push (intern (concat "arg" (number-to-string (1+ i)))) arglist)) - (cond - ((not (numberp (cdr arglist))) - (push '&rest arglist) - (push 'rest arglist)) - ((< (car arity) (cdr arity)) - (push '&optional arglist) - (dotimes (i (- (cdr arity) (car arity))) - (push (intern (concat "arg" (number-to-string - (+ 1 i (car arity))))) - arglist)))) - (nreverse arglist))) + ((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 (eq (car-safe def) 'autoload) (not (eq (nth 4 def) 'keymap))) "[Arg list not available until function definition is loaded.]") (t t))) @@ -147,12 +158,7 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." (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) + (if (not (symbolp arg)) arg (let ((name (symbol-name arg))) (cond ((string-match "\\`&" name) arg) @@ -213,7 +219,7 @@ if the variable `help-downcase-arguments' is non-nil." (defun help-do-arg-highlight (doc args) (with-syntax-table (make-syntax-table emacs-lisp-mode-syntax-table) (modify-syntax-entry ?\- "w") - (dolist (arg args doc) + (dolist (arg args) (setq doc (replace-regexp-in-string ;; This is heuristic, but covers all common cases ;; except ARG1-ARG2 @@ -227,7 +233,8 @@ if the variable `help-downcase-arguments' is non-nil." "\\(?:-[{([<`\"].*?\\)?"; for ARG-{x}, (x), , [x], `x' "\\>") ; end of word (help-highlight-arg arg) - doc t t 1))))) + doc t t 1))) + doc)) (defun help-highlight-arguments (usage doc &rest args) (when (and usage (string-match "^(" usage)) @@ -249,7 +256,7 @@ if the variable `help-downcase-arguments' is non-nil." ;; so let's skip over it (search-backward "(") (goto-char (scan-sexps (point) 1))))) - ;; Highlight aguments in the USAGE string + ;; Highlight arguments 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)))))) @@ -373,6 +380,42 @@ suitable file is found, return nil." (declare-function ad-get-advice-info "advice" (function)) +(defun help-fns--compiler-macro (function) + (let ((handler nil)) + ;; FIXME: Copied from macroexp.el. + (while (and (symbolp function) + (not (setq handler (get function 'compiler-macro))) + (fboundp function)) + ;; Follow the sequence of aliases. + (setq function (symbol-function function))) + (when handler + (princ "This 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) + (princ (format " in `%s'" lib)) + (with-current-buffer standard-output + (save-excursion + (re-search-backward "`\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-function-cmacro function lib))))) + (princ ".\n\n")))) + +;; We could use `symbol-file' but this is a wee bit more efficient. +(defun help-fns--autoloaded-p (function file) + "Return non-nil if FUNCTION has previously been autoloaded. +FILE is the file where FUNCTION was probably defined." + (let* ((file (file-name-sans-extension (file-truename file))) + (load-hist load-history) + (target (cons t function)) + found) + (while (and load-hist (not found)) + (and (caar load-hist) + (equal (file-name-sans-extension (caar load-hist)) file) + (setq found (member target (cdar load-hist)))) + (setq load-hist (cdr load-hist))) + found)) + ;;;###autoload (defun describe-function-1 (function) (let* ((advised (and (symbolp function) (featurep 'advice) @@ -388,59 +431,67 @@ suitable file is found, return nil." (def (if (symbolp real-function) (symbol-function real-function) function)) - file-name string - (beg (if (commandp def) "an interactive " "a ")) + (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)) + (file-name (find-lisp-object-file-name function def)) (pt1 (with-current-buffer (help-buffer) (point))) - errtype) - (setq string - (cond ((or (stringp def) (vectorp def)) - "a keyboard macro") - ((subrp def) - (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")) - ((symbolp def) - (while (and (fboundp def) - (symbolp (symbol-function def))) - (setq def (symbol-function def))) - ;; Handle (defalias 'foo 'bar), where bar is undefined. - (or (fboundp def) (setq errtype 'alias)) - (format "an alias for `%s'" def)) - ((eq (car-safe def) 'lambda) - (concat beg "Lisp function")) - ((eq (car-safe def) 'macro) - "a Lisp macro") - ((eq (car-safe def) 'closure) - (concat beg "Lisp closure")) - ((eq (car-safe def) 'autoload) - (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")))) - ((keymapp def) - (let ((is-full nil) - (elts (cdr-safe def))) - (while elts - (if (char-table-p (car-safe elts)) - (setq is-full t - elts nil)) - (setq elts (cdr-safe elts))) - (if is-full - "a full keymap" - "a sparse keymap"))) - (t ""))) - (princ string) - (if (eq errtype 'alias) + (beg (if (and (or (byte-code-function-p def) + (keymapp def) + (memq (car-safe def) '(macro lambda closure))) + file-name + (help-fns--autoloaded-p function file-name)) + (if (commandp def) + "an interactive autoloaded " + "an autoloaded ") + (if (commandp def) "an interactive " "a ")))) + + ;; Print what kind of function-like object FUNCTION is. + (princ (cond ((or (stringp def) (vectorp def)) + "a keyboard macro") + ((subrp def) + (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")) + (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")) + ((eq (car-safe def) 'autoload) + (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")))) + ((keymapp def) + (let ((is-full nil) + (elts (cdr-safe def))) + (while elts + (if (char-table-p (car-safe elts)) + (setq is-full t + elts nil)) + (setq elts (cdr-safe elts))) + (concat beg (if is-full "keymap" "sparse keymap")))) + (t ""))) + + (if (and aliased (not (fboundp real-def))) (princ ",\nwhich is not defined. Please make a bug report.") (with-current-buffer standard-output (save-excursion (save-match-data (when (re-search-backward "alias for `\\([^`']+\\)'" nil t) - (help-xref-button 1 'help-function def))))) + (help-xref-button 1 'help-function real-def))))) - (setq file-name (find-lisp-object-file-name function def)) (when file-name (princ " in `") ;; We used to add .el to the file name, @@ -475,12 +526,14 @@ suitable file is found, return nil." (if (member (event-modifiers (aref key 0)) '(nil (shift))) (push key non-modified-keys))) (when remapped - (princ "It is remapped to `") + (princ "Its keys are remapped to `") (princ (symbol-name remapped)) - (princ "'")) + (princ "'.\n")) (when keys - (princ (if remapped ", which is bound to " "It is bound to ")) + (princ (if remapped + "Without this remapping, it would be bound to " + "It is bound to ")) ;; If lots of ordinary text characters run this command, ;; don't mention them one by one. (if (< (length non-modified-keys) 10) @@ -500,25 +553,22 @@ suitable file is found, return nil." (fill-region-as-paragraph pt2 (point)) (unless (looking-back "\n\n") (terpri))))) - ;; Note that list* etc do not get this property until - ;; cl-hack-byte-compiler runs, after bytecomp is loaded. - (when (and (symbolp function) - (eq (get function 'byte-compile) - 'cl-byte-compile-compiler-macro)) - (princ "This function has a compiler macro") - (let ((lib (get function 'compiler-macro-file))) - (when (stringp lib) - (princ (format " in `%s'" lib)) - (with-current-buffer standard-output - (save-excursion - (re-search-backward "`\\([^`']+\\)'" nil t) - (help-xref-button 1 'help-function-cmacro function lib))))) - (princ ".\n\n")) - (let* ((advertised (gethash def advertised-signature-table t)) + (help-fns--compiler-macro function) + (let* ((advertised (gethash real-def advertised-signature-table t)) (arglist (if (listp advertised) - advertised (help-function-arglist def))) - (doc (condition-case err (documentation function) - (error (format "No Doc! %S" err)))) + advertised (help-function-arglist real-def))) + (doc-raw (condition-case err + (documentation function t) + (error (format "No Doc! %S" err)))) + ;; If the function is autoloaded, and its docstring has + ;; key substitution constructs, load the library. + (doc (progn + (and (eq (car-safe real-def) 'autoload) + help-enable-auto-load + (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" + doc-raw) + (load (cadr real-def) t)) + (substitute-command-keys doc-raw))) (usage (help-split-fundoc doc function))) (with-current-buffer standard-output ;; If definition is a keymap, skip arglist note. @@ -539,15 +589,30 @@ suitable file is found, return nil." function))))) usage) (car usage)) - ((or (stringp def) - (vectorp def)) - (format "\nMacro: %s" (format-kbd-macro def))) + ((or (stringp real-def) + (vectorp real-def)) + (format "\nMacro: %s" (format-kbd-macro real-def))) (t "[Missing arglist. Please make a bug report.]"))) (high (help-highlight-arguments use doc))) (let ((fill-begin (point))) (insert (car high) "\n") (fill-region fill-begin (point))) (setq doc (cdr high)))) + + ;; If this is a derived mode, link to the parent. + (let ((parent-mode (and (symbolp real-function) + (get real-function + 'derived-mode-parent)))) + (when parent-mode + (with-current-buffer standard-output + (insert "\nParent mode: `") + (let ((beg (point))) + (insert (format "%s" parent-mode)) + (make-text-button beg (point) + 'type 'help-function + 'help-args (list parent-mode)))) + (princ "'.\n"))) + (let* ((obsolete (and ;; function might be a lambda construct. (symbolp function) @@ -575,6 +640,7 @@ If ANY-SYMBOL is non-nil, don't insist the symbol be bound." (with-syntax-table emacs-lisp-mode-syntax-table (or (condition-case () (save-excursion + (skip-chars-forward "'") (or (not (zerop (skip-syntax-backward "_w"))) (eq (char-syntax (following-char)) ?w) (eq (char-syntax (following-char)) ?_) @@ -634,8 +700,8 @@ it is displayed along with the global value." "Describe variable: ") obarray (lambda (vv) - (or (special-variable-p vv) - (get vv 'variable-documentation))) + (or (get vv 'variable-documentation) + (and (boundp vv) (not (keywordp vv))))) t nil nil (if (symbolp v) (symbol-name v)))) (list (if (equal val "") @@ -684,12 +750,19 @@ it is displayed along with the global value." (with-current-buffer standard-output (setq val-start-pos (point)) (princ "value is ") - (let ((from (point))) - (terpri) - (pp val) - (if (< (point) (+ 68 (line-beginning-position 0))) - (delete-region from (1+ from)) - (delete-region (1- from) from)) + (let ((from (point)) + (line-beg (line-beginning-position)) + ;; + (print-rep + (let ((print-quoted t)) + (prin1-to-string val)))) + (if (< (+ (length print-rep) (point) (- line-beg)) 68) + (insert print-rep) + (terpri) + (pp val) + (if (< (point) (+ 68 (line-beginning-position 0))) + (delete-region from (1+ from)) + (delete-region (1- from) from))) (let* ((sv (get variable 'standard-value)) (origval (and (consp sv) (condition-case nil @@ -705,12 +778,18 @@ it is displayed along with the global value." (delete-region (1- from) from))))))) (terpri) (when locus - (if (bufferp locus) - (princ (format "%socal in buffer %s; " - (if (get variable 'permanent-local) - "Permanently l" "L") - (buffer-name))) - (princ (format "It is a frame-local variable; "))) + (cond + ((bufferp locus) + (princ (format "%socal in buffer %s; " + (if (get variable 'permanent-local) + "Permanently l" "L") + (buffer-name)))) + ((framep locus) + (princ (format "It is a frame-local variable; "))) + ((terminal-live-p locus) + (princ (format "It is a terminal-local variable; "))) + (t + (princ (format "It is local to %S" locus)))) (if (not (default-boundp variable)) (princ "globally void") (let ((val (default-value variable))) @@ -760,8 +839,12 @@ it is displayed along with the global value." (obsolete (get variable 'byte-obsolete-variable)) (use (car obsolete)) (safe-var (get variable 'safe-local-variable)) - (doc (or (documentation-property variable 'variable-documentation) - (documentation-property alias 'variable-documentation))) + (doc (condition-case err + (or (documentation-property + variable 'variable-documentation) + (documentation-property + alias 'variable-documentation)) + (error (format "Doc not found: %S" err)))) (extra-line nil)) ;; Add a note for variables that have been make-var-buffer-local. (when (and (local-variable-if-set-p variable) @@ -769,7 +852,10 @@ it is displayed along with the global value." (with-temp-buffer (local-variable-if-set-p variable)))) (setq extra-line t) - (princ " Automatically becomes buffer-local when set in any fashion.\n")) + (princ " Automatically becomes ") + (if (get variable 'permanent-local) + (princ "permanently ")) + (princ "buffer-local when set.\n")) ;; Mention if it's an alias (unless (eq alias variable) @@ -779,7 +865,8 @@ it is displayed along with the global value." (when obsolete (setq extra-line t) (princ " This variable is obsolete") - (if (cdr obsolete) (princ (format " since %s" (cdr obsolete)))) + (if (nth 2 obsolete) + (princ (format " since %s" (nth 2 obsolete)))) (princ (cond ((stringp use) (concat ";\n " use)) (use (format ";\n use `%s' instead." (car obsolete))) (t "."))) @@ -878,7 +965,7 @@ BUFFER defaults to the current buffer." (insert (cond ((null value) "default") ((char-table-p value) "deeper char-table ...") - (t (condition-case err + (t (condition-case nil (category-set-mnemonics value) (error "invalid"))))))