]> code.delx.au - gnu-emacs-elpa/blob - packages/ada-mode/ada-gnat-compile.el
Add ada-mode, wisi packages
[gnu-emacs-elpa] / packages / ada-mode / ada-gnat-compile.el
1 ;; Ada mode compiling functionality provided by the 'gnat'
2 ;; tool.
3 ;;
4 ;; These tools are all Ada-specific; use Makefiles for multi-language
5 ;; GNAT compilation tools.
6 ;;
7 ;; GNAT is provided by AdaCore; see http://libre.adacore.com/
8 ;;
9 ;;; Copyright (C) 2012, 2013 Free Software Foundation, Inc.
10 ;;
11 ;; Author: Stephen Leake <stephen_leake@member.fsf.org>
12 ;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
13 ;;
14 ;; This file is part of GNU Emacs.
15 ;;
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.
20 ;;
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.
25 ;;
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/>.
28 ;;
29 ;;; Usage:
30 ;;
31 ;; Emacs should enter Ada mode automatically when you load an Ada
32 ;; file, based on the file extension.
33 ;;
34 ;; By default, ada-mode is configured to load this file, so nothing
35 ;; special needs to done to use it.
36
37 (require 'compile)
38 (require 'gnat-core)
39
40 ;;;;; code
41
42 ;;;; compiler message handling
43
44 (defun ada-gnat-compilation-filter ()
45 "Filter to add text properties to secondary file references.
46 For `compilation-filter-hook'."
47 (save-excursion
48 (goto-char compilation-filter-start)
49
50 ;; primary references are handled by font-lock functions; see
51 ;; `compilation-mode-font-lock-keywords'.
52 ;;
53 ;; compilation-filter might insert partial lines, or it might insert multiple lines
54 (when (bolp)
55 (while (not (eobp))
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.
61
62 ;; typical secondary references look like:
63 ;;
64 ;; trivial_productions_test.adb:57:77: ==> in call to "Get" at \
65 ;; opentoken-token-enumerated-analyzer.ads:88, instance at line 41
66 ;;
67 ;; c:/foo/bar/lookahead_test.adb:379:14: found type access to "Standard.String" defined at line 379
68 ;;
69 ;; lookahead_test.ads:23:09: "Name" has been inherited from subprogram at aunit-simple_test_cases.ads:47
70 ;;
71 ;; lalr.adb:668:37: non-visible declaration at analyzer.ads:60, instance at parser.ads:38
72 ;;
73 ;; save the file from the primary reference, look for "*.ad?:nn", "at line nnn"
74
75 (let (file)
76 (when (looking-at "^\\(\\(.:\\)?[^ :\n]+\\):")
77 (setq file (match-string-no-properties 1)))
78
79 (skip-syntax-forward "^-"); space following primary reference
80
81 (while (search-forward-regexp "\\s-\\(\\([^[:blank:]]+\\.[[:alpha:]]+\\):\\([0-9]+\\)\\)"
82 (line-end-position) t)
83
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
88 (put-text-property
89 (match-beginning 0) (match-end 0)
90 'ada-secondary-error
91 (list
92 (match-string-no-properties 2); file
93 (string-to-number (match-string-no-properties 3)); line
94 1)); column
95 ))
96
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
101 (put-text-property
102 (match-beginning 1) (match-end 1)
103 'ada-secondary-error
104 (list
105 file
106 (string-to-number (match-string-no-properties 2)); line
107 1)); column
108 ))
109 (forward-line 1))
110 ))
111 ))
112
113 (defun ada-gnat-debug-filter ()
114 ;; call ada-gnat-compilation-filter with `compilation-filter-start' bound
115 (interactive)
116 (beginning-of-line)
117 (let ((compilation-filter-start (point)))
118 (ada-gnat-compilation-filter)))
119
120 ;;;;; auto fix compilation errors
121
122 (defconst ada-gnat-quoted-name-regexp
123 "\"\\([a-zA-Z0-9_.']+\\)\""
124 "regexp to extract the quoted names in error messages")
125
126 (defconst ada-gnat-quoted-punctuation-regexp
127 "\"\\([,:;=()|]+\\)\""
128 "regexp to extract quoted punctuation in error messages")
129
130 (defvar ada-gnat-fix-error-hook nil
131 "For `ada-fix-error-alist'.")
132
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"
140 ;;
141 ;; column number can vary, so only check the line number
142
143 (let ((line (progn (beginning-of-line) (nth 1 (compilation--message->loc (ada-get-compilation-message)))))
144 done choices)
145 (while (not done)
146 (forward-line 1)
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)
150 (progn
151 (skip-syntax-forward "^-")
152 (forward-char 1)
153 (looking-at (concat "possible misspelling of " ada-gnat-quoted-name-regexp))))
154 (push (match-string 1) choices)))
155
156 ;; return correct spelling
157 (cond
158 ((= 0 (length choices))
159 nil)
160
161 ((= 1 (length choices))
162 (car choices))
163
164 (t ;; multiple choices
165 (completing-read "correct spelling: " choices))
166 )))
167
168 (defun ada-gnat-fix-error (msg source-buffer source-window)
169 "For `ada-gnat-fix-error-hook'."
170 (let ((start-pos (point))
171 message-column
172 result)
173 ;; Move to start of error message text
174 (skip-syntax-forward "^-")
175 (forward-char 1)
176 (setq message-column (current-column))
177
178 ;; recognize it, handle it
179 (setq
180 result
181 (unwind-protect
182 (cond
183 ;; It is tempting to define an alist of (MATCH . ACTION), but
184 ;; that is too hard to debug
185 ;;
186 ;; This list will get long, so let's impose some order.
187 ;;
188 ;; First expressions that start with a named regexp, alphabetical by variable name.
189 ;;
190 ;; Then expressions that start with a string, alphabetical by string.
191 ;;
192 ;; Then style errors.
193
194 ((looking-at (concat ada-gnat-quoted-name-regexp " is not visible"))
195 (let ((ident (match-string 1))
196 (done nil)
197 (file-line-struct (progn (beginning-of-line) (ada-get-compilation-message)))
198 pos choices unit-name)
199 ;; next line may contain a reference to where ident is
200 ;; defined; if present, it will have been marked by
201 ;; ada-gnat-compilation-filter
202 ;;
203 ;; or the next line may contain "multiple use clauses cause hiding"
204 ;;
205 ;; the lines after that may contain alternate matches;
206 ;; collect all, let user choose.
207 (while (not done)
208 (forward-line 1)
209 (unless (looking-at ".* multiple use clauses cause hiding")
210 (setq done (not
211 (and
212 (equal file-line-struct (ada-get-compilation-message))
213 (let ((limit (1- (line-end-position))))
214 ;; 1- because next compilation error is at next line beginning
215 (setq pos (next-single-property-change (point) 'ada-secondary-error nil limit))
216 (< pos limit)))))
217 (when (not done)
218 (let* ((item (get-text-property pos 'ada-secondary-error))
219 (unit-file (nth 0 item)))
220 (add-to-list 'choices (ada-ada-name-from-file-name unit-file)))))
221 );; while
222
223 (cond
224 ((= 0 (length choices))
225 (setq unit-name nil))
226
227 ((= 1 (length choices))
228 (setq unit-name (car choices)))
229
230 (t ;; multiple choices
231 (setq unit-name
232 (completing-read "package name: " choices)))
233 );; cond
234
235 (when unit-name
236 (pop-to-buffer source-buffer)
237 ;; We either need to add a with_clause for a package, or
238 ;; prepend the package name here (or add a use clause, but I
239 ;; don't want to do that automatically).
240 ;;
241 ;; If we need to add a with_clause, unit-name may be only
242 ;; the prefix of the real package name, but in that case
243 ;; we'll be back after the next compile; no way to get the
244 ;; full package name (without the function/type name) now.
245 ;; Note that we can't use gnat find, because the code
246 ;; doesn't compile.
247 (cond
248 ((looking-at (concat unit-name "\\."))
249 (ada-fix-add-with-clause unit-name))
250 (t
251 (ada-fix-insert-unit-name unit-name)
252 (insert ".")))
253 t) ;; success, else nil => fail
254 ))
255
256 ((or (looking-at (concat ada-gnat-quoted-name-regexp " is undefined"))
257 (looking-at (concat ada-gnat-quoted-name-regexp " is not a predefined library unit")))
258 ;; We either need to add a with_clause for a package, or
259 ;; something is spelled wrong.
260 (save-excursion
261 (let ((unit-name (match-string 1))
262 (correct-spelling (ada-gnat-misspelling)))
263 (if correct-spelling
264 (progn
265 (pop-to-buffer source-buffer)
266 (search-forward unit-name)
267 (replace-match correct-spelling))
268
269 ;; else assume missing with
270 (pop-to-buffer source-buffer)
271 (ada-fix-add-with-clause unit-name))))
272 t)
273
274 ((looking-at (concat ada-gnat-quoted-name-regexp " not declared in " ada-gnat-quoted-name-regexp))
275 (save-excursion
276 (let ((child-name (match-string 1))
277 (correct-spelling (ada-gnat-misspelling)))
278 (if correct-spelling
279 (progn
280 (setq correct-spelling (match-string 1))
281 (pop-to-buffer source-buffer)
282 (search-forward child-name)
283 (replace-match correct-spelling))
284
285 ;; else guess that "child" is a child package, and extend the with_clause
286 (pop-to-buffer source-buffer)
287 (ada-fix-extend-with-clause child-name))))
288 t)
289
290 ((looking-at (concat ada-gnat-quoted-punctuation-regexp
291 " should be "
292 ada-gnat-quoted-punctuation-regexp))
293 (let ((bad (match-string-no-properties 1))
294 (good (match-string-no-properties 2)))
295 (pop-to-buffer source-buffer)
296 (looking-at bad)
297 (delete-region (match-beginning 0) (match-end 0))
298 (insert good))
299 t)
300
301 ;;;; strings
302 ((looking-at (concat "misspelling of " ada-gnat-quoted-name-regexp))
303 (let ((expected-name (match-string 1)))
304 (pop-to-buffer source-buffer)
305 (looking-at ada-name-regexp)
306 (delete-region (match-beginning 1) (match-end 1))
307 (insert expected-name))
308 t)
309
310 ((looking-at (concat "\"end " ada-name-regexp ";\" expected"))
311 (let ((expected-name (match-string 1)))
312 (pop-to-buffer source-buffer)
313 (if (looking-at (concat "end " ada-name-regexp ";"))
314 (progn
315 (goto-char (match-end 1)) ; just before ';'
316 (delete-region (match-beginning 1) (match-end 1)))
317 ;; else we have just 'end;'
318 (forward-word 1)
319 (insert " "))
320 (insert expected-name))
321 t)
322
323 ((looking-at "expected an access type")
324 (progn
325 (set-buffer source-buffer)
326 (backward-char 1)
327 (when (looking-at "\\.all")
328 (delete-char 4)
329 t)))
330
331 ((looking-at (concat "expected \\(private \\)?type " ada-gnat-quoted-name-regexp))
332 (let ((type (match-string 2)))
333 (forward-line 1)
334 (move-to-column message-column)
335 (when (or (looking-at "found type access")
336 (looking-at "found type .*_Access_Type"))
337 ;; assume just need '.all'
338 (pop-to-buffer source-buffer)
339 (forward-word 1)
340 (insert ".all")
341 t)))
342
343 ((looking-at "extra \".\" ignored")
344 (set-buffer source-buffer)
345 (delete-char 1)
346 t)
347
348 ((looking-at (concat "keyword " ada-gnat-quoted-name-regexp " expected here"))
349 (let ((expected-keyword (match-string 1)))
350 (pop-to-buffer source-buffer)
351 (insert " " expected-keyword))
352 t)
353
354 ((looking-at "\\(?:possible \\)?missing \"with \\([a-zA-Z0-9_.]+\\);")
355 ;; also 'possible missing "with Ada.Text_IO; use Ada.Text_IO"' - ignoring the 'use'
356 (let ((package-name (match-string-no-properties 1)))
357 (pop-to-buffer source-buffer)
358 ;; FIXME (later): should check if prefix is already with'd, extend it
359 (ada-fix-add-with-clause package-name))
360 t)
361
362 ;; must be after above
363 ((looking-at "missing \"\\(.+\\)\"")
364 (let ((stuff (match-string-no-properties 1)))
365 (set-buffer source-buffer)
366 (insert (concat stuff)));; if missing ")", don't need space; otherwise do?
367 t)
368
369 ((looking-at "No legal interpretation for operator")
370 (forward-line 1)
371 (move-to-column message-column)
372 (looking-at (concat "use clause on " ada-gnat-quoted-name-regexp))
373 (let ((package (match-string 1)))
374 (pop-to-buffer source-buffer)
375 (ada-fix-add-use package))
376 t)
377
378 ((looking-at (concat "no selector " ada-gnat-quoted-name-regexp))
379 ;; Check next line for spelling error.
380 (save-excursion
381 (let ((unit-name (match-string 1))
382 (correct-spelling (ada-gnat-misspelling)))
383 (when correct-spelling
384 (pop-to-buffer source-buffer)
385 (search-forward unit-name)
386 (replace-match correct-spelling)
387 t))))
388
389 ((looking-at (concat "operator for \\(private \\)?type " ada-gnat-quoted-name-regexp))
390 (let ((type (match-string 2)))
391 (pop-to-buffer source-buffer)
392 (ada-goto-declarative-region-start)
393 (newline-and-indent)
394 (insert "use type " type ";"))
395 t)
396
397 ((looking-at "parentheses required for unary minus")
398 (set-buffer source-buffer)
399 (insert "(")
400 (forward-word 1)
401 (insert ")")
402 t)
403
404 ((looking-at "prefix of dereference must be an access type")
405 (pop-to-buffer source-buffer)
406 ;; point is after '.' in '.all'
407 (delete-region (- (point) 1) (+ (point) 3))
408 t)
409
410 ;;;; warnings
411 ((looking-at (concat "warning: " ada-gnat-quoted-name-regexp " is already use-visible"))
412 ;; just delete the 'use'; assume it's on a line by itself.
413 (pop-to-buffer source-buffer)
414 (beginning-of-line)
415 (delete-region (point) (progn (forward-line 1) (point)))
416 t)
417
418 ((looking-at (concat "warning: " ada-gnat-quoted-name-regexp " is not modified, could be declared constant"))
419 (pop-to-buffer source-buffer)
420 (search-forward ":")
421 (forward-comment (- (point-max) (point)))
422 ;; "aliased" must be before "constant", so check for it
423 (when (looking-at "aliased")
424 (forward-word 1)
425 (forward-char 1))
426 (insert "constant ")
427 t)
428
429 ((looking-at (concat "warning: constant " ada-gnat-quoted-name-regexp " is not referenced"))
430 (let ((constant (match-string 1)))
431 (pop-to-buffer source-buffer)
432 (end-of-line)
433 (newline-and-indent)
434 (insert "pragma Unreferenced (" constant ");"))
435 t)
436
437 ((looking-at (concat "warning: formal parameter " ada-gnat-quoted-name-regexp " is not referenced"))
438 (let ((param (match-string 1)))
439 (pop-to-buffer source-buffer)
440 (ada-goto-declarative-region-start)
441 (newline-and-indent)
442 (insert "pragma Unreferenced (" param ");"))
443 t)
444
445 ((looking-at (concat "warning: formal parameter " ada-gnat-quoted-name-regexp " is not modified"))
446 (let ((param (match-string 1))
447 (mode-regexp "\"\\([in out]+\\)\"")
448 new-mode
449 old-mode)
450 (forward-line 1)
451 (search-forward-regexp
452 (concat "mode could be " mode-regexp " instead of " mode-regexp))
453 (setq new-mode (match-string 1))
454 (setq old-mode (match-string 2))
455 (pop-to-buffer source-buffer)
456 (search-forward old-mode)
457 (replace-match new-mode)
458 (ada-align)
459 )
460 t)
461
462 ((or
463 (looking-at (concat "warning: no entities of " ada-gnat-quoted-name-regexp " are referenced$"))
464 (looking-at (concat "warning: unit " ada-gnat-quoted-name-regexp " is never instantiated$"))
465 (looking-at "warning: redundant with clause"))
466 ;; just delete the 'with'; assume it's on a line by itself.
467 (pop-to-buffer source-buffer)
468 (beginning-of-line)
469 (delete-region (point) (progn (forward-line 1) (point)))
470 t)
471
472 ((looking-at (concat "warning: variable " ada-gnat-quoted-name-regexp " is assigned but never read"))
473 (let ((param (match-string 1)))
474 (pop-to-buffer source-buffer)
475 (ada-goto-end)
476 (newline-and-indent)
477 (insert "pragma Unreferenced (" param ");"))
478 t)
479
480 ((looking-at (concat "warning: unit " ada-gnat-quoted-name-regexp " is not referenced$"))
481 ;; just delete the 'with'; assume it's on a line by itself.
482 (pop-to-buffer source-buffer)
483 (beginning-of-line)
484 (delete-region (point) (progn (forward-line 1) (point)))
485 t)
486
487 ;;;; style errors
488 ((looking-at "(style) \".*\" in wrong column")
489 (progn
490 (set-buffer source-buffer)
491 (funcall indent-line-function))
492 t)
493
494 ((looking-at "(style) bad capitalization, mixed case required")
495 (progn
496 (set-buffer source-buffer)
497 (forward-word)
498 (ada-case-adjust-identifier)
499 t))
500
501 ((looking-at (concat "(style) bad casing of " ada-gnat-quoted-name-regexp))
502 (let ((correct (match-string-no-properties 1))
503 end)
504 ;; gnat leaves point on first bad character, but we need to replace the whole word
505 (set-buffer source-buffer)
506 (skip-syntax-backward "w_")
507 (setq end (point))
508 (skip-syntax-forward "w_")
509 (delete-region (point) end)
510 (insert correct))
511 t)
512
513 ((or
514 (looking-at "(style) bad column")
515 (looking-at "(style) bad indentation")
516 (looking-at "(style) incorrect layout"))
517 (set-buffer source-buffer)
518 (funcall indent-line-function)
519 t)
520
521 ((looking-at "(style) missing \"overriding\" indicator")
522 (set-buffer source-buffer)
523 (cond
524 ((looking-at "\\(procedure\\)\\|\\(function\\)")
525 (insert "overriding ")
526 t)
527 (t
528 nil)))
529
530 ((looking-at "(style) space not allowed")
531 (set-buffer source-buffer)
532 ;; Error places point on space. More than one trailing space
533 ;; should be fixed by delete-trailing-whitespace in
534 ;; before-save-hook, once the file is modified.
535 (delete-char 1)
536 t)
537
538 ((looking-at "(style) space required")
539 (set-buffer source-buffer)
540 (insert " ")
541 t)
542 )));; end of setq unwind-protect cond
543 (if result
544 t
545 (goto-char start-pos)
546 nil)
547 ))
548
549 ;;;;; setup
550
551 (defun ada-gnat-compile-select-prj ()
552 (setq ada-fix-error-hook 'ada-gnat-fix-error-hook)
553 (add-to-list 'completion-ignored-extensions ".ali") ;; gnat library files
554
555 (add-hook 'compilation-filter-hook 'ada-gnat-compilation-filter)
556
557 ;; ada-mode.el project file parser sets this to other compilers used
558 ;; in the project, so we only add here.
559 (add-to-list 'compilation-error-regexp-alist 'gnat)
560 )
561
562 (defun ada-gnat-compile-deselect-prj ()
563 (setq ada-fix-error-hook nil)
564 (setq completion-ignored-extensions (delete ".ali" completion-ignored-extensions))
565 (setq compilation-filter-hook (delete 'ada-gnat-compilation-filter compilation-filter-hook))
566 (setq compilation-error-regexp-alist (delete 'gnat compilation-error-regexp-alist))
567 )
568
569 (defun ada-gnat-compile ()
570 "Set Ada mode global vars to use 'gnat' for compiling."
571 (add-to-list 'ada-prj-file-ext-extra "gpr")
572 (add-to-list 'ada-prj-parser-alist '("gpr" . gnat-parse-gpr))
573 (add-to-list 'ada-select-prj-compiler '(gnat . ada-gnat-compile-select-prj))
574 (add-to-list 'ada-deselect-prj-compiler '(gnat . ada-gnat-compile-deselect-prj))
575
576 (add-to-list 'ada-prj-parse-one-compiler (cons 'gnat 'gnat-prj-parse-emacs-one))
577 (add-to-list 'ada-prj-parse-final-compiler (cons 'gnat 'gnat-prj-parse-emacs-final))
578
579 (add-hook 'ada-gnat-fix-error-hook 'ada-gnat-fix-error))
580
581 (provide 'ada-gnat-compile)
582 (provide 'ada-compiler)
583
584 (ada-gnat-compile)
585
586 (add-to-list
587 'compilation-error-regexp-alist-alist
588 '(gnat
589 ;; typical:
590 ;; cards_package.adb:45:32: expected private type "System.Address"
591 ;;
592 ;; with full path Source_Reference pragma :
593 ;; d:/maphds/version_x/1773/sbs-abi-dll_lib.ads.gp:39:06: file "interfaces_c.ads" not found
594 ;;
595 ;; gnu cc1: (gnatmake can invoke the C compiler)
596 ;; foo.c:2: `TRUE' undeclared here (not in a function)
597 ;; foo.c:2 : `TRUE' undeclared here (not in a function)
598 "^\\(\\(.:\\)?[^ :\n]+\\):\\([0-9]+\\)\\s-?:?\\([0-9]+\\)?" 1 3 4))
599
600 (unless (default-value ada-compiler)
601 (set-default 'ada-compiler 'gnat))
602
603 ;; end of file