X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/b14e3e21ec6702d27257a1400681fc36ee10282f..18f00515789afb71a4d57171d989a82a1cbe7615:/lisp/help-fns.el diff --git a/lisp/help-fns.el b/lisp/help-fns.el index ede80f858b..ed52be6cc1 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 @@ -76,15 +78,18 @@ DEF is the function whose usage we're looking for in DOCSTRING." ;; Replace `fn' with the actual function name. (if (consp def) "anonymous" def) (match-string 1 docstring)) - (substring docstring 0 (match-beginning 0))))) + (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 "Not documented")) - (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) (eq arglist t)) + (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) @@ -95,30 +100,71 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"." (concat "(fn" (match-string 1 arglist) ")") (format "%S" (help-make-usage 'fn arglist)))))) -(defun help-function-arglist (def) +;; 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 - ((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)) + ((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))) +;; FIXME: Move to subr.el? (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))) - (if (string-match "\\`&" name) arg - (intern (upcase name)))))) + (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. @@ -173,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 @@ -187,10 +233,11 @@ 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 usage + (when (and usage (string-match "^(" usage)) (with-temp-buffer (insert usage) (goto-char (point-min)) @@ -209,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)))))) @@ -353,8 +400,7 @@ suitable file is found, return nil." (pt1 (with-current-buffer (help-buffer) (point))) errtype) (setq string - (cond ((or (stringp def) - (vectorp def)) + (cond ((or (stringp def) (vectorp def)) "a keyboard macro") ((subrp def) (if (eq 'unevalled (cdr (subr-arity def))) @@ -373,6 +419,8 @@ suitable file is found, return nil." (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") @@ -434,12 +482,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) @@ -507,6 +557,21 @@ suitable file is found, return nil." (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) @@ -593,10 +658,9 @@ it is displayed along with the global value." "Describe variable (default %s): " v) "Describe variable: ") obarray - (lambda (vv) - (and (not (keywordp vv)) - (or (boundp vv) - (get vv 'variable-documentation)))) + (lambda (vv) + (or (get vv 'variable-documentation) + (and (boundp vv) (not (keywordp vv))))) t nil nil (if (symbolp v) (symbol-name v)))) (list (if (equal val "") @@ -645,12 +709,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 @@ -666,12 +737,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))) @@ -740,7 +817,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 "."))) @@ -839,7 +917,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"))))))