Mercurial > hg > xemacs-beta

comparison lisp/help.el @ 231:557eaa0339bf r20-5b14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-5b14
author cvs
date Mon, 13 Aug 2007 10:13:48 +0200
parents 434959a2fba3
children 52952cbfc5b5
comparison
equal deleted inserted replaced
230:39ed1d2bdd9d 231:557eaa0339bf
189 Commands: 189 Commands:
190 \\{help-mode-map}" 190 \\{help-mode-map}"
191 ) 191 )
192 192
193 (define-key help-mode-map "q" 'help-mode-quit) 193 (define-key help-mode-map "q" 'help-mode-quit)
194 (define-key help-mode-map "Q" 'help-mode-bury)
194 (define-key help-mode-map "f" 'find-function-at-point) 195 (define-key help-mode-map "f" 'find-function-at-point)
196 (define-key help-mode-map "d" 'describe-function-at-point)
197 (define-key help-mode-map "v" 'describe-variable-at-point)
198 (define-key help-mode-map "i" 'Info-elisp-ref)
199 (define-key help-mode-map "c" 'customize-variable)
200 (define-key help-mode-map [tab] 'help-next-symbol)
201 (define-key help-mode-map [(shift tab)] 'help-prev-symbol)
202 (define-key help-mode-map "n" 'help-next-section)
203 (define-key help-mode-map "p" 'help-prev-section)
195 204
196 (defun describe-function-at-point () 205 (defun describe-function-at-point ()
197 "Describe directly the function at point in the other window." 206 "Describe directly the function at point in the other window."
198 (interactive) 207 (interactive)
199 (let ((symb (function-at-point))) 208 (let ((symb (function-at-point)))
200 (when symb 209 (when symb
201 (describe-function symb)))) 210 (describe-function symb))))
211
202 (defun describe-variable-at-point () 212 (defun describe-variable-at-point ()
203 "Describe directly the variable at point in the other window." 213 "Describe directly the variable at point in the other window."
204 (interactive) 214 (interactive)
205 (let ((symb (variable-at-point))) 215 (let ((symb (variable-at-point)))
206 (when symb 216 (when symb
207 (describe-variable symb)))) 217 (describe-variable symb))))
218
208 (defun help-next-symbol () 219 (defun help-next-symbol ()
209 "Move point to the next quoted symbol." 220 "Move point to the next quoted symbol."
210 (interactive) 221 (interactive)
211 (search-forward "`" nil t)) 222 (search-forward "`" nil t))
223
212 (defun help-prev-symbol () 224 (defun help-prev-symbol ()
213 "Move point to the previous quoted symbol." 225 "Move point to the previous quoted symbol."
214 (interactive) 226 (interactive)
215 (search-backward "'" nil t)) 227 (search-backward "'" nil t))
216 (define-key help-mode-map "d" 'describe-function-at-point) 228
217 (define-key help-mode-map "v" 'describe-variable-at-point) 229 (defun help-next-section ()
218 (define-key help-mode-map [tab] 'help-next-symbol) 230 "Move point to the next quoted symbol."
219 (define-key help-mode-map [(shift tab)] 'help-prev-symbol) 231 (interactive)
220 232 (search-forward-regexp "^\\w+:" nil t))
221 233
222 (defun help-mode-quit () 234 (defun help-prev-section ()
235 "Move point to the previous quoted symbol."
236 (interactive)
237 (search-backward-regexp "^\\w+:" nil t))
238
239 (defun help-mode-bury ()
240 "Buries the buffer, possibly restoring the previous window configuration."
241 (interactive)
242 (help-mode-quit t))
243
244 (defun help-mode-quit (&optional bury)
223 "Exits from help mode, possibly restoring the previous window configuration. 245 "Exits from help mode, possibly restoring the previous window configuration.
224 Bury the help buffer to the end of the buffer list." 246 If the optional argument BURY is non-nil, the help buffer is buried,
247 otherwise it is killed."
225 (interactive) 248 (interactive)
226 (let ((buf (current-buffer))) 249 (let ((buf (current-buffer)))
227 (cond ((frame-property (selected-frame) 'help-window-config) 250 (cond ((frame-property (selected-frame) 'help-window-config)
228 (set-window-configuration 251 (set-window-configuration
229 (frame-property (selected-frame) 'help-window-config)) 252 (frame-property (selected-frame) 'help-window-config))
230 (set-frame-property (selected-frame) 'help-window-config nil)) 253 (set-frame-property (selected-frame) 'help-window-config nil))
231 ((not (one-window-p)) 254 ((not (one-window-p))
232 (delete-window))) 255 (delete-window)))
233 (bury-buffer buf))) 256 (if bury
257 (bury-buffer buf)
258 (kill-buffer buf))))
234 259
235 (defun help-quit () 260 (defun help-quit ()
236 (interactive) 261 (interactive)
237 nil) 262 nil)
238 263
388 This just displays the buffer in another window, rather than selecting 413 This just displays the buffer in another window, rather than selecting
389 the window." 414 the window."
390 :type 'boolean 415 :type 'boolean
391 :group 'help-appearance) 416 :group 'help-appearance)
392 417
418 (defun help-buffer-name (name)
419 "Return a name for a Help buffer using string NAME for context."
420 (if (stringp name)
421 (format "*Help: %s*" name)
422 "*Help*"))
423
393 ;; Use this function for displaying help when C-h something is pressed 424 ;; Use this function for displaying help when C-h something is pressed
394 ;; or in similar situations. Do *not* use it when you are displaying 425 ;; or in similar situations. Do *not* use it when you are displaying
395 ;; a help message and then prompting for input in the minibuffer -- 426 ;; a help message and then prompting for input in the minibuffer --
396 ;; this macro usually selects the help buffer, which is not what you 427 ;; this macro usually selects the help buffer, which is not what you
397 ;; want in those situations. 428 ;; want in those situations.
398 429 (defmacro with-displaying-help-buffer (name &rest body)
399 ;;; ### Should really be a macro (as suggested above) to eliminate the 430 "Form which makes a help buffer with given NAME and evaluates BODY there.
400 ;;; requirement of caller to code a lambda form in THUNK -- mrb 431 The actual name of the buffer is generated by the function `help-buffer-name'."
401 (defun with-displaying-help-buffer (thunk) 432 `(let* ((winconfig (current-window-configuration))
402 (let ((winconfig (current-window-configuration)) 433 (was-one-window (one-window-p))
403 (was-one-window (one-window-p)) 434 (buffer-name (help-buffer-name ,name))
404 (help-not-visible 435 (help-not-visible
405 (not (and (windows-of-buffer "*Help*") ;shortcut 436 (not (and (windows-of-buffer buffer-name) ;shortcut
406 (member (selected-frame) 437 (member (selected-frame)
407 (mapcar 'window-frame 438 (mapcar 'window-frame
408 (windows-of-buffer "*Help*"))))))) 439 (windows-of-buffer buffer-name)))))))
409 (prog1 (with-output-to-temp-buffer "*Help*" 440 (prog1 (with-output-to-temp-buffer buffer-name
410 (prog1 (funcall thunk) 441 (prog1 ,@body
411 (save-excursion 442 (save-excursion
412 (set-buffer standard-output) 443 (set-buffer standard-output)
413 (help-mode)))) 444 (help-mode))))
414 (let ((helpwin (get-buffer-window "*Help*"))) 445 (let ((helpwin (get-buffer-window buffer-name)))
415 (when helpwin 446 (when helpwin
416 (with-current-buffer (window-buffer helpwin) 447 (with-current-buffer (window-buffer helpwin)
417 ;; If the *Help* buffer is already displayed on this 448 ;; If the *Help* buffer is already displayed on this
418 ;; frame, don't override the previous configuration 449 ;; frame, don't override the previous configuration
419 (when help-not-visible 450 (when help-not-visible
420 (set-frame-property (selected-frame) 451 (set-frame-property (selected-frame)
421 'help-window-config winconfig))) 452 'help-window-config winconfig)))
422 (when help-selects-help-window 453 (when help-selects-help-window
423 (select-window helpwin)) 454 (select-window helpwin))
424 (cond ((eq helpwin (selected-window)) 455 (cond ((eq helpwin (selected-window))
425 (display-message 'command 456 (display-message 'command
426 (substitute-command-keys "Type \\[help-mode-quit] to remove help window, \\[scroll-up] to scroll the help."))) 457 (substitute-command-keys "Type \\[help-mode-quit] to remove help window, \\[scroll-up] to scroll the help.")))
427 (was-one-window 458 (was-one-window
428 (display-message 'command 459 (display-message 'command
429 (substitute-command-keys "Type \\[delete-other-windows] to remove help window, \\[scroll-other-window] to scroll the help."))) 460 (substitute-command-keys "Type \\[delete-other-windows] to remove help window, \\[scroll-other-window] to scroll the help.")))
430 (t 461 (t
431 (display-message 'command 462 (display-message 'command
432 (substitute-command-keys "Type \\[switch-to-buffer-other-window] to restore the other window, \\[scroll-other-window] to scroll the help."))))))))) 463 (substitute-command-keys "Type \\[switch-to-buffer-other-window] to restore the other window, \\[scroll-other-window] to scroll the help.")))))))))
464 (put 'with-displaying-help-buffer 'lisp-indent-function 1)
465 (put 'with-displaying-help-buffer 'edebug-form-spec '(form body))
433 466
434 (defun describe-key (key) 467 (defun describe-key (key)
435 "Display documentation of the function invoked by KEY. 468 "Display documentation of the function invoked by KEY.
436 KEY is a string, or vector of events. 469 KEY is a string, or vector of events.
437 When called interactively, KEY may also be a menu selection." 470 When called interactively, KEY may also be a menu selection."
438 (interactive "kDescribe key: ") 471 (interactive "kDescribe key: ")
439 (let ((defn (key-or-menu-binding key))) 472 (let ((defn (key-or-menu-binding key))
473 (key-string (key-description key)))
440 (if (or (null defn) (integerp defn)) 474 (if (or (null defn) (integerp defn))
441 (message "%s is undefined" (key-description key)) 475 (message "%s is undefined" key-string)
442 (with-displaying-help-buffer 476 (with-displaying-help-buffer (format "key `%s'" key-string)
443 (lambda () 477 (princ key-string)
444 (princ (key-description key)) 478 (princ " runs ")
445 (princ " runs ") 479 (if (symbolp defn) (princ (format "`%S'" defn))
446 (if (symbolp defn) (princ (format "`%S'" defn)) 480 (prin1 defn))
447 (prin1 defn)) 481 (princ "\n\n")
448 (princ "\n\n") 482 (cond ((or (stringp defn) (vectorp defn))
449 (cond ((or (stringp defn) (vectorp defn)) 483 (let ((cmd (key-binding defn)))
450 (let ((cmd (key-binding defn))) 484 (if (not cmd)
451 (if (not cmd) 485 (princ "a keyboard macro")
452 (princ "a keyboard macro") 486 (progn
453 (progn 487 (princ "a keyboard macro which runs the command ")
454 (princ "a keyboard macro which runs the command ") 488 (prin1 cmd)
455 (prin1 cmd) 489 (princ ":\n\n")
456 (princ ":\n\n") 490 (if (documentation cmd) (princ (documentation cmd)))))))
457 (if (documentation cmd) (princ (documentation cmd))))))) 491 ((and (consp defn) (not (eq 'lambda (car-safe defn))))
458 ((and (consp defn) (not (eq 'lambda (car-safe defn)))) 492 (let ((describe-function-show-arglist nil))
459 (let ((describe-function-show-arglist nil)) 493 (describe-function-1 (car defn))))
460 (describe-function-1 (car defn) standard-output))) 494 ((symbolp defn)
461 ((symbolp defn) 495 (describe-function-1 defn))
462 (describe-function-1 defn standard-output)) 496 ((documentation defn)
463 ((documentation defn) 497 (princ (documentation defn)))
464 (princ (documentation defn))) 498 (t
465 (t 499 (princ "not documented")))))))
466 (princ "not documented"))))))))
467 500
468 (defun describe-mode () 501 (defun describe-mode ()
469 "Display documentation of current major mode and minor modes. 502 "Display documentation of current major mode and minor modes.
470 For this to work correctly for a minor mode, the mode's indicator variable 503 For this to work correctly for a minor mode, the mode's indicator variable
471 \(listed in `minor-mode-alist') must also be a function whose documentation 504 \(listed in `minor-mode-alist') must also be a function whose documentation
472 describes the minor mode." 505 describes the minor mode."
473 (interactive) 506 (interactive)
474 (with-displaying-help-buffer 507 (with-displaying-help-buffer (format "%s mode" mode-name)
475 (lambda () 508 ;; XEmacs change: print the major-mode documentation before
476 ;; XEmacs change: print the major-mode documentation before 509 ;; the minor modes.
477 ;; the minor modes. 510 (princ mode-name)
478 (princ mode-name) 511 (princ " mode:\n")
479 (princ " mode:\n") 512 (princ (documentation major-mode))
480 (princ (documentation major-mode)) 513 (princ "\n\n----\n\n")
481 (princ "\n\n----\n\n") 514 (let ((minor-modes minor-mode-alist))
482 (let ((minor-modes minor-mode-alist)) 515 (while minor-modes
483 (while minor-modes 516 (let* ((minor-mode (car (car minor-modes)))
484 (let* ((minor-mode (car (car minor-modes))) 517 (indicator (car (cdr (car minor-modes)))))
485 (indicator (car (cdr (car minor-modes))))) 518 ;; Document a minor mode if it is listed in minor-mode-alist,
486 ;; Document a minor mode if it is listed in minor-mode-alist, 519 ;; bound locally in this buffer, non-nil, and has a function
487 ;; bound locally in this buffer, non-nil, and has a function 520 ;; definition.
488 ;; definition. 521 (if (and (boundp minor-mode)
489 (if (and (boundp minor-mode) 522 (symbol-value minor-mode)
490 (symbol-value minor-mode) 523 (fboundp minor-mode))
491 (fboundp minor-mode)) 524 (let ((pretty-minor-mode minor-mode))
492 (let ((pretty-minor-mode minor-mode)) 525 (if (string-match "-mode\\'" (symbol-name minor-mode))
493 (if (string-match "-mode\\'" (symbol-name minor-mode)) 526 (setq pretty-minor-mode
494 (setq pretty-minor-mode 527 (capitalize
495 (capitalize 528 (substring (symbol-name minor-mode)
496 (substring (symbol-name minor-mode) 529 0 (match-beginning 0)))))
497 0 (match-beginning 0))))) 530 (while (and (consp indicator) (extentp (car indicator)))
498 (while (and (consp indicator) (extentp (car indicator))) 531 (setq indicator (cdr indicator)))
499 (setq indicator (cdr indicator))) 532 (while (and indicator (symbolp indicator))
500 (while (and indicator (symbolp indicator)) 533 (setq indicator (symbol-value indicator)))
501 (setq indicator (symbol-value indicator))) 534 (princ (format "%s minor mode (indicator%s):\n"
502 (princ (format "%s minor mode (indicator%s):\n" 535 pretty-minor-mode indicator))
503 pretty-minor-mode indicator)) 536 (princ (documentation minor-mode))
504 (princ (documentation minor-mode)) 537 (princ "\n\n----\n\n"))))
505 (princ "\n\n----\n\n")))) 538 (setq minor-modes (cdr minor-modes))))))
506 (setq minor-modes (cdr minor-modes)))))))
507 539
508 ;; So keyboard macro definitions are documented correctly 540 ;; So keyboard macro definitions are documented correctly
509 (fset 'defining-kbd-macro (symbol-function 'start-kbd-macro)) 541 (fset 'defining-kbd-macro (symbol-function 'start-kbd-macro))
510 542
511 (defun describe-distribution () 543 (defun describe-distribution ()
554 If the optional argument PREFIX is supplied, only commands which 586 If the optional argument PREFIX is supplied, only commands which
555 start with that sequence of keys are described. 587 start with that sequence of keys are described.
556 If the second argument (prefix arg, interactively) is non-null 588 If the second argument (prefix arg, interactively) is non-null
557 then only the mouse bindings are displayed." 589 then only the mouse bindings are displayed."
558 (interactive (list nil current-prefix-arg)) 590 (interactive (list nil current-prefix-arg))
559 (with-displaying-help-buffer 591 (with-displaying-help-buffer (format "bindings for %s" major-mode)
560 (lambda () 592 (describe-bindings-1 prefix mouse-only-p)))
561 (describe-bindings-1 prefix mouse-only-p))))
562 593
563 (defun describe-bindings-1 (&optional prefix mouse-only-p) 594 (defun describe-bindings-1 (&optional prefix mouse-only-p)
564 (let ((heading (if mouse-only-p 595 (let ((heading (if mouse-only-p
565 (gettext "button binding\n------ -------\n") 596 (gettext "button binding\n------ -------\n")
566 (gettext "key binding\n--- -------\n"))) 597 (gettext "key binding\n--- -------\n")))
590 (insert "Global Bindings:\n" heading) 621 (insert "Global Bindings:\n" heading)
591 (describe-bindings-internal (current-global-map) 622 (describe-bindings-internal (current-global-map)
592 nil shadow prefix mouse-only-p) 623 nil shadow prefix mouse-only-p)
593 (when (and prefix function-key-map (not mouse-only-p)) 624 (when (and prefix function-key-map (not mouse-only-p))
594 (insert "\nFunction key map translations:\n" heading) 625 (insert "\nFunction key map translations:\n" heading)
595 (describe-bindings-internal function-key-map nil nil prefix mouse-only-p)) 626 (describe-bindings-internal function-key-map nil nil
627 prefix mouse-only-p))
596 (set-buffer buffer))) 628 (set-buffer buffer)))
597 629
598 (defun describe-prefix-bindings () 630 (defun describe-prefix-bindings ()
599 "Describe the bindings of the prefix used to reach this command. 631 "Describe the bindings of the prefix used to reach this command.
600 The prefix described consists of all but the last event 632 The prefix described consists of all but the last event
605 i) 637 i)
606 (setq i 0) 638 (setq i 0)
607 (while (< i (length prefix)) 639 (while (< i (length prefix))
608 (aset prefix i (aref key i)) 640 (aset prefix i (aref key i))
609 (setq i (1+ i))) 641 (setq i (1+ i)))
610 (with-displaying-help-buffer 642 (with-displaying-help-buffer (format "%s prefix" (key-description prefix))
611 (lambda () 643 (princ "Key bindings starting with ")
612 (princ "Key bindings starting with ") 644 (princ (key-description prefix))
613 (princ (key-description prefix)) 645 (princ ":\n\n")
614 (princ ":\n\n") 646 (describe-bindings-1 prefix nil))))
615 (describe-bindings-1 prefix nil)))))
616 647
617 ;; Make C-h after a prefix, when not specifically bound, 648 ;; Make C-h after a prefix, when not specifically bound,
618 ;; run describe-prefix-bindings. 649 ;; run describe-prefix-bindings.
619 (setq prefix-help-command 'describe-prefix-bindings) 650 (setq prefix-help-command 'describe-prefix-bindings)
620 651
662 (defun view-lossage () 693 (defun view-lossage ()
663 "Display recent input keystrokes and recent minibuffer messages. 694 "Display recent input keystrokes and recent minibuffer messages.
664 The number of keys shown is controlled by `view-lossage-key-count'. 695 The number of keys shown is controlled by `view-lossage-key-count'.
665 The number of messages shown is controlled by `view-lossage-message-count'." 696 The number of messages shown is controlled by `view-lossage-message-count'."
666 (interactive) 697 (interactive)
667 (with-displaying-help-buffer 698 (with-displaying-help-buffer "lossage"
668 (lambda () 699 (princ (key-description (recent-keys view-lossage-key-count)))
669 (princ (key-description (recent-keys view-lossage-key-count))) 700 (save-excursion
670 (save-excursion 701 (set-buffer standard-output)
671 (set-buffer standard-output) 702 (goto-char (point-min))
672 (goto-char (point-min)) 703 (insert "Recent keystrokes:\n\n")
673 (insert "Recent keystrokes:\n\n") 704 (while (progn (move-to-column 50) (not (eobp)))
674 (while (progn (move-to-column 50) (not (eobp))) 705 (search-forward " " nil t)
675 (search-forward " " nil t) 706 (insert "\n")))
676 (insert "\n"))) 707 ;; XEmacs addition
677 ;; XEmacs addition 708 (princ "\n\n\nRecent minibuffer messages (most recent first):\n\n")
678 (princ "\n\n\nRecent minibuffer messages (most recent first):\n\n") 709 (save-excursion
679 (save-excursion 710 (let ((buffer (get-buffer-create " *Message-Log*"))
680 (let ((buffer (get-buffer-create " *Message-Log*")) 711 (count 0)
681 (count 0) 712 oldpoint)
682 oldpoint) 713 (set-buffer buffer)
683 (set-buffer buffer) 714 (goto-char (point-max))
684 (goto-char (point-max)) 715 (set-buffer standard-output)
685 (set-buffer standard-output) 716 (while (and (> (point buffer) (point-min buffer))
686 (while (and (> (point buffer) (point-min buffer)) 717 (< count view-lossage-message-count))
687 (< count view-lossage-message-count)) 718 (setq oldpoint (point buffer))
688 (setq oldpoint (point buffer)) 719 (forward-line -1 buffer)
689 (forward-line -1 buffer) 720 (insert-buffer-substring buffer (point buffer) oldpoint)
690 (insert-buffer-substring buffer (point buffer) oldpoint) 721 (setq count (1+ count)))))))
691 (setq count (1+ count))))))))
692 722
693 (define-function 'help 'help-for-help) 723 (define-function 'help 'help-for-help)
694 724
695 (make-help-screen help-for-help 725 (make-help-screen help-for-help
696 "A B C F I K L M N P S T V W C-c C-d C-f C-i C-k C-n C-w; ? for more help:" 726 "A B C F I K L M N P S T V W C-c C-d C-f C-i C-k C-n C-w; ? for more help:"
729 \\[describe-distribution] XEmacs ordering information. 759 \\[describe-distribution] XEmacs ordering information.
730 \\[describe-no-warranty] Information on absence of warranty for XEmacs. 760 \\[describe-no-warranty] Information on absence of warranty for XEmacs.
731 \\[describe-copying] XEmacs copying permission (General Public License)." 761 \\[describe-copying] XEmacs copying permission (General Public License)."
732 help-map) 762 help-map)
733 763
764 (defmacro with-syntax-table (syntab &rest body)
765 "Evaluate BODY with the syntax-table SYNTAB"
766 `(let ((stab (syntax-table)))
767 (unwind-protect
768 (progn
769 (set-syntax-table (copy-syntax-table ,syntab))
770 ,@body)
771 (set-syntax-table stab))))
772 (put 'with-syntax-table 'lisp-indent-function 1)
773 (put 'with-syntax-table 'edebug-form-spec '(form body))
774
734 (defun function-called-at-point () 775 (defun function-called-at-point ()
735 "Return the function which is called by the list containing point. 776 "Return the function which is called by the list containing point.
736 If that gives no function, return the function whose name is around point. 777 If that gives no function, return the function whose name is around point.
737 If that doesn't give a function, return nil." 778 If that doesn't give a function, return nil."
738 (or (condition-case () 779 (or (ignore-errors
780 (save-excursion
781 (save-restriction
782 (narrow-to-region (max (point-min) (- (point) 1000))
783 (point-max))
784 (backward-up-list 1)
785 (forward-char 1)
786 (let (obj)
787 (setq obj (read (current-buffer)))
788 (and (symbolp obj) (fboundp obj) obj)))))
789 (ignore-errors
790 (with-syntax-table emacs-lisp-mode-syntax-table
739 (save-excursion 791 (save-excursion
740 (save-restriction 792 (or (not (zerop (skip-syntax-backward "_w")))
741 (narrow-to-region (max (point-min) (- (point) 1000)) (point-max)) 793 (eq (char-syntax (char-after (point))) ?w)
742 (backward-up-list 1) 794 (eq (char-syntax (char-after (point))) ?_)
743 (forward-char 1) 795 (forward-sexp -1))
744 (let (obj) 796 (skip-chars-forward "`'")
745 (setq obj (read (current-buffer))) 797 (let ((obj (read (current-buffer))))
746 (and (symbolp obj) (fboundp obj) obj)))) 798 (and (symbolp obj) (fboundp obj) obj)))))))
747 (error nil))
748 (condition-case ()
749 (let ((stab (syntax-table)))
750 (unwind-protect
751 (save-excursion
752 (set-syntax-table emacs-lisp-mode-syntax-table)
753 (or (not (zerop (skip-syntax-backward "_w")))
754 (eq (char-syntax (char-after (point))) ?w)
755 (eq (char-syntax (char-after (point))) ?_)
756 (forward-sexp -1))
757 (skip-chars-forward "`'")
758 (let ((obj (read (current-buffer))))
759 (and (symbolp obj) (fboundp obj) obj)))
760 (set-syntax-table stab)))
761 (error nil))))
762 799
763 (defun function-at-point () 800 (defun function-at-point ()
764 "Return the function whose name is around point. 801 "Return the function whose name is around point.
765 If that gives no function, return the function which is called by the 802 If that gives no function, return the function which is called by the
766 list containing point. If that doesn't give a function, return nil." 803 list containing point. If that doesn't give a function, return nil."
767 (or (condition-case () 804 (or (ignore-errors
768 (let ((stab (syntax-table))) 805 (with-syntax-table emacs-lisp-mode-syntax-table
769 (unwind-protect
770 (save-excursion
771 (set-syntax-table emacs-lisp-mode-syntax-table)
772 (or (not (zerop (skip-syntax-backward "_w")))
773 (eq (char-syntax (char-after (point))) ?w)
774 (eq (char-syntax (char-after (point))) ?_)
775 (forward-sexp -1))
776 (skip-chars-forward "`'")
777 (let ((obj (read (current-buffer))))
778 (and (symbolp obj) (fboundp obj) obj)))
779 (set-syntax-table stab)))
780 (error nil))
781 (condition-case ()
782 (save-excursion 806 (save-excursion
783 (save-restriction 807 (or (not (zerop (skip-syntax-backward "_w")))
784 (narrow-to-region (max (point-min) (- (point) 1000)) 808 (eq (char-syntax (char-after (point))) ?w)
785 (point-max)) 809 (eq (char-syntax (char-after (point))) ?_)
786 (backward-up-list 1) 810 (forward-sexp -1))
787 (forward-char 1) 811 (skip-chars-forward "`'")
788 (let (obj) 812 (let ((obj (read (current-buffer))))
789 (setq obj (read (current-buffer))) 813 (and (symbolp obj) (fboundp obj) obj)))))
790 (and (symbolp obj) (fboundp obj) obj)))) 814 (ignore-errors
791 (error nil)))) 815 (save-excursion
816 (save-restriction
817 (narrow-to-region (max (point-min) (- (point) 1000))
818 (point-max))
819 (backward-up-list 1)
820 (forward-char 1)
821 (let (obj)
822 (setq obj (read (current-buffer)))
823 (and (symbolp obj) (fboundp obj) obj)))))))
792 824
793 ;; Default to nil for the non-hackers? Not until we find a way to 825 ;; Default to nil for the non-hackers? Not until we find a way to
794 ;; distinguish hackers from non-hackers automatically! 826 ;; distinguish hackers from non-hackers automatically!
795 (defcustom describe-function-show-arglist t 827 (defcustom describe-function-show-arglist t
796 "*If non-nil, describe-function will show its arglist, 828 "*If non-nil, describe-function will show its arglist,
820 (format (gettext "Describe function (default %s): ") 852 (format (gettext "Describe function (default %s): ")
821 fn) 853 fn)
822 (gettext "Describe function: ")) 854 (gettext "Describe function: "))
823 obarray 'fboundp t nil 'function-history)))) 855 obarray 'fboundp t nil 'function-history))))
824 (list (if (equal val "") fn (intern val))))) 856 (list (if (equal val "") fn (intern val)))))
825 (with-displaying-help-buffer 857 (with-displaying-help-buffer (format "function `%s'" function)
826 (lambda () 858 (describe-function-1 function)))
827 (describe-function-1 function standard-output)
828 ;; Return the text we displayed.
829 (buffer-string nil nil standard-output))))
830 859
831 (defun function-obsolete-p (function) 860 (defun function-obsolete-p (function)
832 "Return non-nil if FUNCTION is obsolete." 861 "Return non-nil if FUNCTION is obsolete."
833 (not (null (get function 'byte-obsolete-info)))) 862 (not (null (get function 'byte-obsolete-info))))
834 863
876 ;(gettext "an autoloaded Lisp function") 905 ;(gettext "an autoloaded Lisp function")
877 ;(gettext "an interactive autoloaded Lisp function") 906 ;(gettext "an interactive autoloaded Lisp function")
878 ;(gettext "an autoloaded Lisp macro") 907 ;(gettext "an autoloaded Lisp macro")
879 ;(gettext "an interactive autoloaded Lisp macro") 908 ;(gettext "an interactive autoloaded Lisp macro")
880 909
881 (defun describe-function-1 (function stream &optional nodoc) 910 ;; taken out of `describe-function-1'
882 (princ (format "`%S' is " function) stream) 911 (defun function-arglist (function)
912 "Returns a string giving the argument list of FUNCTION.
913 For example:
914
915 (function-arglist 'function-arglist)
916 => (function-arglist FUNCTION)
917
918 This function is used by `describe-function-1' to list function
919 arguments in the standard Lisp style."
920 (let* ((fndef (symbol-function function))
921 (arglist
922 (cond ((compiled-function-p fndef)
923 (compiled-function-arglist fndef))
924 ((eq (car-safe fndef) 'lambda)
925 (nth 1 fndef))
926 ((subrp fndef)
927 (let ((doc (documentation function)))
928 (if (string-match "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'"
929 doc)
930 (substring doc (match-beginning 1) (match-end 1)))))
931 (t t))))
932 (cond ((listp arglist)
933 (prin1-to-string
934 (cons function (mapcar (lambda (arg)
935 (if (memq arg '(&optional &rest))
936 arg
937 (intern (upcase (symbol-name arg)))))
938 arglist))
939 t))
940 ((stringp arglist)
941 (format "(%s %s)" function arglist)))))
942
943 (defun function-documentation (function &optional strip-arglist)
944 "Returns a string giving the documentation for FUNCTION if any.
945 If the optional argument STRIP-ARGLIST is non-nil remove the arglist
946 part of the documentation of internal subroutines."
947 (let ((doc (condition-case nil
948 (or (documentation function)
949 (gettext "not documented"))
950 (void-function ""))))
951 (if (and strip-arglist
952 (string-match "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'" doc))
953 (setq doc (substring doc 0 (match-beginning 0))))
954 doc))
955
956 (defun describe-function-1 (function &optional nodoc)
957 "This function does the work for `describe-function'."
958 (princ (format "`%S' is " function))
883 (let* ((def function) 959 (let* ((def function)
884 (doc (condition-case nil
885 (or (documentation function)
886 (gettext "not documented"))
887 (void-function "")))
888 aliases file-name autoload-file kbd-macro-p fndef macrop) 960 aliases file-name autoload-file kbd-macro-p fndef macrop)
889 (while (and (symbolp def) (fboundp def)) 961 (while (and (symbolp def) (fboundp def))
890 (when (not (eq def function)) 962 (when (not (eq def function))
891 (setq aliases 963 (setq aliases
892 (if aliases 964 (if aliases
903 (setq fndef (cdr def) 975 (setq fndef (cdr def)
904 file-name (and (compiled-function-p (cdr def)) 976 file-name (and (compiled-function-p (cdr def))
905 (compiled-function-annotation (cdr def))) 977 (compiled-function-annotation (cdr def)))
906 macrop t) 978 macrop t)
907 (setq fndef def)) 979 (setq fndef def))
908 (if aliases (princ aliases stream)) 980 (if aliases (princ aliases))
909 (let ((int #'(lambda (string an-p macro-p) 981 (let ((int #'(lambda (string an-p macro-p)
910 (princ (format 982 (princ (format
911 (gettext (concat 983 (gettext (concat
912 (cond ((commandp def) 984 (cond ((commandp def)
913 "an interactive ") 985 "an interactive ")
914 (an-p "an ") 986 (an-p "an ")
915 (t "a ")) 987 (t "a "))
916 "%s" 988 "%s"
917 (if macro-p " macro" " function"))) 989 (if macro-p " macro" " function")))
918 string) 990 string)))))
919 stream))))
920 (cond ((or (stringp def) (vectorp def)) 991 (cond ((or (stringp def) (vectorp def))
921 (princ "a keyboard macro." stream) 992 (princ "a keyboard macro.")
922 (setq kbd-macro-p t)) 993 (setq kbd-macro-p t))
923 ((subrp fndef) 994 ((subrp fndef)
924 (funcall int "built-in" nil macrop)) 995 (funcall int "built-in" nil macrop))
925 ((compiled-function-p fndef) 996 ((compiled-function-p fndef)
926 (funcall int "compiled Lisp" nil macrop)) 997 (funcall int "compiled Lisp" nil macrop))
927 ; XEmacs -- we handle aliases above. 998 ; XEmacs -- we handle aliases above.
928 ; ((symbolp fndef) 999 ; ((symbolp fndef)
929 ; (princ (format "alias for `%s'" 1000 ; (princ (format "alias for `%s'"
930 ; (prin1-to-string def)) stream)) 1001 ; (prin1-to-string def))))
931 ((eq (car-safe fndef) 'lambda) 1002 ((eq (car-safe fndef) 'lambda)
932 (funcall int "Lisp" nil macrop)) 1003 (funcall int "Lisp" nil macrop))
933 ((eq (car-safe fndef) 'mocklisp) 1004 ((eq (car-safe fndef) 'mocklisp)
934 (funcall int "mocklisp" nil macrop)) 1005 (funcall int "mocklisp" nil macrop))
935 ((eq (car-safe def) 'autoload) 1006 ((eq (car-safe def) 'autoload)
936 (setq autoload-file (elt def 1)) 1007 (setq autoload-file (elt def 1))
937 (funcall int "autoloaded Lisp" t (elt def 4))) 1008 (funcall int "autoloaded Lisp" t (elt def 4)))
938 ((and (symbolp def) (not (fboundp def))) 1009 ((and (symbolp def) (not (fboundp def)))
939 (princ "a symbol with a void (unbound) function definition." stream)) 1010 (princ "a symbol with a void (unbound) function definition."))
940 (t 1011 (t
941 nil))) 1012 nil)))
942 (princ "\n" stream) 1013 (princ "\n")
943 (if autoload-file 1014 (if autoload-file
944 (princ (format " -- autoloads from \"%s\"\n" autoload-file) stream)) 1015 (princ (format " -- autoloads from \"%s\"\n" autoload-file)))
945 (or file-name 1016 (or file-name
946 (setq file-name (describe-function-find-file function))) 1017 (setq file-name (describe-function-find-file function)))
947 (if file-name 1018 (if file-name
948 (princ (format " -- loaded from \"%s\"\n" file-name)) stream) 1019 (princ (format " -- loaded from \"%s\"\n" file-name)))
949 ;; (terpri stream) 1020 ;; (terpri)
950 (if describe-function-show-arglist 1021 (if describe-function-show-arglist
951 (let ((arglist 1022 (let ((arglist (function-arglist function)))
952 (cond ((compiled-function-p fndef) 1023 (when arglist
953 (compiled-function-arglist fndef)) 1024 (princ arglist)
954 ((eq (car-safe fndef) 'lambda) 1025 (terpri))))
955 (nth 1 fndef)) 1026 (terpri)
956 ((and (subrp fndef)
957 (string-match
958 "[\n\t ]*\narguments: ?(\\(.*\\))\n?\\'"
959 doc))
960 (prog1
961 (substring doc (match-beginning 1) (match-end 1))
962 (setq doc (substring doc 0 (match-beginning 0)))))
963 (t t))))
964 (if (listp arglist)
965 (progn
966 ;; (princ " ")
967 (princ (cons function
968 (mapcar (lambda (arg)
969 (if (memq arg '(&optional &rest))
970 arg
971 (intern (upcase (symbol-name arg)))))
972 arglist)) stream)
973 (terpri stream)))
974 (if (stringp arglist)
975 (princ (format "(%s %s)\n" function arglist) stream))))
976 (terpri stream)
977 (cond (kbd-macro-p 1027 (cond (kbd-macro-p
978 (princ "These characters are executed:\n\n\t" stream) 1028 (princ "These characters are executed:\n\n\t")
979 (princ (key-description def) stream) 1029 (princ (key-description def))
980 (cond ((setq def (key-binding def)) 1030 (cond ((setq def (key-binding def))
981 (princ (format "\n\nwhich executes the command %S.\n\n" def) stream) 1031 (princ (format "\n\nwhich executes the command %S.\n\n" def))
982 (describe-function-1 def stream)))) 1032 (describe-function-1 def))))
983 (nodoc nil) 1033 (nodoc nil)
984 (t 1034 (t
985 ;; tell the user about obsoleteness. 1035 ;; tell the user about obsoleteness.
986 ;; If the function is obsolete and is aliased, don't 1036 ;; If the function is obsolete and is aliased, don't
987 ;; even bother to report the documentation, as a further 1037 ;; even bother to report the documentation, as a further
988 ;; encouragement to use the new function. 1038 ;; encouragement to use the new function.
989 (let ((obsolete (function-obsoleteness-doc function)) 1039 (let ((obsolete (function-obsoleteness-doc function))
990 (compatible (function-compatibility-doc function))) 1040 (compatible (function-compatibility-doc function)))
991 (when obsolete 1041 (when obsolete
992 (princ obsolete stream) 1042 (princ obsolete)
993 (terpri stream) 1043 (terpri)
994 (terpri stream)) 1044 (terpri))
995 (when compatible 1045 (when compatible
996 (princ compatible stream) 1046 (princ compatible)
997 (terpri stream) 1047 (terpri)
998 (terpri stream)) 1048 (terpri))
999 (unless (and obsolete aliases) 1049 (unless (and obsolete aliases)
1000 (princ doc stream) 1050 (let ((doc (function-documentation function t)))
1001 (unless (or (equal doc "") 1051 (princ "Documentation:\n")
1002 (eq ?\n (aref doc (1- (length doc))))) 1052 (princ doc)
1003 (terpri stream)))))))) 1053 (unless (or (equal doc "")
1004 1054 (eq ?\n (aref doc (1- (length doc)))))
1005 1055 (terpri)))))))))
1006 ;;; this doesn't seem to be used for anything 1056
1007 ;;; Wrong! Obnoxious, whining people who complain very LOUDLY on Usenet 1057
1008 ;;; are binding this to keys. 1058 ;;; [Obnoxious, whining people who complain very LOUDLY on Usenet
1059 ;;; are binding this to keys.]
1009 (defun describe-function-arglist (function) 1060 (defun describe-function-arglist (function)
1010 (interactive (list (or (function-at-point) 1061 (interactive (list (or (function-at-point)
1011 (error "no function call at point")))) 1062 (error "no function call at point"))))
1012 (let ((b nil)) 1063 (message nil)
1013 (unwind-protect 1064 (message (function-arglist function)))
1014 (save-excursion
1015 (set-buffer (setq b (get-buffer-create " *arglist*")))
1016 (buffer-disable-undo b)
1017 (erase-buffer)
1018 (describe-function-1 function b t)
1019 (goto-char (point-min))
1020 (end-of-line)
1021 (or (eobp) (delete-char 1))
1022 (just-one-space)
1023 (end-of-line)
1024 (message (buffer-substring (point-min) (point))))
1025 (and b (kill-buffer b)))))
1026 1065
1027 1066
1028 (defun variable-at-point () 1067 (defun variable-at-point ()
1029 (ignore-errors 1068 (ignore-errors
1030 (let ((stab (syntax-table))) 1069 (with-syntax-table emacs-lisp-mode-syntax-table
1031 (unwind-protect 1070 (save-excursion
1032 (save-excursion 1071 (or (not (zerop (skip-syntax-backward "_w")))
1033 (set-syntax-table emacs-lisp-mode-syntax-table) 1072 (eq (char-syntax (char-after (point))) ?w)
1034 (or (not (zerop (skip-syntax-backward "_w"))) 1073 (eq (char-syntax (char-after (point))) ?_)
1035 (eq (char-syntax (char-after (point))) ?w) 1074 (forward-sexp -1))
1036 (eq (char-syntax (char-after (point))) ?_) 1075 (skip-chars-forward "'")
1037 (forward-sexp -1)) 1076 (let ((obj (read (current-buffer))))
1038 (skip-chars-forward "'") 1077 (and (symbolp obj) (boundp obj) obj))))))
1039 (let ((obj (read (current-buffer))))
1040 (and (symbolp obj) (boundp obj) obj)))
1041 (set-syntax-table stab)))))
1042 1078
1043 (defun variable-obsolete-p (variable) 1079 (defun variable-obsolete-p (variable)
1044 "Return non-nil if VARIABLE is obsolete." 1080 "Return non-nil if VARIABLE is obsolete."
1045 (not (null (get variable 'byte-obsolete-variable)))) 1081 (not (null (get variable 'byte-obsolete-variable))))
1046 1082
1085 (default-console "a built-in default console-local variable") 1121 (default-console "a built-in default console-local variable")
1086 (t 1122 (t
1087 (if type "an unknown type of built-in variable?" 1123 (if type "an unknown type of built-in variable?"
1088 "a variable declared in Lisp"))))) 1124 "a variable declared in Lisp")))))
1089 1125
1126 (defun help-pretty-print-value (object)
1127 "Print OBJECT in current buffer.
1128 Use `pp-internal' if defined, otherwise `cl-prettyprint'"
1129 (princ
1130 (with-output-to-string
1131 (with-syntax-table emacs-lisp-mode-syntax-table
1132 ;; print `#<...>' values better
1133 (modify-syntax-entry ?< "(>")
1134 (modify-syntax-entry ?> ")<")
1135 (let ((indent-line-function 'lisp-indent-line))
1136 (if (fboundp 'pp-internal)
1137 (progn
1138 (pp-internal object "\n")
1139 (terpri))
1140 (cl-prettyprint object)))))))
1141
1090 (defun describe-variable (variable) 1142 (defun describe-variable (variable)
1091 "Display the full documentation of VARIABLE (a symbol)." 1143 "Display the full documentation of VARIABLE (a symbol)."
1092 (interactive 1144 (interactive
1093 (let* ((v (variable-at-point)) 1145 (let* ((v (variable-at-point))
1094 (val (let ((enable-recursive-minibuffers t)) 1146 (val (let ((enable-recursive-minibuffers t))
1096 (if v 1148 (if v
1097 (format "Describe variable (default %s): " v) 1149 (format "Describe variable (default %s): " v)
1098 (gettext "Describe variable: ")) 1150 (gettext "Describe variable: "))
1099 obarray 'boundp t nil 'variable-history)))) 1151 obarray 'boundp t nil 'variable-history))))
1100 (list (if (equal val "") v (intern val))))) 1152 (list (if (equal val "") v (intern val)))))
1101 (with-displaying-help-buffer 1153 (with-displaying-help-buffer (format "variable `%s'" variable)
1102 (lambda () 1154 (let ((origvar variable)
1103 (let ((origvar variable) 1155 aliases)
1104 aliases) 1156 (let ((print-escape-newlines t))
1105 (let ((print-escape-newlines t)) 1157 (princ (format "`%s' is " (symbol-name variable)))
1106 (princ (format "`%s' is " (symbol-name variable))) 1158 (while (variable-alias variable)
1107 (while (variable-alias variable) 1159 (let ((newvar (variable-alias variable)))
1108 (let ((newvar (variable-alias variable))) 1160 (if aliases
1109 (if aliases 1161 ;; I18N3 Need gettext due to concat
1110 ;; I18N3 Need gettext due to concat 1162 (setq aliases
1111 (setq aliases 1163 (concat aliases
1112 (concat aliases 1164 (format "\n which is an alias for `%s',"
1113 (format "\n which is an alias for `%s', " 1165 (symbol-name newvar))))
1114 (symbol-name newvar)))) 1166 (setq aliases
1115 (setq aliases 1167 (format "an alias for `%s',"
1116 (format "an alias for `%s', " 1168 (symbol-name newvar))))
1117 (symbol-name newvar)))) 1169 (setq variable newvar)))
1118 (setq variable newvar))) 1170 (if aliases
1119 (if aliases 1171 (princ (format "%s" aliases)))
1120 (princ (format "%s" aliases))) 1172 (princ (built-in-variable-doc variable))
1121 (princ (built-in-variable-doc variable)) 1173 (princ ".\n")
1122 (princ ".\n\n") 1174 (let ((file-name (describe-function-find-file variable)))
1123 (princ "Value: ") 1175 (if file-name
1124 (if (not (boundp variable)) 1176 (princ (format " -- loaded from \"%s\"\n" file-name))))
1125 (princ "void") 1177 (princ "\nValue: ")
1126 (prin1 (symbol-value variable))) 1178 (if (not (boundp variable))
1127 (terpri) 1179 (princ "void\n")
1128 (cond ((local-variable-p variable (current-buffer)) 1180 (help-pretty-print-value (symbol-value variable)))
1129 (let* ((void (cons nil nil)) 1181 (terpri)
1130 (def (condition-case nil 1182 (cond ((local-variable-p variable (current-buffer))
1131 (default-value variable) 1183 (let* ((void (cons nil nil))
1132 (error void)))) 1184 (def (condition-case nil
1133 (princ "This value is specific to the current buffer.") 1185 (default-value variable)
1134 (terpri) 1186 (error void))))
1135 (if (local-variable-p variable nil) 1187 (princ "This value is specific to the current buffer.\n")
1136 (progn 1188 (if (local-variable-p variable nil)
1137 (princ "(Its value is local to each buffer.)") 1189 (princ "(Its value is local to each buffer.)\n"))
1138 (terpri))) 1190 (terpri)
1139 (if (if (eq def void) 1191 (if (if (eq def void)
1140 (boundp variable) 1192 (boundp variable)
1141 (not (eq (symbol-value variable) def))) 1193 (not (eq (symbol-value variable) def)))
1142 ;; #### I18N3 doesn't localize properly! 1194 ;; #### I18N3 doesn't localize properly!
1143 (progn (princ "Its default-value is ") 1195 (progn (princ "Default-value: ")
1144 (if (eq def void) 1196 (if (eq def void)
1145 (princ "void.") 1197 (princ "void\n")
1146 (prin1 def)) 1198 (help-pretty-print-value def))
1147 (terpri))))) 1199 (terpri)))))
1148 ((local-variable-p variable (current-buffer) t) 1200 ((local-variable-p variable (current-buffer) t)
1149 (princ "Setting it would make its value buffer-local.\n")))) 1201 (princ "Setting it would make its value buffer-local.\n\n"))))
1150 (terpri) 1202 (princ "Documentation:")
1151 (princ "Documentation:") 1203 (terpri)
1152 (terpri) 1204 (let ((doc (documentation-property variable 'variable-documentation))
1153 (let ((doc (documentation-property variable 'variable-documentation)) 1205 (obsolete (variable-obsoleteness-doc origvar))
1154 (obsolete (variable-obsoleteness-doc origvar)) 1206 (compatible (variable-compatibility-doc origvar)))
1155 (compatible (variable-compatibility-doc origvar))) 1207 (when obsolete
1156 (when obsolete 1208 (princ obsolete)
1157 (princ obsolete) 1209 (terpri)
1158 (terpri) 1210 (terpri))
1159 (terpri)) 1211 (when compatible
1160 (when compatible 1212 (princ compatible)
1161 (princ compatible) 1213 (terpri)
1162 (terpri) 1214 (terpri))
1163 (terpri)) 1215 ;; don't bother to print anything if variable is obsolete and aliased.
1164 ;; don't bother to print anything if variable is obsolete and aliased. 1216 (when (or (not obsolete) (not aliases))
1165 (when (or (not obsolete) (not aliases)) 1217 (if doc
1166 (if doc 1218 ;; note: documentation-property calls substitute-command-keys.
1167 ;; note: documentation-property calls substitute-command-keys. 1219 (princ doc)
1168 (princ doc) 1220 (princ "not documented as a variable."))))
1169 (princ "not documented as a variable.")) 1221 (terpri))))
1170 (terpri)))
1171 ;; Return the text we displayed.
1172 (buffer-string nil nil standard-output)))))
1173 1222
1174 (defun sorted-key-descriptions (keys &optional separator) 1223 (defun sorted-key-descriptions (keys &optional separator)
1175 "Sort and separate the key descriptions for KEYS. 1224 "Sort and separate the key descriptions for KEYS.
1176 The sorting is done by length (shortest bindings first), and the bindings 1225 The sorting is done by length (shortest bindings first), and the bindings
1177 are separated with SEPARATOR (\", \" by default)." 1226 are separated with SEPARATOR (\", \" by default)."
1207 1256
1208 (defun describe-syntax () 1257 (defun describe-syntax ()
1209 "Describe the syntax specifications in the syntax table. 1258 "Describe the syntax specifications in the syntax table.
1210 The descriptions are inserted in a buffer, which is then displayed." 1259 The descriptions are inserted in a buffer, which is then displayed."
1211 (interactive) 1260 (interactive)
1212 (with-displaying-help-buffer 1261 (with-displaying-help-buffer (format "syntax-table for %s" major-mode)
1213 (lambda () 1262 ;; defined in syntax.el
1214 ;; defined in syntax.el 1263 (describe-syntax-table (syntax-table) standard-output)))
1215 (describe-syntax-table (syntax-table) standard-output))))
1216 1264
1217 (defun list-processes () 1265 (defun list-processes ()
1218 "Display a list of all processes. 1266 "Display a list of all processes.
1219 \(Any processes listed as Exited or Signaled are actually eliminated 1267 \(Any processes listed as Exited or Signaled are actually eliminated
1220 after the listing is made.)" 1268 after the listing is made.)"
1222 (with-output-to-temp-buffer "*Process List*" 1270 (with-output-to-temp-buffer "*Process List*"
1223 (set-buffer standard-output) 1271 (set-buffer standard-output)
1224 (buffer-disable-undo standard-output) 1272 (buffer-disable-undo standard-output)
1225 (make-local-variable 'truncate-lines) 1273 (make-local-variable 'truncate-lines)
1226 (setq truncate-lines t) 1274 (setq truncate-lines t)
1227 (let ((stream standard-output)) 1275 ;; 00000000001111111111222222222233333333334444444444
1228 ;; 00000000001111111111222222222233333333334444444444 1276 ;; 01234567890123456789012345678901234567890123456789
1229 ;; 01234567890123456789012345678901234567890123456789 1277 ;; rewritten for I18N3. This one should stay rewritten
1230 ;; rewritten for I18N3. This one should stay rewritten 1278 ;; so that the dashes will line up properly.
1231 ;; so that the dashes will line up properly. 1279 (princ "Proc Status Buffer Tty Command\n---- ------ ------ --- -------\n")
1232 (princ "Proc Status Buffer Tty Command\n---- ------ ------ --- -------\n" stream) 1280 (let ((tail (process-list)))
1233 (let ((tail (process-list))) 1281 (while tail
1234 (while tail 1282 (let* ((p (car tail))
1235 (let* ((p (car tail)) 1283 (pid (process-id p))
1236 (pid (process-id p)) 1284 (s (process-status p)))
1237 (s (process-status p))) 1285 (setq tail (cdr tail))
1238 (setq tail (cdr tail)) 1286 (princ (format "%-13s" (process-name p)))
1239 (princ (format "%-13s" (process-name p)) stream) 1287 ;;(if (and (eq system-type 'vax-vms)
1240 ;(if (and (eq system-type 'vax-vms) 1288 ;; (eq s 'signal)
1241 ; (eq s 'signal) 1289 ;; (< (process-exit-status p) NSIG))
1242 ; (< (process-exit-status p) NSIG)) 1290 ;; (princ (aref sys_errlist (process-exit-status p))))
1243 ; (princ (aref sys_errlist (process-exit-status p)) stream)) 1291 (princ s)
1244 (princ s stream) 1292 (if (and (eq s 'exit) (/= (process-exit-status p) 0))
1245 (if (and (eq s 'exit) (/= (process-exit-status p) 0)) 1293 (princ (format " %d" (process-exit-status p))))
1246 (princ (format " %d" (process-exit-status p)) stream)) 1294 (if (memq s '(signal exit closed))
1247 (if (memq s '(signal exit closed)) 1295 ;; Do delete-exited-processes' work
1248 ;; Do delete-exited-processes' work 1296 (delete-process p))
1249 (delete-process p)) 1297 (indent-to 22 1) ;####
1250 (indent-to 22 1) ;#### 1298 (let ((b (process-buffer p)))
1251 (let ((b (process-buffer p))) 1299 (cond ((not b)
1252 (cond ((not b) 1300 (princ "(none)"))
1253 (princ "(none)" stream)) 1301 ((not (buffer-name b))
1254 ((not (buffer-name b)) 1302 (princ "(killed)"))
1255 (princ "(killed)" stream)) 1303 (t
1256 (t 1304 (princ (buffer-name b)))))
1257 (princ (buffer-name b) stream)))) 1305 (indent-to 37 1) ;####
1258 (indent-to 37 1) ;#### 1306 (let ((tn (process-tty-name p)))
1259 (let ((tn (process-tty-name p))) 1307 (cond ((not tn)
1260 (cond ((not tn) 1308 (princ "(none)"))
1261 (princ "(none)" stream)) 1309 (t
1262 (t 1310 (princ (format "%s" tn)))))
1263 (princ (format "%s" tn) stream)))) 1311 (indent-to 49 1) ;####
1264 (indent-to 49 1) ;#### 1312 (if (not (integerp pid))
1265 (if (not (integerp pid)) 1313 (progn
1266 (progn 1314 (princ "network stream connection ")
1267 (princ "network stream connection " stream) 1315 (princ (car pid))
1268 (princ (car pid) stream) 1316 (princ "@")
1269 (princ "@" stream) 1317 (princ (cdr pid)))
1270 (princ (cdr pid) stream)) 1318 (let ((cmd (process-command p)))
1271 (let ((cmd (process-command p))) 1319 (while cmd
1272 (while cmd 1320 (princ (car cmd))
1273 (princ (car cmd) stream) 1321 (setq cmd (cdr cmd))
1274 (setq cmd (cdr cmd)) 1322 (if cmd (princ " ")))))
1275 (if cmd (princ " " stream))))) 1323 (terpri))))))
1276 (terpri stream)))))))
1277
1278 ;; `find-function' et al moved to "find-func.el"
1279 1324
1280 ;;; help.el ends here 1325 ;;; help.el ends here