X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/8ff2ed527d8c7164a110f1cae9cd3f0140751f8b..199143f1fbc4f791ba20405ed1767e1cac099066:/lisp/progmodes/compile.el diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 32fa246b9f..0dc73e9666 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -458,9 +458,9 @@ starting the compilation process.") :version "21.4") (defface compilation-info-face - '((((class color) (min-colors 16) (background light)) + '((((class color) (min-colors 16) (background light)) (:foreground "Green3" :weight bold)) - (((class color) (min-colors 16) (background dark)) + (((class color) (min-colors 16) (background dark)) (:foreground "Green" :weight bold)) (((class color)) (:foreground "green" :weight bold)) (t (:weight bold))) @@ -579,12 +579,17 @@ Faces `compilation-error-face', `compilation-warning-face', (and end-line (setq end-line (match-string-no-properties end-line)) (setq end-line (string-to-number end-line))) - (and col - (setq col (match-string-no-properties col)) - (setq col (- (string-to-number col) compilation-first-column))) - (if (and end-col (setq end-col (match-string-no-properties end-col))) - (setq end-col (- (string-to-number end-col) compilation-first-column -1)) - (if end-line (setq end-col -1))) + (if col + (if (functionp col) + (setq col (funcall col)) + (and + (setq col (match-string-no-properties col)) + (setq col (- (string-to-number col) compilation-first-column))))) + (if (and end-col (functionp end-col)) + (setq end-col (funcall end-col)) + (if (and end-col (setq end-col (match-string-no-properties end-col))) + (setq end-col (- (string-to-number end-col) compilation-first-column -1)) + (if end-line (setq end-col -1)))) (if (consp type) ; not a static type, check what it is. (setq type (or (and (car type) (match-end (car type)) 1) (and (cdr type) (match-end (cdr type)) 0) @@ -726,9 +731,9 @@ FILE should be (ABSOLUTE-FILENAME) or (RELATIVE-FILENAME . DIRNAME) or nil." ,@(when end-line `((,end-line compilation-line-face nil t))) - ,@(when col + ,@(when (integerp col) `((,col compilation-column-face nil t))) - ,@(when end-col + ,@(when (integerp end-col) `((,end-col compilation-column-face nil t))) ,@(nthcdr 6 item) @@ -789,7 +794,10 @@ If this is run in a Compilation mode buffer, re-use the arguments from the original use. Otherwise, recompile using `compile-command'." (interactive) (save-some-buffers (not compilation-ask-about-save) nil) - (let ((default-directory (or compilation-directory default-directory))) + (let ((default-directory + (or (and (not (eq major-mode (nth 1 compilation-arguments))) + compilation-directory) + default-directory))) (apply 'compilation-start (or compilation-arguments `(,(eval compile-command)))))) @@ -816,8 +824,7 @@ Otherwise, construct a buffer name from MODE-NAME." (funcall name-function mode-name)) (compilation-buffer-name-function (funcall compilation-buffer-name-function mode-name)) - ((and (eq major-mode 'compilation-mode) - (equal mode-name (nth 2 compilation-arguments))) + ((eq major-mode (nth 1 compilation-arguments)) (buffer-name)) (t (concat "*" (downcase mode-name) "*")))) @@ -842,6 +849,7 @@ Otherwise, construct a buffer name from MODE-NAME." (defun compilation-start (command &optional mode name-function highlight-regexp) "Run compilation command COMMAND (low level interface). +If COMMAND starts with a cd command, that becomes the `default-directory'. The rest of the arguments are optional; for them, nil means use the default. MODE is the major mode to set in the compilation buffer. Mode @@ -854,26 +862,12 @@ global value of `compilation-highlight-regexp'. Returns the compilation buffer created." (or mode (setq mode 'compilation-mode)) - (let ((name-of-mode - (if (eq mode t) - (prog1 "compilation" (require 'comint)) - (replace-regexp-in-string "-mode$" "" (symbol-name mode)))) - (process-environment - (append - compilation-environment - (if (if (boundp 'system-uses-terminfo) ; `if' for compiler warning - system-uses-terminfo) - (list "TERM=dumb" "TERMCAP=" - (format "COLUMNS=%d" (window-width))) - (list "TERM=emacs" - (format "TERMCAP=emacs:co#%d:tc=unknown:" - (window-width)))) - ;; Set the EMACS variable, but - ;; don't override users' setting of $EMACS. - (unless (getenv "EMACS") '("EMACS=t")) - process-environment)) - (thisdir default-directory) - outwin outbuf) + (let* ((name-of-mode + (if (eq mode t) + (prog1 "compilation" (require 'comint)) + (replace-regexp-in-string "-mode$" "" (symbol-name mode)))) + (thisdir default-directory) + outwin outbuf) (with-current-buffer (setq outbuf (get-buffer-create @@ -892,17 +886,26 @@ Returns the compilation buffer created." (error nil)) (error "Cannot have two processes in `%s' at once" (buffer-name))))) - ;; Clear out the compilation buffer and make it writable. - ;; Change its default-directory to the directory where the compilation - ;; will happen, and insert a `cd' command to indicate this. - (setq buffer-read-only nil) (buffer-disable-undo (current-buffer)) - (erase-buffer) - (buffer-enable-undo (current-buffer)) + ;; first transfer directory from where M-x compile was called (setq default-directory thisdir) - ;; output a mode setter, for saving and later reloading this buffer - (insert "cd " thisdir " # -*-" name-of-mode - "-*-\nEntering directory `" thisdir "'\n" command "\n") + ;; Make compilation buffer read-only. The filter can still write it. + ;; Clear out the compilation buffer. + (let ((inhibit-read-only t) + (default-directory thisdir)) + ;; Then evaluate a cd command if any, but don't perform it yet, else start-command + ;; would do it again through the shell: (cd "..") AND sh -c "cd ..; make" + (cd (if (string-match "^\\s *cd\\(?:\\s +\\(\\S +?\\)\\)?\\s *[;&\n]" command) + (if (match-end 1) + (match-string 1 command) + "~") + default-directory)) + (erase-buffer) + ;; output a mode setter, for saving and later reloading this buffer + (insert "-*- mode: " name-of-mode + "; default-directory: " (prin1-to-string default-directory) + " -*-\n" command "\n") + (setq thisdir default-directory)) (set-buffer-modified-p nil)) ;; If we're already in the compilation buffer, go to the end ;; of the buffer, so point will track the compilation output. @@ -911,70 +914,85 @@ Returns the compilation buffer created." ;; Pop up the compilation buffer. (setq outwin (display-buffer outbuf nil t)) (with-current-buffer outbuf - (if (not (eq mode t)) - (funcall mode) - (with-no-warnings (comint-mode)) - (compilation-shell-minor-mode)) - ;; In what way is it non-ergonomic ? -stef - ;; (toggle-read-only 1) ;;; Non-ergonomic. - (if highlight-regexp - (set (make-local-variable 'compilation-highlight-regexp) - highlight-regexp)) - (set (make-local-variable 'compilation-arguments) - (list command mode name-function highlight-regexp)) - (set (make-local-variable 'revert-buffer-function) - 'compilation-revert-buffer) - (set-window-start outwin (point-min)) - (or (eq outwin (selected-window)) - (set-window-point outwin (if compilation-scroll-output - (point) - (point-min)))) - ;; The setup function is called before compilation-set-window-height - ;; so it can set the compilation-window-height buffer locally. - (if compilation-process-setup-function - (funcall compilation-process-setup-function)) - (compilation-set-window-height outwin) - ;; Start the compilation. - (if (fboundp 'start-process) - (let ((proc (if (eq mode t) - (get-buffer-process - (with-no-warnings - (comint-exec outbuf (downcase mode-name) - shell-file-name nil `("-c" ,command)))) - (start-process-shell-command (downcase mode-name) - outbuf command)))) - ;; Make the buffer's mode line show process state. - (setq mode-line-process '(":%s")) - (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 "\ + (let ((process-environment + (append + compilation-environment + (if (if (boundp 'system-uses-terminfo) ; `if' for compiler warning + system-uses-terminfo) + (list "TERM=dumb" "TERMCAP=" + (format "COLUMNS=%d" (window-width))) + (list "TERM=emacs" + (format "TERMCAP=emacs:co#%d:tc=unknown:" + (window-width)))) + ;; Set the EMACS variable, but + ;; don't override users' setting of $EMACS. + (unless (getenv "EMACS") '("EMACS=t")) + (copy-sequence process-environment)))) + (if (not (eq mode t)) + (funcall mode) + (setq buffer-read-only nil) + (with-no-warnings (comint-mode)) + (compilation-shell-minor-mode)) + (if highlight-regexp + (set (make-local-variable 'compilation-highlight-regexp) + highlight-regexp)) + (set (make-local-variable 'compilation-arguments) + (list command mode name-function highlight-regexp)) + (set (make-local-variable 'revert-buffer-function) + 'compilation-revert-buffer) + (set-window-start outwin (point-min)) + (or (eq outwin (selected-window)) + (set-window-point outwin (if compilation-scroll-output + (point) + (point-min)))) + ;; The setup function is called before compilation-set-window-height + ;; so it can set the compilation-window-height buffer locally. + (if compilation-process-setup-function + (funcall compilation-process-setup-function)) + (compilation-set-window-height outwin) + ;; Start the compilation. + (if (fboundp 'start-process) + (let ((proc (if (eq mode t) + (get-buffer-process + (with-no-warnings + (comint-exec outbuf (downcase mode-name) + shell-file-name nil `("-c" ,command)))) + (start-process-shell-command (downcase mode-name) + outbuf command)))) + ;; Make the buffer's mode line show process state. + (setq mode-line-process '(":%s")) + (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)))) - ;; Without async subprocesses, the buffer is not yet - ;; fontified, so fontify it now. - (let ((font-lock-verbose nil)) ; shut up font-lock messages - (font-lock-fontify-buffer)) - (message "Executing `%s'...done" command))) + status)))) + ((stringp status) + (compilation-handle-exit 'signal status + (concat status "\n"))) + (t + (compilation-handle-exit 'bizarre status status)))) + ;; Without async subprocesses, the buffer is not yet + ;; fontified, so fontify it now. + (let ((font-lock-verbose nil)) ; shut up font-lock messages + (font-lock-fontify-buffer)) + (message "Executing `%s'...done" command))) + ;; Now finally cd to where the shell started make/grep/... + (setq default-directory thisdir)) (if (buffer-local-value 'compilation-scroll-output outbuf) (save-selected-window (select-window outwin) @@ -1052,6 +1070,7 @@ exited abnormally with code %d\n" (set-keymap-parent map compilation-minor-mode-map) (define-key map " " 'scroll-up) (define-key map "\^?" 'scroll-down) + (define-key map "\C-c\C-f" 'next-error-follow-minor-mode) ;; Set up the menu-bar (define-key map [menu-bar compilation] @@ -1095,7 +1114,7 @@ from a different message." :version "21.4") ;;;###autoload -(defun compilation-mode () +(defun compilation-mode (&optional name-of-mode) "Major mode for compilation log buffers. \\To visit the source for a line-numbered error, move point to the error message line and type \\[compile-goto-error]. @@ -1108,7 +1127,7 @@ Runs `compilation-mode-hook' with `run-hooks' (which see). (kill-all-local-variables) (use-local-map compilation-mode-map) (setq major-mode 'compilation-mode - mode-name "Compilation") + mode-name (or name-of-mode "Compilation")) (set (make-local-variable 'page-delimiter) compilation-page-delimiter) (compilation-setup) @@ -1174,6 +1193,8 @@ If nil, use the beginning of buffer.") "Prepare the buffer for the compilation parsing commands to work. Optional argument MINOR indicates this is called from `compilation-minor-mode'." + (unless minor + (setq buffer-read-only t)) (make-local-variable 'compilation-current-error) (make-local-variable 'compilation-messages-start) (make-local-variable 'compilation-error-screen-columns) @@ -1235,7 +1256,7 @@ Turning the mode on runs the normal hook `compilation-minor-mode-hook'." (defun compilation-handle-exit (process-status exit-status msg) "Write MSG in the current buffer and hack its mode-line-process." - (let ((buffer-read-only nil) + (let ((inhibit-read-only t) (status (if compilation-exit-message-function (funcall compilation-exit-message-function process-status exit-status msg) @@ -1522,7 +1543,8 @@ If nil, don't scroll the compilation output window." (defun compilation-goto-locus (msg mk end-mk) "Jump to an error corresponding to MSG at MK. -All arguments are markers. If END-MK is non nil, mark is set there." +All arguments are markers. If END-MK is non-nil, mark is set there +and overlay is highlighted between MK and END-MK." (if (eq (window-buffer (selected-window)) (marker-buffer msg)) ;; If the compilation buffer window is selected, @@ -1538,7 +1560,7 @@ All arguments are markers. If END-MK is non nil, mark is set there." (widen) (goto-char mk)) (if end-mk - (push-mark end-mk nil t) + (push-mark end-mk t) (if mark-active (setq mark-active))) ;; If hideshow got in the way of ;; seeing the right place, open permanently. @@ -1559,26 +1581,32 @@ All arguments are markers. If END-MK is non nil, mark is set there." compilation-highlight-regexp))) (compilation-set-window-height w) - (when (and highlight-regexp - (not (and end-mk transient-mark-mode))) + (when highlight-regexp (unless compilation-highlight-overlay (setq compilation-highlight-overlay (make-overlay (point-min) (point-min))) - (overlay-put compilation-highlight-overlay 'face 'region)) + (overlay-put compilation-highlight-overlay 'face 'next-error)) (with-current-buffer (marker-buffer mk) (save-excursion - (end-of-line) + (if end-mk (goto-char end-mk) (end-of-line)) (let ((end (point))) - (beginning-of-line) + (if mk (goto-char mk) (beginning-of-line)) (if (and (stringp highlight-regexp) (re-search-forward highlight-regexp end t)) (progn (goto-char (match-beginning 0)) - (move-overlay compilation-highlight-overlay (match-beginning 0) (match-end 0))) - (move-overlay compilation-highlight-overlay (point) end)) - (sit-for 0.5) - (delete-overlay compilation-highlight-overlay))))))) - + (move-overlay compilation-highlight-overlay + (match-beginning 0) (match-end 0) + (current-buffer))) + (move-overlay compilation-highlight-overlay + (point) end (current-buffer))) + (if (numberp next-error-highlight) + (sit-for next-error-highlight)) + (if (not (eq next-error-highlight t)) + (delete-overlay compilation-highlight-overlay)))))) + (when (and (eq next-error-highlight 'fringe-arrow)) + (set (make-local-variable 'overlay-arrow-position) + (copy-marker (line-beginning-position)))))) (defun compilation-find-file (marker filename dir &rest formats) "Find a buffer for file FILENAME.