[Top][All Lists]

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

compile+.el - extensions to GNU `compile.el'

From: Drew Adams
Subject: compile+.el - extensions to GNU `compile.el'
Date: Wed, 17 Jan 2001 16:42:05 -0500

;;; compile+.el --- Extensions to `compile.el'.
;; Emacs Lisp Archive Entry
;; Filename: compile+.el
;; Description: Extensions to `compile.el'.
;; Author: Drew ADAMS
;; Maintainer: Drew ADAMS
;; Copyright (C) 1999-2001, Drew Adams, all rights reserved.
;; Created: Fri Apr  2 16:55:16 1999
;; Version: $Id: compile+.el,v 1.7 2001/01/08 22:30:28 dadams Exp $
;; Last-Updated: Mon Jan  8 14:30:02 2001
;;           By: dadams
;;     Update #: 545
;; Keywords: tools, processes
;; Compatibility: GNU Emacs 20.x
;;; Commentary: 
;;    Extensions to `compile.el'.
;;  See also the companion file `compile-.el'.
;;        `compile-.el' should be loaded before `compile.el'.
;;        `compile+.el' should be loaded after `compile.el'.
;;  New user options defined here:
;;    `compile-buffer-mouse-face', `grep-regexp-face',
;;    `grep-default-regexp-fn'.
;;  Other new variable defined here: `grep-pattern'.
;;  ***** NOTE: The following functions defined in `compile.el'
;;              have been REDEFINED HERE:
;;  `compilation-forget-errors' - Use `compile-buffer-mouse-face'.
;;  `compilation-goto-locus' - 1. Highlights `grep-pattern' at error.
;;                             2. Calls `what-line' to display line #.
;;  `compilation-mode' - Uses `fundamental-mode' instead of
;;                       `kill-all-local-variables'.
;;  `compilation-mode-font-lock-keywords' - Highlights `grep-pattern'
;;                                          in `*grep*' buffer.
;;  `compilation-next-error' - Calls `what-line' to display line #.
;;  `compile' - Resets `grep-pattern' from last grep.
;;  `compile-internal' - 1. Set `font-lock-fontified' to nil.
;;                       2. Don't let frame get shrunk.
;;  `compile-reinitialize-errors' - Use `compile-buffer-mouse-face'.
;;  `grep' - 1. Interactive spec uses `grep-default-regexp-fn'.
;;           2. Saves `grep-pattern' for highlighting.
;; Compile mode is now suitable only for specially formatted data:
;; That is, we do a `(put 'compile-mode 'mode-class 'special)'.
;; Some bindings that would try to modify a compilation mode buffer
;; are unbound. Their key sequences will then appear to the user
;; as available for local (Compilation Mode) definition. That is,
;; we do this here: `(undefine-killer-commands 
;;                       compilation-mode-map
;;                       (current-global-map))'
;;; Change log:
;; RCS $Log: compile+.el,v $
;; RCS Revision 1.7  2001/01/08 22:30:28  dadams
;; RCS Adapted file header for Emacs Lisp Archive.
;; RCS
;; RCS Revision 1.6  2001/01/03 17:32:01  dadams
;; RCS *** empty log message ***
;; RCS
;; RCS Revision 1.5  2001/01/03 00:34:01  dadams
;; RCS *** empty log message ***
;; RCS
;; RCS Revision 1.4  2000/12/07 19:34:15  dadams
;; RCS *** empty log message ***
;; RCS
;; RCS Revision 1.3  2000/11/28 19:22:22  dadams
;; RCS Optional require's via 3rd arg=t now.
;; RCS
;; RCS Revision 1.2  2000/09/27 21:08:41  dadams
;; RCS Updated for Emacs 20.7:
;; RCS 1. Removed compilation-sentinel.
;; RCS 2. compile-internal: go to eob before running process.
;; RCS
;; RCS Revision 1.1  2000/09/14 14:52:34  dadams
;; RCS Initial revision
;; RCS
; Revision 1.7  1999/09/02  15:10:48  dadams
; Removed to compile-.el: `compile-mode-summary'.
; Revision 1.6  1999/09/02  14:54:08  dadams
; 1. Removed to compile-.el (new): `compilation-minor-mode-map'.
; 2. Removed: `compilation-mode-map'.
; 3. Require compile-.el.
; 4. Moved provide to end.
; Revision 1.5  1999/08/12  07:15:48  dadams
; `underline' instead of `highlight' for `mouse-face', and put on whole line.
; Revision 1.4  1999/04/14  11:07:42  dadams
; `grep-regexp-face': Define as `skyblue-background-face' if that is defined.
; Revision 1.3  1999/04/13  13:59:44  dadams
; `compilation-sentinel': Only put `mouse-face' on the `grep-regexp-alist' part.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Code:

(require 'cl) ;; when, unless, pop, incf, caar
(require 'compile-) ;; for new defvars from `compile.el'
(require 'compile)

(require 'misc-fns nil t) ;; (no error if not found): undefine-killer-commands
(require 'thingatpt nil t) ;; (no error if not found): word-at-point
(require 'thingatpt+ nil t) ;; (no error if not found): 
(require 'highlight nil t) ;; (no error if not found): highlight-regexp-region


;;; User options:

(defvar compile-buffer-mouse-face 'underline
  "*Face for highlighting mouse-overs in compilation buffer.")

(defvar grep-regexp-face
  (or (and (boundp 'skyblue-background-face) skyblue-background-face)
      (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")))
  "*Face for highlighting `grep' regexps.")

(defvar grep-default-regexp-fn
  (if (fboundp 'symbol-name-nearest-point)
  "*Function of 0 args called to provide default search regexp to \\[grep].
Some reasonable choices:
`word-nearest-point', `symbol-name-nearest-point', `sexp-nearest-point'.

If this is nil and no prefix arg is given to `grep', then no
defaulting is done.

If this is not a function, then function
`grep-default-regexp-fn' does the defaulting otherwise.")

(defun grep-default-regexp-fn ()
  "*Function of 0 args called to provide default search regexp to \\[grep].
No defaulting is done if `grep-default-regexp-fn' is nil.
Otherwise, the defaulting function is provided by 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 `symbol-name-nearest-point', if bound
  - function `grep-tag-default'"
  (cond ((fboundp grep-default-regexp-fn) grep-default-regexp-fn)
        ((get major-mode 'find-tag-default-function))
        ((fboundp 'symbol-name-nearest-point) 'symbol-name-nearest-point)
        (t                              ; Use `grep-tag-default' instead of
         'grep-tag-default)))           ; `find-tag-default', to avoid loading 

;;; Other variables (not user options):

(defvar grep-pattern nil "Search pattern used by latest \\[grep] command.")

;; Compile mode is suitable only for specially formatted data.
(put 'compile-mode 'mode-class 'special)

;;; Undefine some bindings that would try to modify a Compilation mode buffer.
;;; Their key sequences will then appear to the user as available for
;;; local (Compilation Mode) definition.
(when (fboundp 'undefine-killer-commands)
  (undefine-killer-commands compilation-mode-map (current-global-map)))

;; REPLACES ORIGINAL in `compile.el':
;; Resets `grep-pattern' from last grep.
(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."
   (if (or compilation-read-command current-prefix-arg)
       (list (read-from-minibuffer "Compile command: "
                                   compile-command nil nil
                                   '(compile-history . 1)))
     (list compile-command)))
  ;; Reset `grep-pattern' from last grep.
  (setq grep-pattern nil)
  (setq compile-command command)
  (save-some-buffers (not compilation-ask-about-save) nil)
  (compile-internal compile-command "No more errors."))

;; REPLACES ORIGINAL in `compile.el':
;; 1. Interactive spec uses `grep-default-regexp-fn'.
;; 2. Saves `grep-pattern' for highlighting.
(defun grep (command-args)
  "Run `grep', with user-specified args, and collect output in a
buffer.  While `grep' runs asynchronously, you can use the
\\[next-error] command (M-x next-error), or 
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, based upon

If a non-nil 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."
   (let ((arg current-prefix-arg)
     (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))
         ;; Replace the thing matching for with that around cursor
         (when (string-match "[^ ]+\\s +\\(-[^ ]+\\s +\\)*\\(\"[^\"]+\"\\|[^ 
           (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 (and grep-default-regexp-fn
                                        (funcall (grep-default-regexp-fn))) " 
            nil nil 'grep-history))))
  ;; Remember `grep-pattern' for highlighting, if highlighting is possible.
  ;; Really, should determine if `-i' grep option was used, and, if so, modify
  ;; `grep-pattern' to make it case insensitive.  This is not done yet.
  (when (fboundp 'set-face-foreground)
    (cond (;; Quoted pattern (either "..." or '...')
             "[ \t]*\\(-[a-zA-Z]+\\s-+\\)*[ \t]*\\('[^']+'\\|\"[^\"]+\"\\)") ;"
           (setq grep-pattern
                 (substring command-args
                            (1+ (match-beginning 2)) (1- (match-end 2)))))
          (;; Unquoted pattern.
            (concat grep-program
                    "[ \t]*\\(-[a-zA-Z]+\\s-+\\)*[ \t]*\\([^ \n\t'\"]+\\)") ; "
           (setq grep-pattern
                 (substring command-args (match-beginning 2) (match-end 2))))
          (t;; Bad pattern.
           (setq grep-pattern nil))))
  ;; Setting process-setup-function makes exit-message-function work
  ;; even when async processes aren't supported.
  (let* ((compilation-process-setup-function 'grep-process-setup)
         (buf (compile-internal (if null-device
                                    (concat command-args " " null-device)
                                "No more grep hits" "grep"
                                ;; Give it a simpler regexp to match.
                                nil grep-regexp-alist)))))

;; REPLACES ORIGINAL in `compile.el':
;; Sets up font-lock mode to treat `grep-pattern'.
(defun compilation-mode-font-lock-keywords ()
  "Return expressions to highlight in Compilation mode."
   ;; Compiler warning/error lines.
   (mapcar (function
            (lambda (item)
              ;; Prepend "^", adjusting FILE-IDX and LINE-IDX accordingly.
              (let ((file-idx (nth 1 item))
                    (line-idx (nth 2 item))
                    (col-idx (nth 3 item))
                (when (numberp col-idx)
                  (setq keyword
                        (cons (list (1+ col-idx) 'font-lock-type-face nil t)
                (when (numberp line-idx)
                  (setq keyword
                        (cons (list (1+ line-idx) 'font-lock-variable-name-face)
                (when (numberp file-idx)
                  (setq keyword
                        (cons (list (1+ file-idx) 'font-lock-warning-face)
                (cons (concat "^\\(" (nth 0 item) "\\)") keyword))))
   ;; Non-nil `grep-pattern'.
   ;; NOTE: No account is taken here of case-insensitivity options to grep
   ;; (e.g. `-i'). This is not generally possible, as different grep's may use
   ;; different options. Here, only the literal `grep-pattern' string is
   ;; highlighted.
   (and grep-pattern
         (list (concat "\\(" (regexp-quote grep-pattern) "\\)")
               1 grep-regexp-face)))
   ;; Compiler output lines.  Recognize `make[n]:' lines too.
    '("^\\([A-Za-z_0-9/\.+-]+\\)\\(\\[\\([0-9]+\\)\\]\\)?[ \t]*:"
      (1 font-lock-function-name-face) (3 font-lock-comment-face nil t)))

;; REPLACES ORIGINAL in `compile.el':
;; 1. Set `font-lock-fontified' to nil.
;; 2. Don't let frame get shrunk here.
(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 `t' means an empty alist.

Returns the compilation buffer created."
  (let (outbuf)
      (unless name-of-mode (setq name-of-mode "Compilation"))
      (setq outbuf
             (funcall (or name-function compilation-buffer-name-function
                          (function (lambda (mode)
                                      (concat "*" (downcase 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? "
              (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."
      ;; In case the compilation buffer is current, make sure we get the global
      ;; values of compilation-error-regexp-alist, etc.
    (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)
        ;; 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.
        (set-buffer outbuf)
        (setq buffer-read-only nil)
        (buffer-disable-undo (current-buffer))
        (buffer-enable-undo (current-buffer))
        (setq default-directory thisdir)
        (insert "cd " thisdir "\n" command "\n")
        (setq font-lock-fontified nil)  ; DDA
        (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.
      (when (eq outbuf (current-buffer)) (goto-char (point-max)))
      ;; Pop up the compilation buffer.
      ;; DDA: Don't let frame get shrunk here. - see `shrink-fit.el'
      (setq outwin (let ((enable-shrink-frame-to-fit nil)) (display-buffer 
        (set-buffer outbuf)
        ;; D. Adams: next line added to fix bug when my redefined version of 
`display-buffer' is
        ;; used.  Without it, the error msgs are inserted above the "cd ..." & 
"grep ..." lines.
        (goto-char (point-max))
        (compilation-mode name-of-mode)
        ;; (setq buffer-read-only t)  ;;; Non-ergonomic.
        (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)
        (set (make-local-variable 'compilation-enter-directory-regexp-alist)
        (set (make-local-variable 'compilation-leave-directory-regexp-alist)
        (set (make-local-variable 'compilation-file-regexp-alist)
        (set (make-local-variable 'compilation-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) ; `lazy...' is a 
free var here.
        ;; This proves a good idea if the buffer's going to scroll
        ;; with lazy-lock on.
        (setq lazy-lock-defer-on-scrolling t)
        (setq default-directory thisdir)
        (setq compilation-directory-stack (list default-directory))
        (set-window-start outwin (point-min))
        (unless (eq outwin (selected-window)) (set-window-point outwin 
        (compilation-set-window-height outwin)
        (when compilation-process-setup-function
          (funcall compilation-process-setup-function))
        ;; Start the compilation.
        (if (fboundp 'start-process)
            (let* ((process-environment (cons "EMACS=t" process-environment))
                   (proc (start-process-shell-command (downcase mode-name)
              (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 
          ;; 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
          (let ((status (call-process shell-file-name nil outbuf nil "-c" 
            (cond ((numberp status)
                   (compilation-handle-exit 'exit status (if (zerop status)
                                                           (format "\
exited abnormally with code %d\n"
                  ((stringp status)
                   (compilation-handle-exit 'signal status (concat status 
                   (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)))))
    ;; Make it so the next C-x ` will use this buffer.
    (setq compilation-last-buffer outbuf)))

;; REPLACES ORIGINAL in `compile.el':
;; Use `fundamental-mode' instead of `kill-all-local-variables'.
(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).

The following bindings are in effect in this mode:

  (use-local-map compilation-mode-map)
  (setq major-mode 'compilation-mode)
  (setq mode-name (or name-of-mode "Compilation"))
  (set (make-local-variable 'font-lock-defaults)
       '(compilation-mode-font-lock-keywords t))
  (set (make-local-variable 'revert-buffer-function)
  (run-hooks 'compilation-mode-hook))

;; REPLACES ORIGINAL in `compile.el':
;; Calls `what-line' at end to display line number.
(defun compilation-next-error (n)
  "Move point to the next error in the compilation buffer.
Does NOT find the source line like \\[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)))
    ;; Move to the error after the one containing point.
    (goto-char (car (if (< n 0)
                        (let ((i 0)
                              (e compilation-old-error-list))
                          ;; See how many cdrs away ERRORS is from the start.
                          (while (not (eq e errors)) (incf i) (pop e))
                          (if (> (- n) i)
                              (error "Moved back past first error.")
                            (nth (+ i n) compilation-old-error-list)))
                      (let ((compilation-error-list (cdr errors)))
                        (compile-reinitialize-errors nil nil n)
                        (if compilation-error-list
                            (nth (1- n) compilation-error-list)
                          (error "Moved past last error.")))))))

;; REPLACES ORIGINAL in `compile.el':
;; 1. Highlights `grep-pattern' at error location.
;; 2. Calls `what-line' at end to display line number.
(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."
  (if (eq (window-buffer (selected-window))
          (marker-buffer (car next-error)))
      ;; If the compilation buffer window is selected,
      ;; keep the compilation buffer in this window;
      ;; display the source in another window.
      (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))
  ;; If narrowing got in the way of going to the right place, then widen.
  (unless (= (point) (marker-position (cdr next-error)))
    (widen) (goto-char (cdr next-error)))
  ;; Show compilation buffer in other window, scrolled to this error.
  (let* ((pop-up-windows t)
         ;; Use an existing window if it is in a visible frame.
         (w (or (get-buffer-window (marker-buffer (car next-error)) 'visible)
                ;; Pop up a window.
                (display-buffer (marker-buffer (car next-error))))))
    (set-window-point w (car next-error))
    (set-window-start w (car next-error))
    ;; Highlight `grep-pattern' in compilation buffer, if possible.
    (when (and (fboundp 'highlight-regexp-region) grep-pattern)
      (highlight-regexp-region (save-excursion (beginning-of-line) (point))
                               (save-excursion (end-of-line) (point))
                               grep-pattern grep-regexp-face))
    (compilation-set-window-height w))

;; REPLACES ORIGINAL in `compile.el':
;; Use `compile-buffer-mouse-face', not `highlight', as `mouse-face'.
(defun compile-reinitialize-errors (reparse &optional limit-search 
  ;; Parse any new errors in the compilation buffer,
  ;; or reparse from the beginning if the user has asked for that.
    (set-buffer compilation-last-buffer)
    ;; If we are out of errors, or if user says "reparse",
    ;; discard the info we have, to force reparsing.
    (when (or (eq compilation-error-list t)
    ;; If `compilation-error-list' is non-nil, it points to a specific
    ;; error the user wanted.  So don't move it around.
    (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)))
      ;; This was here for a long time (before my rewrite); why? --Roland
      ;;(switch-to-buffer compilation-last-buffer)
      (set-buffer-modified-p nil)
      (when (< compilation-parsing-end (point-max))
        ;; `compilation-error-list' might be non-nil if we have a non-nil
        ;; LIMIT-SEARCH or FIND-AT-LEAST arg.  In that case its value
        ;; records the current position in the error list, and we must
        ;; preserve that after reparsing.
        (let ((error-list-pos compilation-error-list))
          (funcall compilation-parse-errors-function
                   (and find-at-least
                        ;; We only need enough new parsed errors to reach
                        ;; FIND-AT-LEAST errors past the current
                        ;; position.
                        (- find-at-least (length compilation-error-list))))
          ;; Remember the entire list for `compilation-forget-errors'.  If
          ;; this is an incremental parse, append to previous list.  If
          ;; we are parsing anew, `compilation-forget-errors' cleared
          ;; compilation-old-error-list above.
          (setq compilation-old-error-list
                (nconc compilation-old-error-list compilation-error-list))
          (when error-list-pos
            ;; We started in the middle of an existing list of parsed
            ;; errors before parsing more; restore that position.
            (setq compilation-error-list error-list-pos))
          ;; Mouse-Highlight (the first line of) each error message when the
          ;; mouse pointer moves over it:
          (let ((inhibit-read-only t)
                (buffer-undo-list t)
                (error-list compilation-error-list))
            (while error-list
              (save-excursion (put-text-property (goto-char (car (car 
                                                 (progn (end-of-line) (point))
              (setq error-list (cdr error-list)))))))))

;; REPLACES ORIGINAL in `compile.el':
;; Use `compile-buffer-mouse-face', not `highlight', as `mouse-face'.
(defun compilation-forget-errors ()
;; Set `compilation-error-list' to nil, and unchain the markers that point to 
;; 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)
  ;; Remove the highlighting added by compile-reinitialize-errors:
  (let ((inhibit-read-only t)
        (buffer-undo-list t)
    (remove-text-properties (point-min) (point-max) (list 'mouse-face 

;;;;; COMINT-FILE-NAME-PREFIX is free here.
;;;(defun compilation-parse-errors (limit-search find-at-least)
;;;  "Parse the current buffer as `grep', `cc' or `lint' error messages.
;;;See var `compilation-parse-errors-function' for its interface."
;;;  (setq compilation-error-list nil)
;;;  (message "Parsing error messages ...")
;;;  (let (text-buffer orig orig-expanded parent-expanded
;;;        regexp enter-group leave-group error-group
;;;        alist subexpr error-regexp-groups
;;;        (found-desired nil)
;;;        (compilation-num-errors-found 0))
;;;    ;; Don't reparse messages already seen at last parse.
;;;    (goto-char compilation-parsing-end)
;;;    ;; Don't parse first two lines as error messages. This matters for grep.
;;;    (when (bobp)
;;;      (forward-line 2)
;;;      ;; Move back so point is before the newline.
;;;      ;; This matters because some error regexps use \n instead of ^, in 
;;;      ;; to be faster.
;;;      (forward-char -1))
;;;    ;; Compile all the regexps we want to search for into one.
;;;    (setq regexp (concat "\\(" compilation-enter-directory-regexp "\\)\\|"
;;;                         "\\(" compilation-leave-directory-regexp "\\)\\|"
;;;                         "\\(" (mapconcat (function
;;;                                           (lambda (elt)
;;;                                             (concat "\\(" (car elt) "\\)")))
;;;                                          compilation-error-regexp-alist
;;;                                          "\\|") "\\)"))
;;;    ;; Find out how many \(...\) groupings are in each of the regexps, and 
;;;    ;; *-GROUP to the grouping containing each constituent regexp (whose
;;;    ;; subgroups will come immediately thereafter) of the big regexp we have
;;;    ;; just constructed.
;;;    (setq enter-group 1)
;;;    (setq leave-group (+ enter-group
;;;                         (count-regexp-groupings
;;;                          compilation-enter-directory-regexp)
;;;                         1))
;;;    (setq error-group (+ leave-group
;;;                         (count-regexp-groupings
;;;                          compilation-leave-directory-regexp)
;;;                         1))
;;;    ;; Compile an alist (IDX FILE LINE [COL]), where IDX is the number of
;;;    ;; the subexpression for an entire error-regexp, and FILE and LINE (and
;;;    ;; possibly COL) are the numbers for the subexpressions giving the file
;;;    ;; name and line number (and possibly column number).
;;;    (setq alist (or compilation-error-regexp-alist
;;;                    (error "compilation-error-regexp-alist is empty.")))
;;;    (setq subexpr (1+ error-group))
;;;    (while alist
;;;      (setq error-regexp-groups
;;;            (cons (list subexpr
;;;                        (+ subexpr (nth 1 (car alist)))
;;;                        (+ subexpr (nth 2 (car alist)))
;;;                        (and (nth 3 (car alist))
;;;                             (+ subexpr (nth 3 (car alist)))))
;;;                  error-regexp-groups))
;;;      (setq subexpr (+ subexpr 1 (count-regexp-groupings (caar alist))))
;;;      (pop alist))
;;;    (setq orig default-directory)
;;;    (setq orig-expanded (file-truename orig))
;;;    (setq parent-expanded (expand-file-name "../" orig-expanded))
;;;    (while (and (not found-desired)
;;;                ;; We don't just pass LIMIT-SEARCH to `re-search-forward'
;;;                ;; because we want to find matches containing LIMIT-SEARCH
;;;                ;; but which extend past it.
;;;                (re-search-forward regexp nil t))
;;;      ;; Figure out which constituent regexp matched.
;;;      (cond ((match-beginning enter-group)
;;;             ;; The match was the enter-directory regexp.
;;;             (let ((dir
;;;                    (file-name-as-directory
;;;                     (expand-file-name
;;;                      (buffer-substring (match-beginning (+ enter-group 1))
;;;                                        (match-end (+ enter-group 1)))))))
;;;               ;; The directory name in the "entering" message
;;;               ;; is a truename.  Try to convert it to a form
;;;               ;; like what the user typed in.
;;;               (setq dir (compile-abbreviate-directory dir orig orig-expanded
;;;                                                       parent-expanded))
;;;               (push dir compilation-directory-stack)
;;;               (when (file-directory-p dir) (setq default-directory dir)))
;;;             (when (and limit-search (>= (point) limit-search))
;;;               ;; The user wanted a specific error, and we're past it.
;;;               ;; We do this check here (and in the leave-group case)
;;;               ;; rather than at the end of the loop because if the last
;;;               ;; thing seen is an error message, we must carefully
;;;               ;; discard the last error when it is the first in a new
;;;               ;; file (see below in the error-group case).
;;;               (setq found-desired t)))
;;;            ((match-beginning leave-group)
;;;             ;; The match was the leave-directory regexp.
;;;             (let ((beg (match-beginning (+ leave-group 1)))
;;;                   (stack compilation-directory-stack))
;;;               (when beg
;;;                 (let ((dir (file-name-as-directory
;;;                             (expand-file-name
;;;                              (buffer-substring beg (match-end (+ leave-group
;;;                                                                  1)))))))
;;;                   ;; The directory name in the "entering" message is a
;;;                   ;; truename.  Try to convert it to a form like what the
;;;                   ;; user typed in.
;;;                   (setq dir (compile-abbreviate-directory
;;;                              dir orig orig-expanded parent-expanded))
;;;                   (while (and stack (not (string-equal (car stack) dir)))
;;;                     (pop stack))))
;;;               (setq compilation-directory-stack (cdr stack))
;;;               (setq stack (car compilation-directory-stack))
;;;               (when stack (setq default-directory stack)))
;;;             (when (and limit-search (>= (point) limit-search))
;;;               ;; The user wanted a specific error, and we're past it.
;;;               ;; We do this check here (and in the enter-group case)
;;;               ;; rather than at the end of the loop because if the last
;;;               ;; thing seen is an error message, we must carefully
;;;               ;; discard the last error when it is the first in a new
;;;               ;; file (see below in the error-group case).
;;;               (setq found-desired t)))
;;;            ((match-beginning error-group)
;;;             ;; The match was the composite error regexp.
;;;             ;; Find out which individual regexp matched.
;;;             (setq alist error-regexp-groups)
;;;             (while (and alist (null (match-beginning (caar alist))))
;;;               (pop alist))
;;;             (if alist
;;;                 (setq alist (car alist))
;;;               (error "COMPILATION-PARSE-ERRORS: Impossible regexp match."))
;;;             ;; Extract the file name and line number from the error message.
;;;             (let ((beginning-of-match (match-beginning 0)) ;looking-at nukes
;;;                   (filename (buffer-substring (match-beginning (nth 1 
;;;                                               (match-end (nth 1 alist))))
;;;                   (linenum (string-to-int
;;;                             (buffer-substring
;;;                              (match-beginning (nth 2 alist))
;;;                              (match-end (nth 2 alist)))))
;;;                   (column (and (nth 3 alist)
;;;                                (string-to-int
;;;                                 (buffer-substring
;;;                                  (match-beginning (nth 3 alist))
;;;                                  (match-end (nth 3 alist)))))))
;;;               ;; Check for a COMINT-FILE-NAME-PREFIX and prepend it if
;;;               ;; appropriate.  (This is useful for `compilation-minor-mode'
;;;               ;; in an `rlogin-mode' buffer.)
;;;               (when (and (boundp 'comint-file-name-prefix)
;;;                          ;; If file name is relative, default-directory will
;;;                          ;; already contain COMINT-FILE-NAME-PREFIX (done by
;;;                          ;; compile-abbreviate-directory).
;;;                          (file-name-absolute-p filename))
;;;                 (setq filename (concat comint-file-name-prefix filename)))
;;;               (push default-directory filename)
;;;               ;; Locate the erring file and line.
;;;               ;; Cons a new elt onto `compilation-error-list',
;;;               ;; giving a marker for the current compilation buffer
;;;               ;; location, and the file and line number of the error.
;;;               (save-excursion
;;;                 (beginning-of-line 1)
;;;                 (let ((this (cons (point-marker)
;;;                                   (list filename linenum column))))
;;;                   ;; Don't add the same source line more than once.
;;;                   (unless (equal (cdr this) (cdar compilation-error-list))
;;;                     (push this compilation-error-list)
;;;                     (incf compilation-num-errors-found))))
;;;               (when (and (or (and find-at-least
;;;                                   (> compilation-num-errors-found
;;;                                      find-at-least))
;;;                        ;;; D. ADAMS: Second part of next test was:
;;;                        ;;; (>= (point) limit-search).
;;;                        ;;; Was thus bugged: Last error was removed from 
;;;                              (and limit-search
;;;                                   (>= (save-excursion (end-of-line -1)
;;;                                                       (point))
;;;                                       limit-search)))
;;;                          ;; We have found as many new errors as user
;;;                          ;; wants, or past the buffer position he
;;;                          ;; indicated.  We continue to parse until we
;;;                          ;; have seen all the consecutive errors in
;;;                          ;; the same file, so the error positions
;;;                          ;; will be recorded as markers in this
;;;                          ;; buffer that might change.
;;;                          (cdr compilation-error-list) ; Must check at least 
;;;                          (not (equal (cadr (nth 0 compilation-error-list))
;;;                                      (cadr (nth 1 
;;;                 ;; Discard the error just parsed, so that the next
;;;                 ;; parsing run can get it and the following errors in
;;;                 ;; the same file all at once.  If we didn't do this, we
;;;                 ;; would have the same problem we are trying to avoid
;;;                 ;; with the test above, just delayed until the next run!
;;;                 (pop compilation-error-list)
;;;                 (goto-char beginning-of-match)
;;;                 (setq found-desired t))))
;;;            (t (error "COMPILATION-PARSE-ERRORS: Known groups didn't 
;;;      (message "Parsing error messages ... %d (%.0f%% of buffer)"
;;;               compilation-num-errors-found
;;;               ;; Use floating-point because (* 100 (point)) frequently
;;;               ;; exceeds the range of Emacs Lisp integers.
;;;               (/ (* 100.0 (point)) (point-max)))
;;;      (when (and limit-search (>= (point) limit-search))
;;;        ;; User wanted a specific error, and we're past it.
;;;        (setq found-desired t)))
;;;    (setq compilation-parsing-end (if found-desired
;;;                                      (point)
;;;                                    ;; We have searched the whole buffer.
;;;                                    (point-max))))
;;;  (setq compilation-error-list (nreverse compilation-error-list))
;;;  (message "Parsing error messages ... done."))


(provide 'compile+)

;;; `compile+.el' ends here

reply via email to

[Prev in Thread] Current Thread [Next in Thread]