From 3062f81dbf6d815110ad17d5cd19469767e53e5c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 3 Apr 2019 10:58:36 -0400 Subject: [PATCH] * lisp/progmodes/compile.el: Allow 'line' functions in error-regexp-alist (compilation-error-properties): Allow 'line' and 'end-line' to be functions, like 'col' and 'end-col'. (compilation-error-regexp-alist): Document this. (compilation-parse-errors): Drop support for old undocumented feature where 'line' was a function of 2 arguments. (compilation--compat-error-properties): Delete function. --- etc/NEWS | 7 ++ lisp/progmodes/compile.el | 215 ++++++++++++++++---------------------- 2 files changed, 96 insertions(+), 126 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 2bf2b4972a5..26c761ae01f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -385,6 +385,10 @@ current and the previous or the next line, as before. * Changes in Specialized Modes and Packages in Emacs 27.1 +** compile.el +--- +*** In compilation-error-regexp-alist, 'line' (and 'end-line') can be functions + ** cl-lib +++ *** cl-defstruct has a new :noinline argument to prevent inlining its functions @@ -1272,6 +1276,9 @@ documentation of the new mode and its commands. * Incompatible Lisp Changes in Emacs 27.1 +** In compilation-error-regexp-alist the old undocumented feature where 'line' +could be a function of 2 arguments has been dropped. + ** 'define-fringe-bitmap' is always defined, even when Emacs is built without any GUI support. diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 3650b05607c..4018cf7022f 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -558,7 +558,11 @@ of lines. COLUMN can also be of the form (COLUMN . END-COLUMN) meaning a range of columns starting on LINE and ending on END-LINE, if that matched. -TYPE is 2 or nil for a real error or 1 for warning or 0 for info. +LINE, END-LINE, COL, and END-COL can also be functions of no argument +that return the corresponding line or column number. They can assume REGEXP +has just been matched, and should correspondingly preserve this match data. + +f/usr/shaTYPE is 2 or nil for a real error or 1 for warning or 0 for info. TYPE can also be of the form (WARNING . INFO). In that case this will be equivalent to 1 if the WARNING'th subexpression matched or else equivalent to 0 if the INFO'th subexpression matched. @@ -1105,23 +1109,27 @@ POS and RES.") (setq file '("*unknown*"))))) ;; All of these fields are optional, get them only if we have an index, and ;; it matched some part of the message. - (and line - (setq line (match-string-no-properties line)) - (setq line (string-to-number line))) - (and end-line - (setq end-line (match-string-no-properties end-line)) - (setq end-line (string-to-number end-line))) - (if col - (if (functionp col) - (setq col (funcall col)) - (and - (setq col (match-string-no-properties col)) - (setq col (string-to-number col))))) - (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) -1)) - (if end-line (setq end-col -1)))) + (setq line + (if (functionp line) (funcall line) + (and line + (setq line (match-string-no-properties line)) + (string-to-number line)))) + (setq end-line + (if (functionp end-line) (funcall end-line) + (and end-line + (setq end-line (match-string-no-properties end-line)) + (string-to-number end-line)))) + (setq col + (if (functionp col) (funcall col) + (and col + (setq col (match-string-no-properties col)) + (string-to-number col)))) + (setq end-col + (or (if (functionp end-col) (funcall end-col) + (and end-col + (setq end-col (match-string-no-properties end-col)) + (- (string-to-number end-col) -1))) + (and end-line -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) @@ -1222,12 +1230,12 @@ FMTS is a list of format specs for transforming the file name. (setq loc (compilation-assq line (compilation--file-struct->loc-tree file-struct))) (setq end-loc - (if end-line + (if end-line (compilation-assq end-col (compilation-assq end-line (compilation--file-struct->loc-tree file-struct))) - (if end-col ; use same line element + (if end-col ; use same line element (compilation-assq end-col loc)))) (setq loc (compilation-assq col loc)) ;; If they are new, make the loc(s) reference the file they point to. @@ -1370,92 +1378,70 @@ to `compilation-error-regexp-alist' if RULES is nil." (if (consp line) (setq end-line (cdr line) line (car line))) (if (consp col) (setq end-col (cdr col) col (car col))) - (if (functionp line) - ;; The old compile.el had here an undocumented hook that - ;; allowed `line' to be a function that computed the actual - ;; error location. Let's do our best. - (progn - (goto-char start) - (while (re-search-forward pat end t) - (save-match-data - (when compilation-debug - (font-lock-append-text-property - (match-beginning 0) (match-end 0) - 'compilation-debug (vector 'functionp item))) - (add-text-properties - (match-beginning 0) (match-end 0) - (compilation--compat-error-properties - (funcall line (cons (match-string file) - (cons default-directory - (nthcdr 4 item))) - (if col (match-string col)))))) - (compilation--put-prop - file 'font-lock-face compilation-error-face))) + (unless (or (null (nth 5 item)) (integerp (nth 5 item))) + (error "HYPERLINK should be an integer: %s" (nth 5 item))) - (unless (or (null (nth 5 item)) (integerp (nth 5 item))) - (error "HYPERLINK should be an integer: %s" (nth 5 item))) + (goto-char start) + (while (re-search-forward pat end t) + (when (setq props (compilation-error-properties + file line end-line col end-col (or type 2) fmt)) - (goto-char start) - (while (re-search-forward pat end t) - (when (setq props (compilation-error-properties - file line end-line col end-col (or type 2) fmt)) - - (when (integerp file) - (let ((this-type (if (consp type) - (compilation-type type) - (or type 2)))) - (compilation--note-type this-type) - - (compilation--put-prop - file 'font-lock-face - (symbol-value (aref [compilation-info-face - compilation-warning-face - compilation-error-face] - this-type))))) - - (compilation--put-prop - line 'font-lock-face compilation-line-face) - (compilation--put-prop - end-line 'font-lock-face compilation-line-face) - - (compilation--put-prop - col 'font-lock-face compilation-column-face) - (compilation--put-prop - end-col 'font-lock-face compilation-column-face) - - ;; Obey HIGHLIGHT. - (dolist (extra-item (nthcdr 6 item)) - (let ((mn (pop extra-item))) - (when (match-beginning mn) - (let ((face (eval (car extra-item)))) - (cond - ((null face)) - ((or (symbolp face) (stringp face)) - (put-text-property - (match-beginning mn) (match-end mn) - 'font-lock-face face)) - ((and (listp face) - (eq (car face) 'face) - (or (symbolp (cadr face)) - (stringp (cadr face)))) - (compilation--put-prop mn 'font-lock-face (cadr face)) - (add-text-properties - (match-beginning mn) (match-end mn) - (nthcdr 2 face))) - (t - (error "Don't know how to handle face %S" - face))))))) - (let ((mn (or (nth 5 item) 0))) - (when compilation-debug - (font-lock-append-text-property - (match-beginning 0) (match-end 0) - 'compilation-debug (vector 'std item props))) - (add-text-properties - (match-beginning mn) (match-end mn) - (cddr props)) + (when (integerp file) + (let ((this-type (if (consp type) + (compilation-type type) + (or type 2)))) + (compilation--note-type this-type) + + (compilation--put-prop + file 'font-lock-face + (symbol-value (aref [compilation-info-face + compilation-warning-face + compilation-error-face] + this-type))))) + + (compilation--put-prop + line 'font-lock-face compilation-line-face) + (compilation--put-prop + end-line 'font-lock-face compilation-line-face) + + (compilation--put-prop + col 'font-lock-face compilation-column-face) + (compilation--put-prop + end-col 'font-lock-face compilation-column-face) + + ;; Obey HIGHLIGHT. + (dolist (extra-item (nthcdr 6 item)) + (let ((mn (pop extra-item))) + (when (match-beginning mn) + (let ((face (eval (car extra-item)))) + (cond + ((null face)) + ((or (symbolp face) (stringp face)) + (put-text-property + (match-beginning mn) (match-end mn) + 'font-lock-face face)) + ((and (listp face) + (eq (car face) 'face) + (or (symbolp (cadr face)) + (stringp (cadr face)))) + (compilation--put-prop mn 'font-lock-face (cadr face)) + (add-text-properties + (match-beginning mn) (match-end mn) + (nthcdr 2 face))) + (t + (error "Don't know how to handle face %S" + face))))))) + (let ((mn (or (nth 5 item) 0))) + (when compilation-debug (font-lock-append-text-property - (match-beginning mn) (match-end mn) - 'font-lock-face (cadr props))))))))) + (match-beginning 0) (match-end 0) + 'compilation-debug (vector 'std item props))) + (add-text-properties + (match-beginning mn) (match-end mn) + (cddr props)) + (font-lock-append-text-property + (match-beginning mn) (match-end mn) + 'font-lock-face (cadr props)))))))) (defvar compilation--parsed -1) (make-variable-buffer-local 'compilation--parsed) @@ -2837,29 +2823,6 @@ TRUE-DIRNAME is the `file-truename' of DIRNAME, if given." (defvar compilation-error-list nil) (defvar compilation-old-error-list nil) -(defun compilation--compat-error-properties (err) - "Map old-style error ERR to new-style message." - ;; Old-style structure is (MARKER (FILE DIR) LINE COL) or - ;; (MARKER . MARKER). - (let ((dst (cdr err))) - (if (markerp dst) - `(compilation-message ,(compilation--make-message - (cons nil (compilation--make-cdrloc - nil nil dst)) - 2 nil) - help-echo "mouse-2: visit the source location" - keymap compilation-button-map - mouse-face highlight) - ;; Too difficult to do it by hand: dispatch to the normal code. - (let* ((file (pop dst)) - (line (pop dst)) - (col (pop dst)) - (filename (pop file)) - (dirname (pop file)) - (fmt (pop file))) - (compilation-internal-error-properties - (cons filename dirname) line nil col nil 2 fmt))))) - (defun compilation--compat-parse-errors (limit) (when compilation-parse-errors-function ;; FIXME: We should remove the rest of the compilation keywords -- 2.39.2