xemacs-beta: lisp/prim/help.el comparison

comparison lisp/prim/help.el @ 183:e121b013d1f0 r20-3b18

Import from CVS: tag r20-3b18

author	cvs
date	Mon, 13 Aug 2007 09:54:23 +0200
parents	9ad43877534d
children	3d6bfa290dbd

comparison

equal deleted inserted replaced

-:f07455f06202
+:e121b013d1f0
 ;;; Commentary:
 ;; This code implements XEmacs's on-line help system, the one invoked by
 ;;`M-x help-for-help'.
 ;; 06/11/1997 -- Converted to use char-after instead of broken
 ;;  following-char. -slb
 ;;; Code:
 (let ((defn (key-or-menu-binding key)))
 (if (or (null defn) (integerp defn))
 (message "%s is undefined" (key-description key))
 (with-displaying-help-buffer
 (lambda ()
-;	 (princ (key-description key))
+	 (princ (key-description key))
-;	 (princ " runs the command ")
+	 (princ " runs ")
-	 (prin1 defn)
+	 (princ (format "`%s'" defn))
-	 (princ ":\n")
+	 (princ "\n\n")
 	 (cond ((or (stringp defn) (vectorp defn))
 		(let ((cmd (key-binding defn)))
 		  (if (not cmd)
 		      (princ "a keyboard macro")
 		    (progn
 unless the function is autoloaded."
 :type 'boolean
 :group 'help-appearance)
 (defun describe-function-find-file (function)
-(and (boundp 'load-history) ; not standardly bound in XEmacs
+(let ((files load-history)
-(let ((files load-history)
 	     file)
 	 (while files
 	   (if (memq function (cdr (car files)))
 	       (setq file (car (car files)) files nil))
 	   (setq files (cdr files)))
-	 file)))
+	 file))
 (defun describe-function (function)
 "Display the full documentation of FUNCTION (a symbol)."
 (interactive
-(let* ((fn (function-called-at-point))
+(let* ((fn (funcall find-function-function))
 (val (let ((enable-recursive-minibuffers t))
 (completing-read
 (if fn
 (format (gettext "Describe function (default %s): ")
 				fn)
 ;(gettext "an interactive autoloaded Lisp function")
 ;(gettext "an autoloaded Lisp macro")
 ;(gettext "an interactive autoloaded Lisp macro")
 (defun describe-function-1 (function stream &optional nodoc)
-(prin1 function stream)
+(princ (format "`%S' is " function) stream)
-(princ ": " stream)
 (let* ((def function)
 	 file-name
 (doc (or (documentation function)
 (gettext "not documented")))
 	 aliases home kbd-macro-p fndef macrop)
 (while (symbolp def)
 (or (eq def function)
 	  (if aliases
 	      ;; I18N3 Need gettext due to concat
 	      (setq aliases (concat aliases
-				    (format "\n     which is an alias for %s, "
+				    (format
+				     "\n     which is an alias for `%s', "
 					    (symbol-name def))))
-	    (setq aliases (format "an alias for %s, " (symbol-name def)))))
+	    (setq aliases (format "an alias for `%s', "
+				  (symbol-name def)))))
 (setq def (symbol-function def)))
 (if (compiled-function-p def)
 	(setq home (compiled-function-annotation def)))
 (if (eq 'macro (car-safe def))
 	(setq fndef (cdr def)
 	      macrop t)
 (setq fndef def))
-(if describe-function-show-arglist
-(if (cond ((eq 'autoload (car-safe fndef))
-nil)
-((eq 'lambda (car-safe fndef))
-(princ (or (nth 1 fndef) "()") stream)
-t)
-((compiled-function-p fndef)
-(princ (or (compiled-function-arglist fndef) "()") stream)
-t)
-((and (subrp fndef)
-(string-match "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'"
-doc))
-(princ (substring doc (match-beginning 1) (match-end 1))
-stream)
-(setq doc (substring doc 0 (match-beginning 0)))
-t)
-(t
-nil))
-(princ "\n  -- " stream)))
 (if aliases (princ aliases stream))
 (let ((int #'(lambda (string an-p macro-p)
 		   (princ (format
 			   (gettext (concat
 				     (cond ((commandp def)
 ((eq (car-safe def) 'autoload)
 	     (setq file-name (elt def 1))
 	     (funcall int "autoloaded Lisp" t (elt def 4)))
 (t
 nil)))
+(princ "\n")
 (or file-name
 	(setq file-name (describe-function-find-file function)))
 (if file-name
-	(princ (format ".\n  -- loads from \"%s\"" file-name) stream))
+	(princ (format "  -- loads from \"%s\"\n" file-name) stream))
 (if home
-	(princ (format ".\n  -- loaded from %s" home)))
+	(princ (format "  -- loaded from \"%s\"\n" home)) stream)
-(princ "." stream)
+;;     (terpri stream)
+(if describe-function-show-arglist
+(let ((arglist
+	       (cond ((compiled-function-p fndef)
+		      (compiled-function-arglist fndef))
+		     ((eq (car-safe fndef) 'lambda)
+		      (nth 1 fndef))
+		     ((and (subrp fndef)
+			   (string-match
+			    "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'"
+			    doc))
+		      (prog1
+			  (substring doc (match-beginning 1) (match-end 1))
+			(setq doc (substring doc 0 (match-beginning 0)))))
+		     (t t))))
+	  (if (listp arglist)
+	      (progn
+;; 		(princ "  ")
+		(princ (cons function
+			     (mapcar (lambda (arg)
+				       (if (memq arg '(&optional &rest))
+					   arg
+					 (intern (upcase (symbol-name arg)))))
+				       arglist)) stream)
+		(terpri stream)))
+	  (if (stringp arglist)
+	      (princ (format "(%s %s)\n" function arglist) stream))))
 (terpri stream)
 (cond (kbd-macro-p
 	   (princ "These characters are executed:\n\n\t" stream)
 	   (princ (key-description def) stream)
 	   (cond ((setq def (key-binding def))
-		  (princ (format "\n\nwhich executes the command %s.\n\n" def) stream)
+		  (princ (format "\n\nwhich executes the command %S.\n\n" def) stream)
 		  (describe-function-1 def stream))))
 	  (nodoc nil)
 	  (t
 	   ;; tell the user about obsoleteness.
 	   ;; If the function is obsolete and is aliased, don't
 (with-displaying-help-buffer
 (lambda ()
 (let ((origvar variable)
 	   aliases)
 (let ((print-escape-newlines t))
+	 (princ (format "`%s' is " (symbol-name variable)))
 	 (while (variable-alias variable)
 	   (let ((newvar (variable-alias variable)))
 	     (if aliases
 		 ;; I18N3 Need gettext due to concat
 		 (setq aliases
 		       (concat aliases
-			       (format ",\n     which is an alias for %s"
+			       (format "\n     which is an alias for `%s',"
 				       (symbol-name newvar))))
 	       (setq aliases
-		     (format "%s is an alias for %s"
+		     (format "an alias for `%s',"
-			     (symbol-name variable)
 			     (symbol-name newvar))))
 	     (setq variable newvar)))
 	 (if aliases
-	     (princ (format "%s.\n" aliases)))
+	     (princ (format "%s" aliases)))
+	 (princ (built-in-variable-doc variable))
+	 (princ ".\n\n")
+	 (princ "Value: ")
 	 (if (not (boundp variable))
-	     (princ (format "%s is void" variable))
+	     (princ "void")
-	   (princ (format "%s's value is " variable))
 	   (prin1 (symbol-value variable)))
-	 (terpri)
-	 (princ "  -- ")
-	 (princ (built-in-variable-doc variable))
-	 (princ ".")
 	 (terpri)
 	 (cond ((local-variable-p variable (current-buffer))
 		(let* ((void (cons nil nil))
 		       (def (condition-case nil
 				(default-value variable)
 			     (if (eq def void)
 				 (princ "void.")
 			       (prin1 def))
 			     (terpri)))))
 	       ((local-variable-p variable (current-buffer) t)
-		(princ "Setting it would make its value buffer-local.\n")
+		(princ "Setting it would make its value buffer-local.\n"))))
-		(terpri))))
 (terpri)
 (princ "Documentation:")
 (terpri)
 (let ((doc (documentation-property variable 'variable-documentation))
 	     (obsolete (variable-obsoleteness-doc origvar))
 (defun where-is (definition)
 "Print message listing key sequences that invoke specified command.
 Argument is a command definition, usually a symbol with a function definition."
 (interactive
-(let ((fn (function-called-at-point))
+(let ((fn (funcall find-function-function))
 	 (enable-recursive-minibuffers t)
 	 val)
 (setq val (read-command
 		(if fn (format "Where is command (default %s): " fn)
 		  "Where is command: ")))
 (princ (car cmd) stream)
 (setq cmd (cdr cmd))
 (if cmd (princ " " stream)))))
 (terpri stream)))))))
-(defvar find-function-function 'ff-function-at-point
-"The function used by `find-function' to select the function near
+;; find-function stuff
+(defvar find-function-function 'function-at-point
+"*The function used by `find-function' to select the function near
 point.
-For example `ff-function-at-point' or `function-called-at-point'.")
+For example `function-at-point' or `function-called-at-point'.")
 (defvar find-function-source-path nil
 "The default list of directories where find-function searches.
 If this variable is `nil' then find-function searches `load-path' by
 default.")
-;;; Code:
 (defun find-function-noselect (function &optional path)
-"Put point at the definition of the function at point and return the buffer.
+"Returns list `(buffer point)' pointing to the definition of FUNCTION.
-Finds the emacs-lisp package containing the definition of FUNCTION
+Finds the emacs-lisp library containing the definition of FUNCTION
-into a buffer and place point before the definition.  The buffer is
+in a buffer and places point before the definition.  The buffer is
 not selected.
-If the optional argument PATH is given, the package where FUNCTION is
+If the optional argument PATH is given, the library where FUNCTION is
 defined is searched in PATH instead of `load-path' (see
 `find-function-source-path')."
 (and (subrp (symbol-function function))
 (error "%s is a primitive function" function))
 (if (not function)
 (error "You didn't specify a function"))
 (let ((def (symbol-function function))
-	package aliases)
+	library aliases)
 (while (symbolp def)
 (or (eq def function)
 	  (if aliases
 	      (setq aliases (concat aliases
 				    (format ", which is an alias for %s"
 						       def)))))
 (setq function (symbol-function function)
 	    def (symbol-function function)))
 (if aliases
 	(message aliases))
-(setq package
+(setq library
 	  (cond ((eq (car-safe def) 'autoload)
 		 (nth 1 def))
 		((describe-function-find-file function))
-		((and (compiled-function-p def)
+		((compiled-function-p def)
-		      (fboundp 'compiled-function-annotation))
 		 (substring (compiled-function-annotation def) 0 -4))))
-(if (null package)
+(if (null library)
-	(error "Can't find package"))
+	(error "Can't find library"))
-(if (string-match "\\(\\.elc?\\'\\)" package)
+(if (string-match "\\(\\.elc?\\'\\)" library)
-	(setq package (substring package 0 (match-beginning 1))))
+	(setq library (substring library 0 (match-beginning 1))))
-(setq package (concat package ".el"))
+(let* ((path (or path find-function-source-path))
-(let ((filename (locate-library package t
+	   (compression (or (rassq 'jka-compr-handler file-name-handler-alist)
-				    (if path
+			    (member 'crypt-find-file-hook find-file-hooks)))
-					path
+	   (filename (or (locate-library (concat library ".el")
-				      find-function-source-path)))
+					 t path)
-	  (calling-buffer (current-buffer)))
+			 (locate-library library t path)
+			 (if compression
+			     (or (locate-library (concat library ".el.gz")
+						 t path)
+				 (locate-library (concat library ".gz")
+						 t path))))))
 (if (not filename)
-	  (error "The package \"%s\" is not in the path." package))
+	  (error "The library \"%s\" is not in the path." library))
-(set-buffer (find-file-noselect filename))
+(save-excursion
-(save-match-data
+	(set-buffer (find-file-noselect filename))
-	(let ((p (point))
+	(save-match-data
-	      ;; avoid defconst, defgroup, defvar (any others?)
+	  (let (;; avoid defconst, defgroup, defvar (any others?)
-	      (re (format "^(def[^cgv\W]\\w+\\s-+%s\\s-" function))
+		(re (format "^\\s-*(def[^cgv\W]\\w+\\s-+%s\\s-" function))
-	      (syntable (syntax-table)))
+		(syntable (syntax-table)))
-	  (set-syntax-table emacs-lisp-mode-syntax-table)
+	    (set-syntax-table emacs-lisp-mode-syntax-table)
-	  (goto-char (point-min))
+	    (goto-char (point-min))
-	  (if (prog1
+	    (if (prog1
 		  (re-search-forward re nil t)
-		(set-syntax-table syntable))
+		  (set-syntax-table syntable))
-	      (prog2
+		(progn
-		  (beginning-of-line)
+		    (beginning-of-line)
-		  (current-buffer)
+		    (list (current-buffer) (point)))
-		(set-buffer calling-buffer))
+	      (error "Cannot find definition of %s" function))))))))
-	    (goto-char p)
-	    (set-buffer calling-buffer)
+(defun function-at-point ()
-	    (error "Cannot find definition of %s" function)))))))
+(or (condition-case ()
+	  (let ((stab (syntax-table)))
-(defun ff-function-at-point ()
+	    (unwind-protect
-(condition-case ()
+		(save-excursion
-(let ((stab (syntax-table)))
+		  (set-syntax-table emacs-lisp-mode-syntax-table)
-	(unwind-protect
+		  (or (not (zerop (skip-syntax-backward "_w")))
-	    (save-excursion
+		      (eq (char-syntax (char-after (point))) ?w)
-	      (set-syntax-table emacs-lisp-mode-syntax-table)
+		      (eq (char-syntax (char-after (point))) ?_)
-	      (or (not (zerop (skip-syntax-backward "_w")))
+		      (forward-sexp -1))
-		  (eq (char-syntax (char-after (point))) ?w)
+		  (skip-chars-forward "`'")
-		  (eq (char-syntax (char-after (point))) ?_)
+		  (let ((obj (read (current-buffer))))
-		  (forward-sexp -1))
+		    (and (symbolp obj) (fboundp obj) obj)))
-	      (skip-chars-forward "'")
+	      (set-syntax-table stab)))
-	      (let ((obj (read (current-buffer))))
+	(error nil))
-		(and (symbolp obj) (fboundp obj) obj)))
+(condition-case ()
-	  (set-syntax-table stab)))
+	  (save-excursion
-(error nil)))
+	    (save-restriction
+	      (narrow-to-region (max (point-min) (- (point) 1000)) (point-max))
-(defun ff-read-function ()
+	      (backward-up-list 1)
+	      (forward-char 1)
+	      (let (obj)
+		(setq obj (read (current-buffer)))
+		(and (symbolp obj) (fboundp obj) obj))))
+	(error nil))))
+(defun find-function-read-function ()
 "Read and return a function, defaulting to the one near point.
 The function named by `find-function-function' is used to select the
 default function."
 (let ((fn (funcall find-function-function))
 (defun find-function (function &optional path)
 "Find the definition of the function near point in the current window.
-Finds the emacs-lisp package containing the definition of the function
+Finds the emacs-lisp library containing the definition of the function
 near point (selected by `find-function-function') and places point
 before the definition.
-If the optional argument PATH is given, the package where FUNCTION is
+If the optional argument PATH is given, the library where FUNCTION is
 defined is searched in PATH instead of `load-path'"
 (interactive (ff-read-function))
-(switch-to-buffer
+(let ((buffer-point (find-function-noselect function path)))
-(find-function-noselect function path)))
+(if buffer-point
+	(progn
+	  (switch-to-buffer (car buffer-point))
+	  (goto-char (cadr buffer-point))
+	  (recenter 0)))))
 (defun find-function-other-window (function &optional path)
 "Find the definition of the function near point in the other window.
-Finds the emacs-lisp package containing the definition of the function
+Finds the emacs-lisp library containing the definition of the function
 near point (selected by `find-function-function') and places point
 before the definition.
-If the optional argument PATH is given, the package where FUNCTION is
+If the optional argument PATH is given, the library where FUNCTION is
 defined is searched in PATH instead of `load-path'"
 (interactive (ff-read-function))
-(switch-to-buffer-other-window
+(let ((buffer-point (find-function-noselect function path)))
-(find-function-noselect function path)))
+(if buffer-point
+	(progn
+	  (switch-to-buffer-other-window (car buffer-point))
+	  (goto-char (cadr buffer-point))
+	  (recenter 0)))))
 (defun find-function-other-frame (function &optional path)
 "Find the definition of the function near point in the another frame.
-Finds the emacs-lisp package containing the definition of the function
+Finds the emacs-lisp library containing the definition of the function
 near point (selected by `find-function-function') and places point
 before the definition.
-If the optional argument PATH is given, the package where FUNCTION is
+If the optional argument PATH is given, the library where FUNCTION is
 defined is searched in PATH instead of `load-path'"
 (interactive (ff-read-function))
-(switch-to-buffer-other-frame
+(let ((buffer-point (find-function-noselect function path)))
-(find-function-noselect function path)))
+(if buffer-point
+	(progn
-(define-key mode-specific-map "f" 'find-function)
+	  (switch-to-buffer-other-frame (car buffer-point))
+	  (goto-char (cadr buffer-point))
+	  (recenter 0)))))
+(defun find-function-on-key (key)
+"Find the function that KEY invokes.  KEY is a string."
+(interactive "kFind function on key: ")
+(let ((defn (key-or-menu-binding key)))
+(if (or (null defn) (integerp defn))
+(message "%s is undefined" (key-description key))
+(if (and (consp defn) (not (eq 'lambda (car-safe defn))))
+	  (message "runs %s" (prin1-to-string defn))
+	(find-function-other-window defn)))))
+(define-key ctl-x-map "F" 'find-function)
 (define-key ctl-x-4-map "F" 'find-function-other-window)
 (define-key ctl-x-5-map "F" 'find-function-other-frame)
 ;;; help.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/prim/help.el @ 183:e121b013d1f0 r20-3b18