(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.

1 files changed, 65 insertions, 70 deletions

diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index 99426a3665a..464fcc90d3a 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -1,6 +1,6 @@
 ;;; compile.el --- run compiler as inferior of Emacs, parse error messages.
 
-;; Copyright (C) 1985, 86, 87, 93, 94, 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 86, 87, 93, 94, 1995, 1996 Free Software Foundation, Inc.
 
 ;; Author: Roland McGrath <roland@prep.ai.mit.edu>
 ;; Maintainer: FSF
@@ -259,9 +259,9 @@ 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.")
+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)
@@ -331,16 +331,15 @@ easily repeat a grep command."
     (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))))))))
+           (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
@@ -434,36 +433,27 @@ Returns the compilation buffer created."
               (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))
+          ;; No asynchronous processes available.
+          (message "Executing `%s'..." command)
           ;; Fake modeline display as if `start-process' were run.
           (setq mode-line-process ":run")
-          (sit-for 0) ;; Force redisplay
+          (force-mode-line-update)
+          (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)))))
+                                      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)))
 
@@ -581,6 +571,32 @@ See `compilation-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."
@@ -590,8 +606,7 @@ See `compilation-mode'."
           (if (null (buffer-name buffer))
               ;; buffer killed
               (set-process-buffer proc nil)
-            (let ((obuf (current-buffer))
-                  omax opoint)
+            (let ((obuf (current-buffer)))
               ;; save-excursion isn't the right thing if
               ;; process-buffer is current-buffer
               (unwind-protect
@@ -599,33 +614,13 @@ See `compilation-mode'."
                     ;; 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)))
+                    (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))
           ))))