Download
(eval-when-compile (require 'cl))
(require 'compile-20)
(require 'compile)
(require 'thingatpt nil t)
(when (and (require 'thingatpt+ nil t)
(fboundp 'tap-put-thing-at-point-props))
(tap-define-aliases-wo-prefix)
(tap-put-thing-at-point-props))
(require 'highlight nil t)
(defvar lazy-lock-defer-on-scrolling)
(defvar compilation-filter-hook)
(put 'compile-mode 'mode-class 'special)
(unless (facep 'minibuffer-prompt)
(defface minibuffer-prompt '((((background dark)) (:foreground "cyan"))
(t (:foreground "dark blue")))
"Face for minibuffer prompts."
:group 'basic-faces))
(defcustom grep-case-insensitive-option "-i"
"*Option for grep command that indicates case-insensitivity.
This is taken into account for match highlighting.
If your grep command has no such option, set this to \"\"."
:type 'string :group 'compilation)
(defcustom compile-buffer-mouse-face 'underline
"*Face for highlighting mouse-overs in compilation buffer."
:type 'sexp :group 'compilation)
(defcustom grep-regexp-face
(or (and (fboundp 'set-face-background)
(fboundp 'x-color-defined-p)
(x-color-defined-p "SkyBlue")
(prog1 (make-face 'grep-regexp-face)
(set-face-background 'grep-regexp-face "SkyBlue")))
'highlight)
"*Face for highlighting `grep' regexps."
:type 'sexp :group 'compilation)
(defcustom grep-default-regexp-fn (if (fboundp 'non-nil-symbol-name-nearest-point)
'non-nil-symbol-name-nearest-point
'word-at-point)
"*Function of 0 args called to provide default search regexp to \\[grep].
Some reasonable choices are defined in `thingatpt+.el':
`word-nearest-point', `non-nil-symbol-name-nearest-point',
`region-or-non-nil-symbol-name-nearest-point', `sexp-nearest-point'.
This is ignored if Transient Mark mode is on and the region is active
and non-empty. In that case, the quoted (\") region text is used as
the default regexp.
If `grep-default-regexp-fn' is nil and no prefix arg is given to
`grep', then no defaulting is done.
Otherwise, if the value is not a function, then function
`grep-default-regexp-fn' does the defaulting."
:type '(choice
(const :tag "No default search regexp (unless you use `C-u')" nil)
(function :tag "Function of zero args to provide default search regexp"))
:group 'grep)
(defcustom grep-default-comment-line-regexp ":[0-9]+: *;"
"*Default regexp for a comment line, for use in `remove-grep-comments'.
The default value matches lines that begin with a Lisp comment."
:type 'string :group 'grep)
(defvar grep-pattern nil "Search pattern used by latest \\[grep] command.")
(defun grep-default-regexp-fn ()
"*Function of 0 args called to provide default search regexp to \\[grep].
This is used only if both of the following are true:
- Transient Mark mode is off or the region is inactive or empty.
- The value of option `grep-default-regexp-fn' is
`grep-default-regexp-fn'.
When this is used, the default regexp is provided by calling the
first of these that references a defined function:
- variable `grep-default-regexp-fn'
- variable `find-tag-default-function'
- the `find-tag-default-function' property of the `major-mode'
- function `non-nil-symbol-name-nearest-point', if bound
- function `grep-tag-default'"
(cond ((functionp grep-default-regexp-fn) grep-default-regexp-fn)
(find-tag-default-function)
((get major-mode 'find-tag-default-function))
((fboundp 'non-nil-symbol-name-nearest-point) 'non-nil-symbol-name-nearest-point)
(t
'grep-tag-default)))
(defun compile (command)
"Compile the program including the current buffer. Default: run `make'.
Runs COMMAND, a shell command, in a separate process asynchronously
with output going to the buffer `*compilation*'.
You can then use the command \\[next-error] to find the next error message
and move to the source code that caused it.
Interactively, prompts for the command if `compilation-read-command' is
non-nil; otherwise uses `compile-command'. With prefix arg, always prompts.
To run more than one compilation at once, start one and rename the
\`*compilation*' buffer to some other name with \\[rename-buffer].
Then start the next one.
The name used for the buffer is actually whatever is returned by the
function in `compilation-buffer-name-function', so you can set that to
a function that generates a unique name."
(interactive
(if (or compilation-read-command current-prefix-arg)
(list (read-from-minibuffer "Compile command: "
compile-command nil nil
'(compile-history . 1)))
(list compile-command)))
(setq grep-pattern nil
compile-command command)
(save-some-buffers (not compilation-ask-about-save) nil)
(compile-internal compile-command "No more errors."))
(defun grep (command-args)
"Run `grep' with user-specified args, and collect output in a buffer.
COMMAND-ARGS are the user-specified arguments.
While `grep' runs asynchronously, you can use the
\\[next-error] command (M-x next-error), or \\<compilation-minor-mode-map>\\[compile-goto-error]
in the grep output buffer, to find the text that `grep' hits refer to.
This command uses a special history list for its arguments, so you can
easily repeat a `grep' command.
The text (regexp) to find is defaulted as follows:
- If Transient Mark mode is on and the region is active and nonempty,
then the double-quoted region text is used. (If the region contains
double-quotes (\"), then you will need to escape them by hand.)
- If option `grep-default-regexp-fn' is a function, then it is called
to return the default regexp.
- If `grep-default-regexp-fn' is nil and no prefix arg is provided,
then no default regexp is used.
If a prefix arg is provided, the default text is substituted into the
last grep command in the grep command history (or into `grep-command'
if that history list is empty). That is, the same command options and
files to search are used as the last time."
(interactive
(let ((arg current-prefix-arg)
grep-default)
(unless grep-command (grep-compute-defaults))
(when arg
(let ((tag-default (funcall (grep-default-regexp-fn))))
(setq grep-default (or (car grep-history) grep-command))
(when (string-match "[^ ]+\\s +\\(-[^ ]+\\s +\\)*\\(\"[^\"]+\"\\|[^ ]+\\)"
grep-default)
(setq grep-default (replace-match tag-default t t grep-default 2)))))
(list (read-from-minibuffer
"grep <pattern> <files> : "
(if arg
(or grep-default grep-command)
(concat grep-command
(if (and transient-mark-mode mark-active
(not (eq (region-beginning) (region-end))))
(concat "\"" (buffer-substring-no-properties (region-beginning)
(region-end)) "\"")
(and (grep-default-regexp-fn) (funcall (grep-default-regexp-fn))))
" "))
nil nil 'grep-history))))
(when (fboundp 'set-face-foreground)
(cond (
(string-match
(concat
grep-program
"[ \t]*\\(-[a-zA-Z]+\\s-+\\)*[ \t]*\\('[^']+'\\|\"[^\"]+\"\\)")
command-args)
(setq grep-pattern
(substring command-args (1+ (match-beginning 2)) (1- (match-end 2)))))
(
(string-match
(concat grep-program
"[ \t]*\\(-[a-zA-Z]+\\s-+\\)*[ \t]*\\([^ \n\t'\"]+\\)")
command-args)
(setq grep-pattern (substring command-args (match-beginning 2) (match-end 2))))
(t
(setq grep-pattern nil))))
(when (and (not (string= "" grep-case-insensitive-option))
(string-match grep-case-insensitive-option command-args))
(setq grep-pattern (mapconcat (lambda (char)
(if (or (and (>= char ?a) (<= char ?z))
(and (>= char ?A) (<= char ?Z)))
(concat "[" (char-to-string (downcase char))
(char-to-string (upcase char)) "]")
(char-to-string char)))
grep-pattern "")))
(let* ((compilation-process-setup-function 'grep-process-setup)
(buf
(compile-internal (if null-device (concat command-args " " null-device) command-args)
"No more grep hits" "grep"
nil grep-regexp-alist)))))
(defun compilation-mode-font-lock-keywords ()
"Return expressions to highlight in Compilation mode."
(nconc
(mapcar (function
(lambda (item)
(let ((file-idx (nth 1 item))
(line-idx (nth 2 item))
(col-idx (nth 3 item))
keyword)
(when (numberp col-idx)
(setq keyword (cons (list (1+ col-idx) 'font-lock-type-face nil t) keyword)))
(when (numberp line-idx)
(setq keyword (cons (list (1+ line-idx) 'font-lock-variable-name-face)
keyword)))
(when (numberp file-idx)
(setq keyword (cons (list (1+ file-idx) 'font-lock-warning-face) keyword)))
(cons (concat "^\\(" (nth 0 item) "\\)") keyword))))
compilation-error-regexp-alist)
(and grep-pattern `((,(concat "\\(" grep-pattern "\\)") 1 grep-regexp-face)))
(list
'("^\\([A-Za-z_0-9/\.+-]+\\)\\(\\[\\([0-9]+\\)\\]\\)?[ \t]*:"
(1 font-lock-function-name-face) (3 font-lock-comment-face nil t)))))
(defun compile-internal (command error-message
&optional name-of-mode parser
error-regexp-alist name-function
enter-regexp-alist leave-regexp-alist
file-regexp-alist nomessage-regexp-alist)
"Run compilation command COMMAND (low level interface).
ERROR-MESSAGE is a string to print if the user asks to see another error
and there are no more errors. The rest of the arguments, 3-10 are optional.
For them nil means use the default.
NAME-OF-MODE is the name to display as the major mode in the compilation
buffer. PARSER is the error parser function. ERROR-REGEXP-ALIST is the error
message regexp alist to use. NAME-FUNCTION is a function called to name the
buffer. ENTER-REGEXP-ALIST is the enter directory message regexp alist to use.
LEAVE-REGEXP-ALIST is the leave directory message regexp alist to use.
FILE-REGEXP-ALIST is the change current file message regexp alist to use.
NOMESSAGE-REGEXP-ALIST is the nomessage regexp alist to use.
The defaults for these variables are the global values of
\`compilation-parse-errors-function', `compilation-error-regexp-alist',
\`compilation-buffer-name-function', `compilation-enter-directory-regexp-alist',
\`compilation-leave-directory-regexp-alist', `compilation-file-regexp-alist',
\ and `compilation-nomessage-regexp-alist', respectively.
For arg 7-10 a value of t means an empty alist.
Return the compilation buffer created."
(let (outbuf)
(save-excursion
(unless name-of-mode (setq name-of-mode "Compilation"))
(setq outbuf (get-buffer-create
(funcall (or name-function compilation-buffer-name-function
(function (lambda (mode)
(concat "*" (downcase mode) "*"))))
name-of-mode)))
(set-buffer outbuf)
(let ((comp-proc (get-buffer-process (current-buffer))))
(when comp-proc
(if (or (not (eq (process-status comp-proc) 'run))
(yes-or-no-p (format "A %s process is running; kill it? "
name-of-mode)))
(condition-case nil
(progn (interrupt-process comp-proc)
(sit-for 1)
(delete-process comp-proc))
(error nil))
(error "Cannot have two processes in `%s' at once"
(buffer-name)))))
(kill-all-local-variables))
(unless error-regexp-alist (setq error-regexp-alist compilation-error-regexp-alist))
(unless enter-regexp-alist (setq enter-regexp-alist compilation-enter-directory-regexp-alist))
(unless leave-regexp-alist (setq leave-regexp-alist compilation-leave-directory-regexp-alist))
(unless file-regexp-alist (setq file-regexp-alist compilation-file-regexp-alist))
(unless nomessage-regexp-alist
(setq nomessage-regexp-alist compilation-nomessage-regexp-alist))
(unless parser (setq parser compilation-parse-errors-function))
(let ((thisdir default-directory)
outwin)
(save-excursion
(set-buffer outbuf)
(setq buffer-read-only nil)
(buffer-disable-undo (current-buffer))
(erase-buffer)
(buffer-enable-undo (current-buffer))
(setq default-directory thisdir)
(insert "cd " thisdir "\n" command "\n")
(setq font-lock-fontified nil)
(set-buffer-modified-p nil))
(when (eq outbuf (current-buffer)) (goto-char (point-max)))
(setq outwin (let ((fit-frame-inhibit-fitting-flag t)) (display-buffer outbuf)))
(save-excursion
(set-buffer outbuf)
(goto-char (point-max))
(compilation-mode name-of-mode)
(set (make-local-variable 'compilation-parse-errors-function) parser)
(set (make-local-variable 'compilation-error-message) error-message)
(set (make-local-variable 'compilation-error-regexp-alist)
error-regexp-alist)
(set (make-local-variable 'compilation-enter-directory-regexp-alist)
enter-regexp-alist)
(set (make-local-variable 'compilation-leave-directory-regexp-alist)
leave-regexp-alist)
(set (make-local-variable 'compilation-file-regexp-alist)
file-regexp-alist)
(set (make-local-variable 'compilation-nomessage-regexp-alist)
nomessage-regexp-alist)
(set (make-local-variable 'compilation-arguments)
(list command error-message
name-of-mode parser
error-regexp-alist name-function
enter-regexp-alist leave-regexp-alist
file-regexp-alist nomessage-regexp-alist))
(make-local-variable 'lazy-lock-defer-on-scrolling)
(setq lazy-lock-defer-on-scrolling t
default-directory thisdir
compilation-directory-stack (list default-directory))
(set-window-start outwin (point-min))
(unless (eq outwin (selected-window)) (set-window-point outwin (point-min)))
(compilation-set-window-height outwin)
(when compilation-process-setup-function
(funcall compilation-process-setup-function))
(if (fboundp 'start-process)
(let* ((process-environment (cons "EMACS=t" process-environment))
(proc (start-process-shell-command (downcase mode-name)
outbuf
command)))
(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)))
(message "Executing `%s'..." command)
(setq mode-line-process ":run")
(force-mode-line-update)
(sit-for 0)
(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)))
(when compilation-scroll-output
(save-selected-window (select-window outwin) (goto-char (point-max)))))
(setq compilation-last-buffer outbuf)))
(defun compilation-mode (&optional name-of-mode)
"Major mode for compilation log buffers.
\\<compilation-mode-map>To visit the source for a line-numbered error,
move point to the error message line and type \\[compile-goto-error].
To kill the compilation, type \\[kill-compilation].
Runs `compilation-mode-hook' with `run-hooks' (which see).
NAME-OF-MODE is the name to use for the `mode-name' (default:
\"Compilation\").
The following bindings are in effect in this mode:
\\{compilation-mode-map}"
(interactive)
(fundamental-mode)
(use-local-map compilation-mode-map)
(setq major-mode 'compilation-mode
mode-name (or name-of-mode "Compilation"))
(compilation-setup)
(set (make-local-variable 'font-lock-defaults) '(compilation-mode-font-lock-keywords t))
(set (make-local-variable 'revert-buffer-function) 'compilation-revert-buffer)
(run-hooks 'compilation-mode-hook))
(defun compilation-next-error (nth)
"Move point to the NTH next error in the compilation buffer.
Does NOT find the source line like \\[next-error].
NTH defaults to 1, meaning the next error."
(interactive "p")
(unless (compilation-buffer-p (current-buffer))
(error "Not in a compilation buffer"))
(setq compilation-last-buffer (current-buffer))
(let ((errors (compile-error-at-point)))
(goto-char (car (if (< nth 0)
(let ((i 0)
(e compilation-old-error-list))
(while (not (eq e errors)) (incf i) (pop e))
(if (> (- nth) i)
(error "Moved back past first error")
(nth (+ i nth) compilation-old-error-list)))
(let ((compilation-error-list (cdr errors)))
(compile-reinitialize-errors nil nil nth)
(if compilation-error-list
(nth (1- nth) compilation-error-list)
(error "Moved past last error")))))))
(what-line))
(defun compilation-goto-locus (next-error)
"Jump to an error locus returned by `compilation-next-error-locus'.
Takes one argument, a cons (ERROR . SOURCE) of two markers.
Selects a window with point at SOURCE, with another window displaying ERROR.
NEXT-ERROR is the locus of the next compilation error."
(if (eq (window-buffer (selected-window))
(marker-buffer (car next-error)))
(let ((pop-up-windows t))
(pop-to-buffer (marker-buffer (cdr next-error))))
(if (and (window-dedicated-p (selected-window))
(eq (selected-window) (frame-root-window)))
(switch-to-buffer-other-frame (marker-buffer (cdr next-error)))
(switch-to-buffer (marker-buffer (cdr next-error)))))
(goto-char (cdr next-error))
(unless (= (point) (marker-position (cdr next-error)))
(widen) (goto-char (cdr next-error)))
(let* ((pop-up-windows t)
(w (or (get-buffer-window (marker-buffer (car next-error)) 'visible)
(display-buffer (marker-buffer (car next-error))))))
(set-window-point w (car next-error))
(set-window-start w (car next-error))
(when (and (fboundp 'hlt-highlight-regexp-region) grep-pattern)
(hlt-highlight-regexp-region (line-beginning-position) (line-end-position)
grep-pattern grep-regexp-face)
(message (format "Line %s. %s"
(+ (count-lines (point-min) (point))
(if (= (current-column) 0) 1 0))
(substitute-command-keys
"`\\[negative-argument] \
\\[highlight]' to remove highlighting (in a region)."))))
(compilation-set-window-height w))
(raise-frame))
(defun compile-reinitialize-errors (reparse &optional limit-search find-at-least)
"Parse new errors in compilation buffer, or reparse from the beginning
if the user has asked for that."
(save-excursion
(set-buffer compilation-last-buffer)
(when (or (eq compilation-error-list t)
reparse)
(compilation-forget-errors))
(unless (and compilation-error-list
(or (not limit-search)
(> compilation-parsing-end limit-search))
(or (not find-at-least)
(>= (length compilation-error-list) find-at-least)))
(set-buffer-modified-p nil)
(when (< compilation-parsing-end (point-max))
(let ((error-list-pos compilation-error-list))
(funcall compilation-parse-errors-function
limit-search
(and find-at-least
(- find-at-least (length compilation-error-list))))
(setq compilation-old-error-list
(nconc compilation-old-error-list compilation-error-list))
(when error-list-pos
(setq compilation-error-list error-list-pos))
(let ((inhibit-read-only t)
(buffer-undo-list t)
(error-list compilation-error-list)
deactivate-mark)
(while error-list
(save-excursion (put-text-property (goto-char (car (car error-list)))
(line-end-position)
'mouse-face compile-buffer-mouse-face))
(setq error-list (cdr error-list)))))))))
(defun compilation-forget-errors ()
"Set `compilation-error-list' to nil, and unchain markers
that point to the error messages and their text, so that they no
longer slow down gap motion. This would happen anyway at the next
garbage collection, but it is better to do it right away."
(while compilation-old-error-list
(let ((next-error (car compilation-old-error-list)))
(set-marker (car next-error) nil)
(if (markerp (cdr next-error))
(set-marker (cdr next-error) nil)))
(setq compilation-old-error-list (cdr compilation-old-error-list)))
(setq compilation-error-list nil
compilation-directory-stack (list default-directory)
compilation-parsing-end 1)
(let ((inhibit-read-only t)
(buffer-undo-list t)
deactivate-mark)
(remove-text-properties (point-min) (point-max) (list 'mouse-face compile-buffer-mouse-face))))
(defun new-grep-buffer ()
"Rename current grep buffer and switch to new buffer *grep*.
Current buffer must be a grep buffer. It is renamed to *grep*<N>."
(interactive)
(unless (string-match "\\*grep\\*" (buffer-name (current-buffer)))
(error "Not in a grep buffer"))
(rename-uniquely)
(switch-to-buffer "*grep*")
(compilation-mode))
(defun choose-grep-buffer (buf)
"Switch to a grep buffer."
(interactive
(let ((bufs (grep-buffers)))
(unless bufs (error "No grep buffers"))
(list (completing-read "Grep buffer: " bufs nil t nil nil
(and (consp (cdr bufs)) (car (cadr bufs)))))))
(switch-to-buffer buf)
(select-frame-set-input-focus (selected-frame))
(compilation-mode))
(defun grep-buffers ()
"List of names of grep buffers."
(let ((bufs ()))
(dolist (buf (buffer-list))
(when (string-match "\\*grep\\*" (buffer-name buf)) (push (list (buffer-name buf)) bufs)))
(nreverse bufs)))
(unless (fboundp 'select-frame-set-input-focus)
(defun select-frame-set-input-focus (frame)
"Select FRAME, raise it, and set input focus, if possible."
(select-frame frame)
(raise-frame frame)
(cond ((eq window-system 'x) (x-focus-frame frame))
((eq window-system 'w32) (w32-focus-frame frame)))
(cond (focus-follows-mouse (set-mouse-position (selected-frame) (1- (frame-width)) 0)))))
(defun remove-grep-comments (&optional read-regexp-p)
"Remove lines that are completely commented out.
With a prefix argument, you are prompted for the regexp used to match
commented lines. The default value is
`grep-default-comment-line-regexp'.
With no prefix argument, this default value is used as the regexp.
You can use command `grep-toggle-comments' to toggle automatic removal
of commented lines.
Note: This simply removes lines that begin with the regexp you
provide. It does not, in general, remove multi-line comments. Use it
to remove C++ comments that start with //, but not multi-line comments
between /* and */."
(interactive "P")
(let ((inhibit-read-only t)
(regexp (if read-regexp-p
(read-from-minibuffer
"Comment regexp: " nil nil nil 'regexp-history
grep-default-comment-line-regexp)
grep-default-comment-line-regexp)))
(save-excursion (goto-char (point-min))
(flush-lines regexp))))
(defun toggle-grep-comments ()
"Toggle removal of commented lines in grep output."
(interactive)
(cond ((and (boundp 'compilation-filter-hook)
(memq 'remove-grep-comments compilation-filter-hook))
(remove-hook 'compilation-filter-hook 'remove-grep-comments)
(when (consp grep-history) (grep (car grep-history)))
(message "Automatic removal of commented lines is now OFF"))
(t
(add-hook 'compilation-filter-hook 'remove-grep-comments)
(when (consp grep-history) (grep (car grep-history)))
(message "Automatic removal of commented lines is now ON"))))
(provide 'compile+20)