-;; Set compilation-error-list to nil, and unchain the 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.
-(defun compilation-forget-errors ()
- (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))
- (if compilation-parsing-end
- (set-marker compilation-parsing-end 1))
- ;; Remove the highlighting added by compile-reinitialize-errors:
- (let ((inhibit-read-only t)
- (buffer-undo-list t)
- deactivate-mark)
- (remove-text-properties (point-min) (point-max)
- '(mouse-face highlight help-echo nil))))
-
-
-;; This function is not needed any more by compilation mode.
-;; Does anyone else need it or can it be deleted?
-(defun count-regexp-groupings (regexp)
- "Return the number of \\( ... \\) groupings in REGEXP (a string)."
- (let ((groupings 0)
- (len (length regexp))
- (i 0)
- c)
- (while (< i len)
- (setq c (aref regexp i)
- i (1+ i))
- (cond ((= c ?\[)
- ;; Find the end of this [...].
- (while (and (< i len)
- (not (= (aref regexp i) ?\])))
- (setq i (1+ i))))
- ((= c ?\\)
- (if (< i len)
- (progn
- (setq c (aref regexp i)
- i (1+ i))
- (if (= c ?\))
- ;; We found the end of a grouping,
- ;; so bump our counter.
- (setq groupings (1+ groupings))))))))
- groupings))
-
-(defvar compilation-current-file nil
- "Used by `compilation-parse-errors' to store filename for file being compiled.")
-
-;; This variable is not used as a global variable. It's defined here just to
-;; shut up the byte compiler. It's bound and used by compilation-parse-errors
-;; and set by compile-collect-regexps.
-(defvar compilation-regexps nil)
-
-(defun compilation-parse-errors (limit-search find-at-least)
- "Parse the current buffer as grep, cc, lint or other error messages.
-See variable `compilation-parse-errors-function' for the interface it uses."
- (setq compilation-error-list nil)
- (message "Parsing error messages...")
- (if (null compilation-error-regexp-alist)
- (error "compilation-error-regexp-alist is empty!"))
- (let* ((compilation-regexps nil) ; Variable set by compile-collect-regexps.
- (default-directory (car compilation-directory-stack))
- (found-desired nil)
- (compilation-num-errors-found 0)
- ;; Set up now the expanded, abbreviated directory variables
- ;; that compile-abbreviate-directory will need, so we can
- ;; compute them just once here.
- (orig (abbreviate-file-name default-directory))
- (orig-expanded (abbreviate-file-name
- (file-truename default-directory)))
- (parent-expanded (abbreviate-file-name
- (expand-file-name "../" orig-expanded))))
-
- ;; Make a list of all the regexps. Each element has the form
- ;; (REGEXP TYPE IDX1 IDX2 ...)
- ;; where TYPE is one of leave, enter, file, error or nomessage.
- (compile-collect-regexps 'leave compilation-leave-directory-regexp-alist)
- (compile-collect-regexps 'enter compilation-enter-directory-regexp-alist)
- (compile-collect-regexps 'file compilation-file-regexp-alist)
- (compile-collect-regexps 'error compilation-error-regexp-alist)
- (compile-collect-regexps 'nomessage compilation-nomessage-regexp-alist)
-
- ;; Don't reparse messages already seen at last parse.
- (goto-char compilation-parsing-end)
- (when (and (bobp)
- (compilation-buffer-p (current-buffer)))
- (setq compilation-current-file nil) ; No current file at start.
- ;; Don't parse the first two lines as error messages.
- ;; This matters for grep.
- (forward-line 2))
-
- ;; Parse messages.
- (while (not (or found-desired (eobp)
- ;; Don't parse the "compilation finished" message
- ;; as a compilation error.
- (get-text-property (point) 'compilation-handle-exit)))
- (let ((this compilation-regexps) (prev nil) (alist nil) type)
- ;; Go through the regular expressions. If a match is found,
- ;; variable alist is set to the corresponding alist and the
- ;; matching regexp is moved to the front of compilation-regexps
- ;; to make it match faster next time.
- (while (and this (null alist))
- (if (not (looking-at (car (car this))))
- (progn (setq prev this) ; No match, go to next.
- (setq this (cdr this)))
- (setq alist (cdr (car this))) ; Got a match.
-;;; (if prev ; If not the first regexp,
-;;; (progn ; move it to the front.
-;;; (setcdr prev (cdr this))
-;;; (setcdr this compilation-regexps)
-;;; (setq compilation-regexps this)))
- ))
- (if (and alist ; Seen a match and not to
- (not (eq (setq type (car alist)) 'nomessage))) ; be ignored.
- (let* ((end-of-match (match-end 0))
- (filename
- (compile-buffer-substring (car (setq alist (cdr alist)))))
- stack)
- (if (eq type 'error) ; error message
- (let* ((linenum (if (numberp (car (setq alist (cdr alist))))
- (string-to-int
- (compile-buffer-substring (car alist)))
- ;; (car alist) is not a number, must be a
- ;; function that is called below to return
- ;; an error position descriptor.
- (car alist)))
- ;; Convert to integer later if linenum not a function.
- (column (compile-buffer-substring
- (car (setq alist (cdr alist)))))
- this-error)
-
- ;; Check that we have a file name.
- (or filename
- ;; No file name in message, we must have seen it before
- (setq filename compilation-current-file)
- (error "\
-An error message with no file name and no file name has been seen earlier"))
-
- ;; Clean up the file name string in several ways.
- (setq filename (compilation-normalize-filename filename))
-
- (setq filename
- (cons filename (cons default-directory (cdr alist))))
-
- ;; Locate the erring file and line.
- ;; Make this-error a new elt for compilation-error-list,
- ;; giving a marker for the current compilation buffer
- ;; location, and the file and line number of the error.
- ;; Save, as the start of the error, the beginning of the
- ;; line containing the match.
- (setq this-error
- (if (numberp linenum)
- (list (point-marker) filename linenum
- (and column (string-to-int column)))
- ;; If linenum is not a number then it must be
- ;; a function returning an error position
- ;; descriptor or nil (meaning no position).
- (save-excursion
- (funcall linenum filename column))))
-
- ;; We have an error position descriptor.
- ;; If we have found as many new errors as the user
- ;; wants, or if we are past the buffer position he
- ;; indicated, then we continue to parse until we have
- ;; seen all consecutive errors in the same file. This
- ;; means that all the errors of a source file will be
- ;; seen in one parsing run, so that the error positions
- ;; will be recorded as markers in the source file
- ;; buffer that will move when the buffer is changed.
- (if (and this-error
- compilation-error-list ; At least one previous.
- (or (and find-at-least
- (>= compilation-num-errors-found
- find-at-least))
- (and limit-search
- (>= end-of-match limit-search)))
- ;; `this-error' could contain a pair of
- ;; markers already.
- (let ((thispos (cdr this-error))
- (lastpos (cdar compilation-error-list)))
- (not (equal
- (if (markerp thispos)
- (marker-buffer thispos)
- (car thispos))
- (if (markerp lastpos)
- (marker-buffer lastpos)
- (car lastpos))))))
- ;; We are past the limits and the last error
- ;; parsed, didn't belong to the same source file
- ;; as the earlier ones i.e. we have seen all the
- ;; errors belonging to the earlier file. We don't
- ;; add the error just parsed so that the next
- ;; parsing run can get it and the following errors
- ;; in the same file all at once.
- (setq found-desired t)
-
- (goto-char end-of-match) ; Prepare for next message.
- ;; Don't add the same source line more than once.
- (and this-error
- (not (and
- compilation-error-list
- (equal (cdr (car compilation-error-list))
- (cdr this-error))))
- (setq compilation-error-list
- (cons this-error compilation-error-list)
- compilation-num-errors-found
- (1+ compilation-num-errors-found)))))
-
- ;; Not an error message.
- (if (eq type `file) ; Change current file.
- (when filename
- (setq compilation-current-file
- ;; Clean up the file name string in several ways.
- (compilation-normalize-filename filename)))
- ;; Enter or leave directory.
- (setq stack compilation-directory-stack)
- ;; Don't check if it is really a directory.
- ;; Let the code to search and clean up file names
- ;; try to use it in any case.
- (when filename
- ;; Clean up the directory name string in several ways.
- (setq filename (compilation-normalize-filename filename))
- (setq filename
- ;; The directory name in the message
- ;; is a truename. Try to convert it to a form
- ;; like what the user typed in.
- (compile-abbreviate-directory
- (file-name-as-directory
- (expand-file-name filename))
- orig orig-expanded parent-expanded))
- (if (eq type 'leave)
- ;; If we are leaving a specific directory,
- ;; as preparation, pop out of all other directories
- ;; that we entered nested within it.
- (while (and stack
- (not (string-equal (car stack)
- filename)))
- (setq stack (cdr stack)))
- (setq compilation-directory-stack
- (cons filename compilation-directory-stack)
- default-directory filename)))
- (and (eq type 'leave)
- stack
- (setq compilation-directory-stack (cdr stack))
- (setq stack (car compilation-directory-stack))
- (setq default-directory stack)))
- (goto-char end-of-match) ; Prepare to look at next message.
- (and limit-search (>= end-of-match limit-search)
- ;; The user wanted a specific error, and we're past it.
- ;; We do this check here 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 above in
- ;; the error-message case)
- (setq found-desired t)))
-
- ;; Go to before the last character in the message so that we will
- ;; see the next line also when the message ended at end of line.
- ;; When we ignore the last error message above, this will
- ;; cancel the effect of forward-line below so that point
- ;; doesn't move.
- (forward-char -1)
-
- ;; Is this message necessary any more? Parsing is now so fast
- ;; that you might not need to know how it proceeds.
- (message
- "Parsing error messages...%d found. %.0f%% of buffer seen."
- compilation-num-errors-found
- ;; Use floating-point because (* 100 (point)) frequently
- ;; exceeds the range of Emacs Lisp integers.
- (/ (* 100.0 (point)) (point-max)))
- )))
-
- (forward-line 1)) ; End of while loop. Look at next line.
-
- (set-marker compilation-parsing-end (point))
- (setq compilation-error-list (nreverse compilation-error-list))
- ;; (message "Parsing error messages...done. %d found. %.0f%% of buffer seen."
- ;; compilation-num-errors-found
- ;; (/ (* 100.0 (point)) (point-max)))
- (message "Parsing error messages...done.")))
-
-(defun compile-collect-regexps (type this)
- ;; Add elements to variable compilation-regexps that is bound in
- ;; compilation-parse-errors.
- (and (not (eq this t))
- (dolist (el this)
- (push (cons (car el) (cons type (cdr el))) compilation-regexps))))
-
-(defun compile-buffer-substring (index)
- "Get substring matched by INDEXth subexpression."
- (if index
- (let ((beg (match-beginning index)))
- (if beg (buffer-substring beg (match-end index))))))