1 ;; ada-gnat-compile.el --- Ada mode compiling functionality provided by 'gnat' -*- lexical-binding:t -*-
2 ;; Includes related functions, such as gnatprep support.
4 ;; These tools are all Ada-specific; use Makefiles for multi-language
5 ;; GNAT compilation tools.
7 ;; GNAT is provided by AdaCore; see http://libre.adacore.com/
9 ;;; Copyright (C) 2012 - 2015 Free Software Foundation, Inc.
11 ;; Author: Stephen Leake <stephen_leake@member.fsf.org>
12 ;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
14 ;; This file is part of GNU Emacs.
16 ;; GNU Emacs is free software: you can redistribute it and/or modify
17 ;; it under the terms of the GNU General Public License as published by
18 ;; the Free Software Foundation, either version 3 of the License, or
19 ;; (at your option) any later version.
21 ;; GNU Emacs is distributed in the hope that it will be useful,
22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 ;; GNU General Public License for more details.
26 ;; You should have received a copy of the GNU General Public License
27 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
31 ;; Emacs should enter Ada mode automatically when you load an Ada
32 ;; file, based on the file extension.
34 ;; By default, ada-mode is configured to load this file, so nothing
35 ;; special needs to done to use it.
42 ;;;; compiler message handling
44 (defun ada-gnat-compilation-filter ()
45 "Filter to add text properties to secondary file references.
46 For `compilation-filter-hook'."
48 (goto-char compilation-filter-start)
50 ;; primary references are handled by font-lock functions; see
51 ;; `compilation-mode-font-lock-keywords'.
53 ;; compilation-filter might insert partial lines, or it might insert multiple lines
54 (goto-char (line-beginning-position))
56 ;; We don't want 'next-error' to always go to secondary
57 ;; references, so we _don't_ set 'compilation-message text
58 ;; property. Instead, we set 'ada-secondary-error, so
59 ;; `ada-goto-secondary-error' will handle it. We also set
60 ;; fonts, so the user can see the reference.
62 ;; typical secondary references look like:
64 ;; trivial_productions_test.adb:57:77: ==> in call to "Get" at \
65 ;; opentoken-token-enumerated-analyzer.ads:88, instance at line 41
67 ;; c:/foo/bar/lookahead_test.adb:379:14: found type access to "Standard.String" defined at line 379
69 ;; lookahead_test.ads:23:09: "Name" has been inherited from subprogram at aunit-simple_test_cases.ads:47
71 ;; lalr.adb:668:37: non-visible declaration at analyzer.ads:60, instance at parser.ads:38
73 ;; save the file from the primary reference, look for "*.ad?:nn", "at line nnn"
76 (when (looking-at "^\\(\\(.:\\)?[^ :\n]+\\):")
77 (setq file (match-string-no-properties 1)))
79 (skip-syntax-forward "^-"); space following primary reference
81 (while (search-forward-regexp "\\s-\\(\\([^[:blank:]]+\\.[[:alpha:]]+\\):\\([0-9]+\\)\\)"
82 (line-end-position) t)
84 (goto-char (match-end 0))
85 (with-silent-modifications
86 (compilation--put-prop 2 'font-lock-face compilation-info-face); file
87 (compilation--put-prop 3 'font-lock-face compilation-line-face); line
89 (match-beginning 0) (match-end 0)
92 (match-string-no-properties 2); file
93 (string-to-number (match-string-no-properties 3)); line
97 (when (search-forward-regexp "\\(at line \\)\\([0-9]+\\)" (line-end-position) t)
98 (with-silent-modifications
99 (compilation--put-prop 1 'font-lock-face compilation-info-face); "at line" instead of file
100 (compilation--put-prop 2 'font-lock-face compilation-line-face); line
102 (match-beginning 1) (match-end 1)
106 (string-to-number (match-string-no-properties 2)); line
113 (defun ada-gnat-debug-filter ()
114 ;; call ada-gnat-compilation-filter with `compilation-filter-start' bound
117 (let ((compilation-filter-start (point)))
118 (ada-gnat-compilation-filter)))
120 ;;;;; auto fix compilation errors
122 (defconst ada-gnat-quoted-name-regexp
123 "\"\\([a-zA-Z0-9_.']+\\)\""
124 "regexp to extract the quoted names in error messages")
126 (defconst ada-gnat-quoted-punctuation-regexp
127 "\"\\([,:;=()|]+\\)\""
128 "regexp to extract quoted punctuation in error messages")
130 (defvar ada-gnat-fix-error-hook nil
131 "For `ada-fix-error-alist'.")
133 (defun ada-gnat-misspelling ()
134 "Return correct spelling from current compiler error, if there are corrections offered.
135 Prompt user if more than one."
136 ;; wisi-output.adb:115:41: no selector "Productions" for type "RHS_Type" defined at wisi.ads:77
137 ;; wisi-output.adb:115:41: invalid expression in loop iterator
138 ;; wisi-output.adb:115:42: possible misspelling of "Production"
139 ;; wisi-output.adb:115:42: possible misspelling of "Production"
141 ;; column number can vary, so only check the line number
143 (let ((line (progn (beginning-of-line) (nth 1 (compilation--message->loc (ada-get-compilation-message)))))
147 (setq done (or (not (ada-get-compilation-message))
148 (not (equal line (nth 1 (compilation--message->loc (ada-get-compilation-message)))))))
149 (when (and (not done)
151 (skip-syntax-forward "^-")
153 (looking-at (concat "possible misspelling of " ada-gnat-quoted-name-regexp))))
154 (push (match-string 1) choices)))
156 ;; return correct spelling
158 ((= 0 (length choices))
161 ((= 1 (length choices))
164 (t ;; multiple choices
165 (completing-read "correct spelling: " choices))
168 (defun ada-gnat-fix-error (_msg source-buffer _source-window)
169 "For `ada-gnat-fix-error-hook'."
170 (let ((start-pos (point))
173 ;; Move to start of error message text
174 (skip-syntax-forward "^-")
176 (setq message-column (current-column))
178 ;; recognize it, handle it
183 ;; It is tempting to define an alist of (MATCH . ACTION), but
184 ;; that is too hard to debug
186 ;; This list will get long, so let's impose some order.
188 ;; First expressions that start with a named regexp, alphabetical by variable name.
190 ;; Then expressions that start with a string, alphabetical by string.
192 ;; Then style errors.
194 ((looking-at (concat ada-gnat-quoted-name-regexp " is not visible"))
196 (file-line-struct (progn (beginning-of-line) (ada-get-compilation-message)))
197 pos choices unit-name)
198 ;; next line may contain a reference to where ident is
199 ;; defined; if present, it will have been marked by
200 ;; ada-gnat-compilation-filter:
202 ;; gnatquery.adb:255:13: "Has_Element" is not visible
203 ;; gnatquery.adb:255:13: non-visible declaration at a-convec.ads:68, instance at gnatcoll-arg_lists.ads:157
204 ;; gnatquery.adb:255:13: non-visible declaration at a-coorse.ads:62, instance at gnatcoll-xref.ads:912
205 ;; gnatquery.adb:255:13: non-visible declaration at a-coorse.ads:62, instance at gnatcoll-xref.ads:799
206 ;; gnatquery.adb:255:13: non-visible declaration at gnatcoll-xref.ads:314
208 ;; or the next line may contain "multiple use clauses cause hiding"
210 ;; the lines after that may contain alternate matches;
211 ;; collect all, let user choose.
213 (unless (looking-at ".* multiple use clauses cause hiding")
215 (let ((limit (1- (line-end-position))))
216 ;; 1- because next compilation error is at next line beginning
219 (equal file-line-struct (ada-get-compilation-message))
220 (setq pos (next-single-property-change (point) 'ada-secondary-error nil limit))
223 (let* ((item (get-text-property pos 'ada-secondary-error))
224 (unit-file (nth 0 item))
225 (choice (ada-ada-name-from-file-name unit-file)))
226 (unless (member choice choices) (push choice choices))
228 (goto-char (1+ (next-single-property-change (point) 'ada-secondary-error nil limit)))
229 (when (eolp) (forward-line 1))
231 )));; unless while let
235 ((= 0 (length choices)) nil)
236 ((= 1 (length choices)) (car choices))
237 (t ;; multiple choices
238 (completing-read "package name: " choices))))
241 (pop-to-buffer source-buffer)
242 ;; We either need to add a with_clause for a package, or
243 ;; prepend the package name here (or add a use clause, but I
244 ;; don't want to do that automatically).
246 ;; If we need to add a with_clause, unit-name may be only
247 ;; the prefix of the real package name, but in that case
248 ;; we'll be back after the next compile; no way to get the
249 ;; full package name (without the function/type name) now.
250 ;; Note that we can't use gnat find, because the code
253 ((looking-at (concat unit-name "\\."))
254 (ada-fix-add-with-clause unit-name))
256 (ada-fix-insert-unit-name unit-name)
258 t) ;; success, else nil => fail
261 ((or (looking-at (concat ada-gnat-quoted-name-regexp " is undefined"))
262 (looking-at (concat ada-gnat-quoted-name-regexp " is not a predefined library unit")))
263 ;; We either need to add a with_clause for a package, or
264 ;; something is spelled wrong.
266 (let ((unit-name (match-string 1))
267 (correct-spelling (ada-gnat-misspelling)))
270 (pop-to-buffer source-buffer)
271 (search-forward unit-name)
272 (replace-match correct-spelling))
274 ;; else assume missing with
275 (pop-to-buffer source-buffer)
276 (ada-fix-add-with-clause unit-name))))
279 ((looking-at (concat ada-gnat-quoted-name-regexp " not declared in " ada-gnat-quoted-name-regexp))
281 (let ((child-name (match-string 1))
282 (correct-spelling (ada-gnat-misspelling)))
285 (setq correct-spelling (match-string 1))
286 (pop-to-buffer source-buffer)
287 (search-forward child-name)
288 (replace-match correct-spelling))
290 ;; else guess that "child" is a child package, and extend the with_clause
291 (pop-to-buffer source-buffer)
292 (ada-fix-extend-with-clause child-name))))
295 ((looking-at (concat ada-gnat-quoted-punctuation-regexp
297 ada-gnat-quoted-punctuation-regexp))
298 (let ((bad (match-string-no-properties 1))
299 (good (match-string-no-properties 2)))
300 (pop-to-buffer source-buffer)
302 (delete-region (match-beginning 0) (match-end 0))
307 ((looking-at (concat "misspelling of " ada-gnat-quoted-name-regexp))
308 (let ((expected-name (match-string 1)))
309 (pop-to-buffer source-buffer)
310 (looking-at ada-name-regexp)
311 (delete-region (match-beginning 1) (match-end 1))
312 (insert expected-name))
315 ((looking-at (concat "\"end " ada-name-regexp ";\" expected"))
316 (let ((expected-name (match-string 1)))
317 (pop-to-buffer source-buffer)
318 (if (looking-at (concat "end " ada-name-regexp ";"))
320 (goto-char (match-end 1)) ; just before ';'
321 (delete-region (match-beginning 1) (match-end 1)))
322 ;; else we have just 'end;'
325 (insert expected-name))
328 ((looking-at (concat "\"end loop " ada-name-regexp ";\" expected"))
329 (let ((expected-name (match-string 1)))
330 (pop-to-buffer source-buffer)
331 (if (looking-at (concat "end loop " ada-name-regexp ";"))
333 (goto-char (match-end 1)) ; just before ';'
334 (delete-region (match-beginning 1) (match-end 1)))
335 ;; else we have just 'end loop;'
338 (insert expected-name))
341 ((looking-at "expected an access type")
343 (set-buffer source-buffer)
345 (when (looking-at "\\.all")
349 ((looking-at (concat "expected \\(private \\)?type " ada-gnat-quoted-name-regexp))
352 (move-to-column message-column)
354 ((looking-at "found type access")
355 (pop-to-buffer source-buffer)
356 (if (looking-at "'Access")
361 ((looking-at "found type .*_Access_Type")
362 ;; assume just need '.all'
363 (pop-to-buffer source-buffer)
369 ((looking-at "extra \".\" ignored")
370 (set-buffer source-buffer)
374 ((looking-at (concat "keyword " ada-gnat-quoted-name-regexp " expected here"))
375 (let ((expected-keyword (match-string 1)))
376 (pop-to-buffer source-buffer)
377 (insert " " expected-keyword))
380 ((looking-at "\\(?:possible \\)?missing \"with \\([a-zA-Z0-9_.]+\\);")
381 ;; also 'possible missing "with Ada.Text_IO; use Ada.Text_IO"' - ignoring the 'use'
382 (let ((package-name (match-string-no-properties 1)))
383 (pop-to-buffer source-buffer)
384 ;; FIXME (later): should check if prefix is already with'd, extend it
385 (ada-fix-add-with-clause package-name))
388 ;; must be after above
389 ((looking-at "missing \"\\(.+\\)\"")
390 (let ((stuff (match-string-no-properties 1)))
391 (set-buffer source-buffer)
392 (insert (concat stuff)));; if missing ")", don't need space; otherwise do?
395 ((looking-at "No legal interpretation for operator")
397 (move-to-column message-column)
398 (looking-at (concat "use clause on " ada-gnat-quoted-name-regexp))
399 (let ((package (match-string 1)))
400 (pop-to-buffer source-buffer)
401 (ada-fix-add-use package))
404 ((looking-at (concat "no selector " ada-gnat-quoted-name-regexp))
405 ;; Check next line for spelling error.
407 (let ((unit-name (match-string 1))
408 (correct-spelling (ada-gnat-misspelling)))
409 (when correct-spelling
410 (pop-to-buffer source-buffer)
411 (search-forward unit-name)
412 (replace-match correct-spelling)
415 ((looking-at (concat "operator for \\(private \\)?type " ada-gnat-quoted-name-regexp))
416 (let ((type (match-string 2)))
417 (pop-to-buffer source-buffer)
418 (ada-goto-declarative-region-start)
420 (insert "use type " type ";"))
423 ((looking-at "parentheses required for unary minus")
424 (set-buffer source-buffer)
430 ((looking-at "prefix of dereference must be an access type")
431 (pop-to-buffer source-buffer)
432 ;; point is after '.' in '.all'
433 (delete-region (- (point) 1) (+ (point) 3))
437 ((looking-at (concat "warning: " ada-gnat-quoted-name-regexp " is already use-visible"))
438 ;; just delete the 'use'; assume it's on a line by itself.
439 (pop-to-buffer source-buffer)
441 (delete-region (point) (progn (forward-line 1) (point)))
444 ((looking-at (concat "warning: " ada-gnat-quoted-name-regexp " is not modified, could be declared constant"))
445 (pop-to-buffer source-buffer)
447 (forward-comment (- (point-max) (point)))
448 ;; "aliased" must be before "constant", so check for it
449 (when (looking-at "aliased")
455 ((looking-at (concat "warning: constant " ada-gnat-quoted-name-regexp " is not referenced"))
456 (let ((constant (match-string 1)))
457 (pop-to-buffer source-buffer)
460 (insert "pragma Unreferenced (" constant ");"))
463 ((looking-at (concat "warning: formal parameter " ada-gnat-quoted-name-regexp " is not referenced"))
464 (let ((param (match-string 1)))
465 (pop-to-buffer source-buffer)
466 (ada-goto-declarative-region-start)
468 (insert "pragma Unreferenced (" param ");"))
471 ((looking-at (concat "warning: formal parameter " ada-gnat-quoted-name-regexp " is not modified"))
472 (let ((mode-regexp "\"\\([in out]+\\)\"")
476 (search-forward-regexp
477 (concat "mode could be " mode-regexp " instead of " mode-regexp))
478 (setq new-mode (match-string 1))
479 (setq old-mode (match-string 2))
480 (pop-to-buffer source-buffer)
481 (search-forward old-mode)
482 (replace-match new-mode)
488 (looking-at (concat "warning: no entities of " ada-gnat-quoted-name-regexp " are referenced$"))
489 (looking-at (concat "warning: unit " ada-gnat-quoted-name-regexp " is never instantiated$"))
490 (looking-at "warning: redundant with clause"))
491 ;; just delete the 'with'; assume it's on a line by itself.
492 (pop-to-buffer source-buffer)
494 (delete-region (point) (progn (forward-line 1) (point)))
497 ((looking-at (concat "warning: variable " ada-gnat-quoted-name-regexp " is assigned but never read"))
498 (let ((param (match-string 1)))
499 (pop-to-buffer source-buffer)
500 (ada-goto-end) ;; leaves point before semicolon
503 (insert "pragma Unreferenced (" param ");"))
506 ((looking-at (concat "warning: unit " ada-gnat-quoted-name-regexp " is not referenced$"))
507 ;; just delete the 'with'; assume it's on a line by itself.
508 (pop-to-buffer source-buffer)
510 (delete-region (point) (progn (forward-line 1) (point)))
514 ((looking-at "(style) \".*\" in wrong column")
515 (set-buffer source-buffer)
516 (funcall indent-line-function)
519 ((looking-at "(style) bad capitalization, mixed case required")
520 (set-buffer source-buffer)
522 (ada-case-adjust-identifier)
525 ((looking-at (concat "(style) bad casing of " ada-gnat-quoted-name-regexp))
526 (let ((correct (match-string-no-properties 1))
528 ;; gnat leaves point on first bad character, but we need to replace the whole word
529 (set-buffer source-buffer)
530 (skip-syntax-backward "w_")
532 (skip-syntax-forward "w_")
533 (delete-region (point) end)
538 (looking-at "(style) bad column")
539 (looking-at "(style) bad indentation")
540 (looking-at "(style) incorrect layout"))
541 (set-buffer source-buffer)
542 (funcall indent-line-function)
545 ((looking-at "(style) misplaced \"then\"")
546 (set-buffer source-buffer)
550 ((looking-at "(style) missing \"overriding\" indicator")
551 (set-buffer source-buffer)
553 ((looking-at "\\(procedure\\)\\|\\(function\\)")
554 (insert "overriding ")
559 ((looking-at "(style) space not allowed")
560 (set-buffer source-buffer)
561 ;; Error places point on space. More than one trailing space
562 ;; should be fixed by delete-trailing-whitespace in
563 ;; before-save-hook, once the file is modified.
567 ((looking-at "(style) space required")
568 (set-buffer source-buffer)
571 )));; end of setq unwind-protect cond
574 (goto-char start-pos)
580 (defun ada-gnat-compile-select-prj ()
581 (setq ada-fix-error-hook 'ada-gnat-fix-error-hook)
582 (setq ada-prj-show-path 'gnat-prj-show-path)
583 (add-to-list 'completion-ignored-extensions ".ali") ;; gnat library files
584 (add-hook 'ada-syntax-propertize-hook 'ada-gnat-syntax-propertize)
585 (add-hook 'ada-syntax-propertize-hook 'gnatprep-syntax-propertize)
587 ;; There is no common convention for a file extension for gnatprep files.
589 ;; find error locations in .gpr files
590 (setq compilation-search-path (append compilation-search-path (ada-prj-get 'prj_dir)))
592 ;; must be after indentation engine setup, because that resets the
593 ;; indent function list.
594 (add-hook 'ada-mode-hook 'gnatprep-setup t)
596 (add-hook 'compilation-filter-hook 'ada-gnat-compilation-filter)
598 ;; ada-mode.el project file parser sets this to other compilers used
599 ;; in the project, so we only add here.
600 (add-to-list 'compilation-error-regexp-alist 'gnat)
603 (defun ada-gnat-compile-deselect-prj ()
604 (setq ada-fix-error-hook nil)
605 (setq completion-ignored-extensions (delete ".ali" completion-ignored-extensions))
606 (setq ada-syntax-propertize-hook (delq 'gnatprep-syntax-propertize ada-syntax-propertize-hook))
607 (setq ada-syntax-propertize-hook (delq 'ada-gnat-syntax-propertize ada-syntax-propertize-hook))
609 ;; don't need to delete from compilation-search-path; completely rewritten in ada-select-prj-file
611 (setq ada-mode-hook (delq 'gnatprep-setup ada-mode-hook))
613 (setq compilation-filter-hook (delete 'ada-gnat-compilation-filter compilation-filter-hook))
614 (setq compilation-error-regexp-alist (delete 'gnat compilation-error-regexp-alist))
617 (defun ada-gnat-compile ()
618 "Set Ada mode global vars to use 'gnat' for compiling."
619 (add-to-list 'ada-prj-file-ext-extra "gpr")
620 (add-to-list 'ada-prj-parser-alist '("gpr" . gnat-parse-gpr))
621 (add-to-list 'ada-select-prj-compiler '(gnat . ada-gnat-compile-select-prj))
622 (add-to-list 'ada-deselect-prj-compiler '(gnat . ada-gnat-compile-deselect-prj))
624 (add-to-list 'ada-prj-parse-one-compiler (cons 'gnat 'gnat-prj-parse-emacs-one))
625 (add-to-list 'ada-prj-parse-final-compiler (cons 'gnat 'gnat-prj-parse-emacs-final))
627 (font-lock-add-keywords 'ada-mode
628 ;; gnatprep preprocessor line
629 (list (list "^[ \t]*\\(#.*\n\\)" '(1 font-lock-preprocessor-face t))))
631 (add-hook 'ada-gnat-fix-error-hook 'ada-gnat-fix-error))
633 (provide 'ada-gnat-compile)
634 (provide 'ada-compiler)
639 'compilation-error-regexp-alist-alist
642 ;; cards_package.adb:45:32: expected private type "System.Address"
644 ;; with full path Source_Reference pragma :
645 ;; d:/maphds/version_x/1773/sbs-abi-dll_lib.ads.gp:39:06: file "interfaces_c.ads" not found
647 ;; gnu cc1: (gnatmake can invoke the C compiler)
648 ;; foo.c:2: `TRUE' undeclared here (not in a function)
649 ;; foo.c:2 : `TRUE' undeclared here (not in a function)
650 "^\\(\\(.:\\)?[^ :\n]+\\):\\([0-9]+\\)\\s-?:?\\([0-9]+\\)?" 1 3 4))
652 (unless (default-value 'ada-compiler)
653 (set-default 'ada-compiler 'gnat))