comparison lisp/progmodes/compile.el @ 14045:1300c7703f67

(compilation-handle-exit): New function, broken out of compilation-sentinel. (compilation-sentinel, compile-internal): Use it. (compilation-exit-message-function): Doc fix for protocol change: take process status and exit-code args instead of process object. (grep): Use new protocol for compilation-exit-message-function.

14044:1c331f9332ae

;;; compile.el --- run compiler as inferior of Emacs, parse error messages.

;; Copyright (C) 1985, 86, 87, 93, 94, 1995 Free Software Foundation, Inc.

;; Author: Roland McGrath <[e-mail]>
;; Maintainer: FSF
;; Keywords: tools, processes

  "Stack of previous directories for `compilation-leave-directory-regexp'.
The head element is the directory the compilation was started in.")

(defvar compilation-exit-message-function nil "\
If non-nil, called when a compilation process dies to return a status message.
This should be a function a two arguments as passed to a process sentinel
\(see `set-process-sentinel\); it returns a cons (MESSAGE . MODELINE) of the
strings to write into the compilation buffer, and to put in its mode line.")

;; History of compile commands.
(defvar compile-history nil)
;; History of grep commands.
(defvar grep-history nil)

			       ;; Give it a simpler regexp to match.
			       nil grep-regexp-alist)))
    (save-excursion
      (set-buffer buf)
      (set (make-local-variable 'compilation-exit-message-function)
	   (lambda (proc msg)
	     (let ((code (process-exit-status proc)))
	       (if (eq (process-status proc) 'exit)
		   (cond ((zerop code)
			  '("finished (matches found)\n" . "matched"))
			 ((= code 1)
			  '("finished with no matches found\n" . "no match"))
			 (t
			  (cons msg code)))
		 (cons msg code))))))))

(defun compile-internal (command error-message
				 &optional name-of-mode parser regexp-alist
				 name-function)
  "Run compilation command COMMAND (low level interface).

	      (set-process-sentinel proc 'compilation-sentinel)
	      (set-process-filter proc 'compilation-filter)
	      (set-marker (process-mark proc) (point) outbuf)
	      (setq compilation-in-progress
		    (cons proc compilation-in-progress)))
	  ;; No asynchronous processes available
	  (message (format "Executing `%s'..." command))
	  ;; Fake modeline display as if `start-process' were run.
	  (setq mode-line-process ":run")
	  (sit-for 0) ;; Force redisplay
	  (let ((status (call-process shell-file-name nil outbuf nil "-c"
				      command))
		finish-msg)
	    ;; Fake modeline after exit.
	    (setq mode-line-process
		  (cond ((numberp status) (format ":exit[%d]" status))
			((stringp status) (format ":exit[-1: %s]" status))
			(t ":exit[???]")))
	    ;; Call `compilation-finish-function' as `compilation-sentinel'
	    ;; would, and finish up the compilation buffer with the same
	    ;; message we would get from `start-process'.
	    (setq finish-msg
		  (if (numberp status)
		      (if (zerop status)
			  "finished\n"
			(format "exited abnormally with code %d\n" status))
		    "exited abnormally with code -1\n"))
	    (goto-char (point-max))
	    (insert "\nCompilation " finish-msg)
	    (forward-char -1)
	    (insert " at " (substring (current-time-string) 0 19)) ; no year
	    (forward-char 1)
	    (if compilation-finish-function
		(funcall compilation-finish-function outbuf finish-msg)))
	(message (format "Executing `%s'...done" command)))))
    ;; Make it so the next C-x ` will use this buffer.
    (setq compilation-last-buffer outbuf)))

;; Set the height of WINDOW according to compilation-window-height.
(defun compilation-set-window-height (window)

  (if (setq compilation-minor-mode (if (null arg)
				       (null compilation-minor-mode)
				     (> (prefix-numeric-value arg) 0)))
      (compilation-setup)))

;; Called when compilation process changes state.
(defun compilation-sentinel (proc msg)
  "Sentinel for compilation buffers."
  (let ((buffer (process-buffer proc)))
    (if (memq (process-status proc) '(signal exit))
	(progn
	  (if (null (buffer-name buffer))
	      ;; buffer killed
	      (set-process-buffer proc nil)
	    (let ((obuf (current-buffer))
		  omax opoint)
	      ;; save-excursion isn't the right thing if
	      ;; process-buffer is current-buffer
	      (unwind-protect
		  (progn
		    ;; Write something in the compilation buffer
		    ;; and hack its mode line.
		    (set-buffer buffer)
		    (let ((buffer-read-only nil)
			  (status (if compilation-exit-message-function
				      (funcall compilation-exit-message-function
					       proc msg)
				    (cons msg (process-exit-status proc)))))
		      (setq omax (point-max)
			    opoint (point))
		      (goto-char omax)
		      ;; Record where we put the message, so we can ignore it
		      ;; later on.
		      (insert ?\n mode-name " " (car status))
		      (forward-char -1)
		      (insert " at " (substring (current-time-string) 0 19))
		      (forward-char 1)
		      (setq mode-line-process
			    (format ":%s [%s]"
				    (process-status proc) (cdr status)))
		      ;; Since the buffer and mode line will show that the
		      ;; process is dead, we can delete it now.  Otherwise it
		      ;; will stay around until M-x list-processes.
		      (delete-process proc)
		      ;; Force mode line redisplay soon.
		      (force-mode-line-update))
		    (if (and opoint (< opoint omax))
			(goto-char opoint))
		    (if compilation-finish-function
			(funcall compilation-finish-function buffer msg)))
		(set-buffer obuf))))
	  (setq compilation-in-progress (delq proc compilation-in-progress))
	  ))))

(defun compilation-filter (proc string)

14045:1300c7703f67

;;; compile.el --- run compiler as inferior of Emacs, parse error messages.

;; Copyright (C) 1985, 86, 87, 93, 94, 1995, 1996 Free Software Foundation, Inc.

;; Author: Roland McGrath <[e-mail]>
;; Maintainer: FSF
;; Keywords: tools, processes

  "Stack of previous directories for `compilation-leave-directory-regexp'.
The head element is the directory the compilation was started in.")

(defvar compilation-exit-message-function nil "\
If non-nil, called when a compilation process dies to return a status message.
This should be a function of three arguments: process status, exit status,
and exit message; it returns a cons (MESSAGE . MODELINE) of the strings to
write into the compilation buffer, and to put in its mode line.")

;; History of compile commands.
(defvar compile-history nil)
;; History of grep commands.
(defvar grep-history nil)

			       ;; Give it a simpler regexp to match.
			       nil grep-regexp-alist)))
    (save-excursion
      (set-buffer buf)
      (set (make-local-variable 'compilation-exit-message-function)
	   (lambda (status code msg)
	     (if (eq status 'exit)
		 (cond ((zerop code)
			'("finished (matches found)\n" . "matched"))
		       ((= code 1)
			'("finished with no matches found\n" . "no match"))
		       (t
			(cons msg code)))
	       (cons msg code)))))))

(defun compile-internal (command error-message
				 &optional name-of-mode parser regexp-alist
				 name-function)
  "Run compilation command COMMAND (low level interface).

	      (set-process-sentinel proc 'compilation-sentinel)
	      (set-process-filter proc 'compilation-filter)
	      (set-marker (process-mark proc) (point) outbuf)
	      (setq compilation-in-progress
		    (cons proc compilation-in-progress)))
	  ;; No asynchronous processes available.
	  (message "Executing `%s'..." command)
	  ;; Fake modeline display as if `start-process' were run.
	  (setq mode-line-process ":run")
	  (force-mode-line-update)
	  (sit-for 0)			; Force redisplay
	  (let ((status (call-process shell-file-name nil outbuf nil "-c"
				      command)))
	    (cond ((numberp status)
		   (compilation-handle-exit 'exit status
					    (if (zerop status)
						"finished\n"
					      (format "\
exited abnormally with code %d\n"
						      status))))
		  ((stringp status)
		   (compilation-handle-exit 'signal status
					    (concat status "\n")))
		  (t
		   (compilation-handle-exit 'bizarre status status))))
	  (message "Executing `%s'...done" command))))
    ;; Make it so the next C-x ` will use this buffer.
    (setq compilation-last-buffer outbuf)))

;; Set the height of WINDOW according to compilation-window-height.
(defun compilation-set-window-height (window)

  (if (setq compilation-minor-mode (if (null arg)
				       (null compilation-minor-mode)
				     (> (prefix-numeric-value arg) 0)))
      (compilation-setup)))

;; Write msg in the current buffer and hack its mode-line-process.
(defun compilation-handle-exit (process-status exit-status msg)
  (let ((buffer-read-only nil)
	(status (if compilation-exit-message-function
		    (funcall compilation-exit-message-function
			     process-status exit-status msg)
		  (cons msg exit-status)))
	(omax (point-max))
	(opoint (point)))
    ;; Record where we put the message, so we can ignore it
    ;; later on.
    (goto-char omax)
    (insert ?\n mode-name " " (car status))
    (forward-char -1)
    (insert " at " (substring (current-time-string) 0 19))
    (forward-char 1)
    (setq mode-line-process
	  (format ":%s [%s]"
		  (process-status proc) (cdr status)))
    ;; Force mode line redisplay soon.
    (force-mode-line-update)
    (if (and opoint (< opoint omax))
	(goto-char opoint))
    (if compilation-finish-function
	(funcall compilation-finish-function buffer msg))))

;; Called when compilation process changes state.
(defun compilation-sentinel (proc msg)
  "Sentinel for compilation buffers."
  (let ((buffer (process-buffer proc)))
    (if (memq (process-status proc) '(signal exit))
	(progn
	  (if (null (buffer-name buffer))
	      ;; buffer killed
	      (set-process-buffer proc nil)
	    (let ((obuf (current-buffer)))
	      ;; save-excursion isn't the right thing if
	      ;; process-buffer is current-buffer
	      (unwind-protect
		  (progn
		    ;; Write something in the compilation buffer
		    ;; and hack its mode line.
		    (set-buffer buffer)
		    (compilation-handle-exit (process-status proc)
					     (process-exit-status proc)
					     msg)
		    ;; Since the buffer and mode line will show that the
		    ;; process is dead, we can delete it now.  Otherwise it
		    ;; will stay around until M-x list-processes.
		    (delete-process proc))
		(set-buffer obuf))))
	  (setq compilation-in-progress (delq proc compilation-in-progress))
	  ))))

(defun compilation-filter (proc string)