changeset 39726:19d78cd38271

New file, contents mostly from `help.el'. (describe-variable): Use `condition-case' instead of `ignore-errors'.

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/help-funs.el	Tue Oct 09 11:15:19 2001 +0000
@@ -0,0 +1,563 @@
+;;; help-funs.el --- Complex help functions
+
+;; Copyright (C) 1985, 1986, 1993, 1994, 1998, 1999, 2000, 2001
+;;   Free Software Foundation, Inc.
+
+;; Maintainer: FSF
+;; Keywords: help, internal
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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, or (at your option)
+;; any later version.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This file contains those help commands which are complicated, and
+;; which may not be used in every session.  For example
+;; `describe-function' will probably be heavily used when doing elisp
+;; programming, but not if just editing C files.  Simpler help commands
+;; are in help.el
+
+;;; Code:
+
+;;;###autoload
+(defun help-with-tutorial (&optional arg)
+  "Select the Emacs learn-by-doing tutorial.
+If there is a tutorial version written in the language
+of the selected language environment, that version is used.
+If there's no tutorial in that language, `TUTORIAL' is selected.
+With arg, you are asked to choose which language."
+  (interactive "P")
+  (let ((lang (if arg
+		  (read-language-name 'tutorial "Language: " "English")
+		(if (get-language-info current-language-environment 'tutorial)
+		    current-language-environment
+		  "English")))
+	file filename)
+    (setq filename (get-language-info lang 'tutorial))
+    (setq file (expand-file-name (concat "~/" filename)))
+    (delete-other-windows)
+    (if (get-file-buffer file)
+	(switch-to-buffer (get-file-buffer file))
+      (switch-to-buffer (create-file-buffer file))
+      (setq buffer-file-name file)
+      (setq default-directory (expand-file-name "~/"))
+      (setq buffer-auto-save-file-name nil)
+      (insert-file-contents (expand-file-name filename data-directory))
+      (goto-char (point-min))
+      (search-forward "\n<<")
+      (beginning-of-line)
+      (delete-region (point) (progn (end-of-line) (point)))
+      (let ((n (- (window-height (selected-window))
+		  (count-lines (point-min) (point))
+		  6)))
+	(if (< n 12)
+	    (newline n)
+	  ;; Some people get confused by the large gap.
+	  (newline (/ n 2))
+	  (insert "[Middle of page left blank for didactic purposes.  "
+		  "Text continues below]")
+	  (newline (- n (/ n 2)))))
+      (goto-char (point-min))
+      (set-buffer-modified-p nil))))
+
+;;;###autoload
+(defun locate-library (library &optional nosuffix path interactive-call)
+  "Show the precise file name of Emacs library LIBRARY.
+This command searches the directories in `load-path' like `M-x load-library'
+to find the file that `M-x load-library RET LIBRARY RET' would load.
+Optional second arg NOSUFFIX non-nil means don't add suffixes `.elc' or `.el'
+to the specified name LIBRARY.
+
+If the optional third arg PATH is specified, that list of directories
+is used instead of `load-path'.
+
+When called from a program, the file name is normaly returned as a
+string.  When run interactively, the argument INTERACTIVE-CALL is t,
+and the file name is displayed in the echo area."
+  (interactive (list (read-string "Locate library: ")
+		     nil nil
+		     t))
+  (let (result)
+    (catch 'answer
+      (mapc
+       (lambda (dir)
+	 (mapc
+	  (lambda (suf)
+	    (let ((try (expand-file-name (concat library suf) dir)))
+	      (and (file-readable-p try)
+		   (null (file-directory-p try))
+		   (progn
+		     (setq result try)
+		     (throw 'answer try)))))
+	  (if nosuffix
+	      '("")
+	    '(".elc" ".el" "")
+	    (let ((basic '(".elc" ".el" ""))
+		  (compressed '(".Z" ".gz" "")))
+	      ;; If autocompression mode is on,
+	      ;; consider all combinations of library suffixes
+	      ;; and compression suffixes.
+	      (if (rassq 'jka-compr-handler file-name-handler-alist)
+		  (apply 'nconc
+			 (mapcar (lambda (compelt)
+				   (mapcar (lambda (baselt)
+					     (concat baselt compelt))
+					   basic))
+				 compressed))
+		basic)))))
+       (or path load-path)))
+    (and interactive-call
+	 (if result
+	     (message "Library is file %s" result)
+	   (message "No library %s in search path" library)))
+    result))
+
+
+;; Functions
+
+;;;###autoload
+(defun describe-function (function)
+  "Display the full documentation of FUNCTION (a symbol)."
+  (interactive
+   (let ((fn (function-called-at-point))
+	 (enable-recursive-minibuffers t)
+	 val)
+     (setq val (completing-read (if fn
+				    (format "Describe function (default %s): " fn)
+				  "Describe function: ")
+				obarray 'fboundp t nil nil (symbol-name fn)))
+     (list (if (equal val "")
+	       fn (intern val)))))
+  (if (null function)
+      (message "You didn't specify a function")
+    (with-output-to-temp-buffer "*Help*"
+      (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 nil (interactive-p))
+      (print-help-return-message)
+	(save-excursion
+	  (set-buffer standard-output)
+	  ;; Return the text we displayed.
+	(buffer-string)))))
+
+(defun describe-function-1 (function parens interactive-p)
+  (let* ((def (if (symbolp function)
+		  (symbol-function function)
+		function))
+	 file-name string need-close
+	 (beg (if (commandp def) "an interactive " "a ")))
+    (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 (symbolp (symbol-function def))
+		   (setq def (symbol-function def)))
+		 (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) 'mocklisp)
+		 "a mocklisp function")
+		((eq (car-safe def) 'autoload)
+		 (setq file-name (nth 1 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"))
+			 ))
+                ;; perhaps use keymapp here instead
+                ((eq (car-safe def) 'keymap)
+                 (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 "")))
+    (when (and parens (not (equal string "")))
+      (setq need-close t)
+      (princ "("))
+    (princ string)
+    (with-current-buffer "*Help*"
+      (save-excursion
+	(save-match-data
+	  (if (re-search-backward "alias for `\\([^`']+\\)'" nil t)
+	      (help-xref-button 1 'help-function def)))))
+    (or file-name
+	(setq file-name (symbol-file function)))
+    (if file-name
+	(progn
+	  (princ " in `")
+	  ;; We used to add .el to the file name,
+	  ;; but that's completely wrong when the user used load-file.
+	  (princ file-name)
+	  (princ "'")
+	  ;; Make a hyperlink to the library.
+	  (with-current-buffer "*Help*"
+	    (save-excursion
+	      (re-search-backward "`\\([^`']+\\)'" nil t)
+	      (help-xref-button 1 'help-function-def function file-name)))))
+    (if need-close (princ ")"))
+    (princ ".")
+    (terpri)
+    (when (commandp function)
+      (let ((keys (where-is-internal
+		   function overriding-local-map nil nil)))
+	(when keys
+	  (princ "It is bound to ")
+	  ;; FIXME: This list can be very long (f.ex. for self-insert-command).
+	  (princ (mapconcat 'key-description keys ", "))
+	  (princ ".")
+	  (terpri))))
+    ;; Handle symbols aliased to other symbols.
+    (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)))
+    (let ((arglist (cond ((byte-code-function-p def)
+			  (car (append def nil)))
+			 ((eq (car-safe def) 'lambda)
+			  (nth 1 def))
+			 ((and (eq (car-safe def) 'autoload)
+			       (not (eq (nth 4 def) 'keymap)))
+			  (concat "[Arg list not available until "
+				  "function definition is loaded.]"))
+			 (t t))))
+      (cond ((listp arglist)
+	     (princ (cons (if (symbolp function) function "anonymous")
+			  (mapcar (lambda (arg)
+				    (if (memq arg '(&optional &rest))
+					arg
+				      (intern (upcase (symbol-name arg)))))
+				  arglist)))
+	     (terpri))
+	    ((stringp arglist)
+	     (princ arglist)
+	     (terpri))))
+    (let ((doc (documentation function)))
+      (if doc
+	  (progn (terpri)
+		 (princ doc)
+		 (if (subrp def)
+		     (with-current-buffer standard-output
+		       (beginning-of-line)
+		       ;; Builtins get the calling sequence at the end of
+		       ;; the doc string.  Move it to the same place as
+		       ;; for other functions.
+
+		       ;; In cases where `function' has been fset to a
+		       ;; subr we can't search for function's name in
+		       ;; the doc string.  Kluge round that using the
+		       ;; printed representation.  The arg list then
+		       ;; shows the wrong function name, but that
+		       ;; might be a useful hint.
+		       (let* ((rep (prin1-to-string def))
+			      (name (progn
+				      (string-match " \\([^ ]+\\)>$" rep)
+				      (match-string 1 rep))))
+			 (if (looking-at (format "(%s[ )]" (regexp-quote name)))
+			     (let ((start (point-marker)))
+			       (goto-char (point-min))
+			       (forward-paragraph)
+			       (insert-buffer-substring (current-buffer) start)
+			       (insert ?\n)
+			       (delete-region (1- start) (point-max)))
+			   (goto-char (point-min))
+			   (forward-paragraph)
+			   (insert
+			    "[Missing arglist.  Please make a bug report.]\n")))
+		       (goto-char (point-max))))
+		 (help-setup-xref (list #'describe-function function)
+				  interactive-p))
+	(princ "not documented")))))
+
+
+;; Variables
+
+;;;###autoload
+(defun variable-at-point ()
+  "Return the bound variable symbol found around point.
+Return 0 if there is no such symbol."
+  (condition-case ()
+      (with-syntax-table emacs-lisp-mode-syntax-table
+	(save-excursion
+	  (or (not (zerop (skip-syntax-backward "_w")))
+	      (eq (char-syntax (following-char)) ?w)
+	      (eq (char-syntax (following-char)) ?_)
+	      (forward-sexp -1))
+	  (skip-chars-forward "'")
+	  (let ((obj (read (current-buffer))))
+	    (or (and (symbolp obj) (boundp obj) obj)
+		0))))
+    (error 0)))
+
+;;;###autoload
+(defun describe-variable (variable &optional buffer)
+  "Display the full documentation of VARIABLE (a symbol).
+Returns the documentation as a string, also.
+If VARIABLE has a buffer-local value in BUFFER (default to the current buffer),
+it is displayed along with the global value."
+  (interactive
+   (let ((v (variable-at-point))
+	 (enable-recursive-minibuffers t)
+	 val)
+     (setq val (completing-read (if (symbolp v)
+				    (format
+				     "Describe variable (default %s): " v)
+				  "Describe variable: ")
+				obarray 'boundp t nil nil
+				(if (symbolp v) (symbol-name v))))
+     (list (if (equal val "")
+	       v (intern val)))))
+  (unless (bufferp buffer) (setq buffer (current-buffer)))
+  (if (not (symbolp variable))
+      (message "You did not specify a variable")
+    (let (valvoid)
+      (with-current-buffer buffer
+	(with-output-to-temp-buffer "*Help*"
+	  (prin1 variable)
+	  (if (not (boundp variable))
+	      (progn
+		(princ " is void")
+		(setq valvoid t))
+	    (let ((val (symbol-value variable)))
+	      (with-current-buffer standard-output
+		(princ "'s value is ")
+		(terpri)
+		(let ((from (point)))
+		  (pp val)
+		  (help-xref-on-pp from (point))
+		  (if (< (point) (+ from 20))
+		      (save-excursion
+			(goto-char from)
+			(delete-char -1)))))))
+	  (terpri)
+	  (when (local-variable-p variable)
+	    (princ (format "Local in buffer %s; " (buffer-name)))
+	    (if (not (default-boundp variable))
+		(princ "globally void")
+	      (let ((val (default-value variable)))
+		(with-current-buffer standard-output
+		  (princ "global value is ")
+		  (terpri)
+		  ;; Fixme: pp can take an age if you happen to
+		  ;; ask for a very large expression.  We should
+		  ;; probably print it raw once and check it's a
+		  ;; sensible size before prettyprinting.  -- fx
+		  (let ((from (point)))
+			(pp val)
+			(help-xref-on-pp from (point))
+			(if (< (point) (+ from 20))
+			    (save-excursion
+			      (goto-char from)
+			      (delete-char -1)))))))
+	    (terpri))
+	  (terpri)
+	  (with-current-buffer standard-output
+	    (when (> (count-lines (point-min) (point-max)) 10)
+	      ;; Note that setting the syntax table like below
+	      ;; makes forward-sexp move over a `'s' at the end
+	      ;; of a symbol.
+	      (set-syntax-table emacs-lisp-mode-syntax-table)
+	      (goto-char (point-min))
+	      (if valvoid
+		  (forward-line 1)
+		(forward-sexp 1)
+		(delete-region (point) (progn (end-of-line) (point)))
+		(insert " value is shown below.\n\n")
+		(save-excursion
+		  (insert "\n\nValue:"))))
+	    ;; Add a note for variables that have been make-var-buffer-local.
+	    (when (and (local-variable-if-set-p variable)
+		       (or (not (local-variable-p variable))
+			   (with-temp-buffer
+			     (local-variable-if-set-p variable))))
+	      (save-excursion
+		(forward-line -1)
+		(insert "Automatically becomes buffer-local when set in any fashion.\n"))))
+	  (princ "Documentation:")
+	  (terpri)
+	  (let ((doc (documentation-property variable 'variable-documentation)))
+	    (princ (or doc "not documented as a variable.")))
+          (help-setup-xref (list #'describe-variable variable (current-buffer))
+			   (interactive-p))
+	  
+	  ;; Make a link to customize if this variable can be customized.
+	  ;; Note, it is not reliable to test only for a custom-type property
+	  ;; because those are only present after the var's definition
+	  ;; has been loaded.
+	  (if (or (get variable 'custom-type) ; after defcustom
+		  (get variable 'custom-loads) ; from loaddefs.el
+		  (get variable 'standard-value)) ; from cus-start.el
+	      (let ((customize-label "customize"))
+		(terpri)
+		(terpri)
+		(princ (concat "You can " customize-label " this variable."))
+		(with-current-buffer standard-output
+		  (save-excursion
+		    (re-search-backward
+		     (concat "\\(" customize-label "\\)") nil t)
+		    (help-xref-button 1 'help-customize-variable variable)))))
+	  ;; Make a hyperlink to the library if appropriate.  (Don't
+	  ;; change the format of the buffer's initial line in case
+	  ;; anything expects the current format.)
+	  (let ((file-name (symbol-file variable)))
+	    (when (equal file-name "loaddefs.el")
+	      ;; Find the real def site of the preloaded variable.
+	      (let ((location
+		     (condition-case nil
+			 (find-variable-noselect variable file-name)
+		       (error nil))))
+		(when location
+		  (with-current-buffer (car location)
+		    (goto-char (cdr location))
+		    (when (re-search-backward
+			   "^;;; Generated autoloads from \\(.*\\)" nil t)
+		      (setq file-name (match-string 1)))))))
+	    (when file-name
+	      (princ "\n\nDefined in `")
+	      (princ file-name)
+	      (princ "'.")
+	      (with-current-buffer standard-output
+		(save-excursion
+		  (re-search-backward "`\\([^`']+\\)'" nil t)
+		  (help-xref-button 1 'help-variable-def
+				    variable file-name)))))
+
+	  (print-help-return-message)
+	  (save-excursion
+	    (set-buffer standard-output)
+	    ;; Return the text we displayed.
+	    (buffer-string)))))))
+
+
+;; `help-manyarg-func-alist' is defined primitively (in doc.c).
+;; New primitives with `MANY' or `UNEVALLED' arglists should be added
+;; to this alist.
+;; The parens and function name are redundant, but it's messy to add
+;; them in `documentation'.
+
+;; This will find any missing items:
+;; (let (l)
+;;   (mapatoms (lambda (x)
+;; 	      (if (and (fboundp x)
+;; 		       (subrp (symbol-function x))
+;; 		       (not (numberp (cdr (subr-arity (symbol-function x)))))
+;; 		       (not (assq x help-manyarg-func-alist)))
+;; 		  (push x l))))
+;;   l)
+(defconst help-manyarg-func-alist
+  (purecopy
+   '((list . "(list &rest OBJECTS)")
+     (vector . "(vector &rest OBJECTS)")
+     (make-byte-code . "(make-byte-code &rest ELEMENTS)")
+     (call-process
+      . "(call-process PROGRAM &optional INFILE BUFFER DISPLAY &rest ARGS)")
+     (call-process-region
+      . "(call-process-region START END PROGRAM &optional DELETE BUFFER DISPLAY &rest ARGS)")
+     (string . "(string &rest CHARACTERS)")
+     (+ . "(+ &rest NUMBERS-OR-MARKERS)")
+     (- . "(- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS)")
+     (* . "(* &rest NUMBERS-OR-MARKERS)")
+     (/ . "(/ DIVIDEND DIVISOR &rest DIVISORS)")
+     (max . "(max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)")
+     (min . "(min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)")
+     (logand . "(logand &rest INTS-OR-MARKERS)")
+     (logior . "(logior &rest INTS-OR-MARKERS)")
+     (logxor . "(logxor &rest INTS-OR-MARKERS)")
+     (encode-time
+      . "(encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE)")
+     (insert . "(insert &rest ARGS)")
+     (insert-and-inherit . "(insert-and-inherit &rest ARGS)")
+     (insert-before-markers . "(insert-before-markers &rest ARGS)")
+     (message . "(message STRING &rest ARGUMENTS)")
+     (message-box . "(message-box STRING &rest ARGUMENTS)")
+     (message-or-box . "(message-or-box STRING &rest ARGUMENTS)")
+     (propertize . "(propertize STRING &rest PROPERTIES)")
+     (format . "(format STRING &rest OBJECTS)")
+     (apply . "(apply FUNCTION &rest ARGUMENTS)")
+     (run-hooks . "(run-hooks &rest HOOKS)")
+     (run-hook-with-args . "(run-hook-with-args HOOK &rest ARGS)")
+     (run-hook-with-args-until-failure
+      . "(run-hook-with-args-until-failure HOOK &rest ARGS)")
+     (run-hook-with-args-until-success
+      . "(run-hook-with-args-until-success HOOK &rest ARGS)")
+     (funcall . "(funcall FUNCTION &rest ARGUMENTS)")
+     (append . "(append &rest SEQUENCES)")
+     (concat . "(concat &rest SEQUENCES)")
+     (vconcat . "(vconcat &rest SEQUENCES)")
+     (nconc . "(nconc &rest LISTS)")
+     (widget-apply . "(widget-apply WIDGET PROPERTY &rest ARGS)")
+     (make-hash-table . "(make-hash-table &rest KEYWORD-ARGS)")
+     (insert-string . "(insert-string &rest ARGS)")
+     (start-process . "(start-process NAME BUFFER PROGRAM &rest PROGRAM-ARGS)")
+     (setq-default . "(setq-default SYMBOL VALUE [SYMBOL VALUE...])")
+     (save-excursion . "(save-excursion &rest BODY)")
+     (save-current-buffer . "(save-current-buffer &rest BODY)")
+     (save-restriction . "(save-restriction &rest BODY)")
+     (or . "(or CONDITIONS ...)")
+     (and . "(and CONDITIONS ...)")
+     (if . "(if COND THEN ELSE...)")
+     (cond . "(cond CLAUSES...)")
+     (progn . "(progn BODY ...)")
+     (prog1 . "(prog1 FIRST BODY...)")
+     (prog2 . "(prog2 X Y BODY...)")
+     (setq . "(setq SYM VAL SYM VAL ...)")
+     (quote . "(quote ARG)")
+     (function . "(function ARG)")
+     (defun . "(defun NAME ARGLIST [DOCSTRING] BODY...)")
+     (defmacro . "(defmacro NAME ARGLIST [DOCSTRING] BODY...)")
+     (defvar . "(defvar SYMBOL [INITVALUE DOCSTRING])")
+     (defconst . "(defconst SYMBOL INITVALUE [DOCSTRING])")
+     (let* . "(let* VARLIST BODY...)")
+     (let . "(let VARLIST BODY...)")
+     (while . "(while TEST BODY...)")
+     (catch . "(catch TAG BODY...)")
+     (unwind-protect . "(unwind-protect BODYFORM UNWINDFORMS...)")
+     (condition-case . "(condition-case VAR BODYFORM HANDLERS...)")
+     (track-mouse . "(track-mouse BODY ...)")
+     (ml-if . "(ml-if COND THEN ELSE...)")
+     (ml-provide-prefix-argument . "(ml-provide-prefix-argument ARG1 ARG2)")
+     (ml-prefix-argument-loop . "(ml-prefix-argument-loop ...)")
+     (with-output-to-temp-buffer
+	 . "(with-output-to-temp-buffer BUFFNAME BODY ...)")
+     (save-window-excursion . "(save-window-excursion BODY ...)")
+     (find-operation-coding-system
+      . "(find-operation-coding-system OPERATION ARGUMENTS ...)")
+     (insert-before-markers-and-inherit
+      . "(insert-before-markers-and-inherit &rest ARGS)"))))
+
+
+(provide 'help-funs)
+
+;;; help-funs.el ends here
+
+