code.delx.au - gnu-emacs-elpa/blob - packages/ada-mode/ada-gnat-compile.el

   1 ;; Ada mode compiling functionality provided by the 'gnat'
   2 ;; tool. Includes related functions, such as gnatprep support.
   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 - 2015  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     (goto-char (line-beginning-position))
  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              ;; gnatquery.adb:255:13: "Has_Element" is not visible
 204              ;; gnatquery.adb:255:13: non-visible declaration at a-convec.ads:68, instance at gnatcoll-arg_lists.ads:157
 205              ;; gnatquery.adb:255:13: non-visible declaration at a-coorse.ads:62, instance at gnatcoll-xref.ads:912
 206              ;; gnatquery.adb:255:13: non-visible declaration at a-coorse.ads:62, instance at gnatcoll-xref.ads:799
 207              ;; gnatquery.adb:255:13: non-visible declaration at gnatcoll-xref.ads:314
 208              ;;
 209              ;; or the next line may contain "multiple use clauses cause hiding"
 210              ;;
 211              ;; the lines after that may contain alternate matches;
 212              ;; collect all, let user choose.
 213              (forward-line 1)
 214              (unless (looking-at ".* multiple use clauses cause hiding")
 215                (while (not done)
 216                  (let ((limit (1- (line-end-position))))
 217                    ;; 1- because next compilation error is at next line beginning
 218                    (setq done (not
 219                                (and
 220                                 (equal file-line-struct (ada-get-compilation-message))
 221                                 (setq pos (next-single-property-change (point) 'ada-secondary-error nil limit))
 222                                 (< pos limit))))
 223                    (when (not done)
 224                      (let* ((item (get-text-property pos 'ada-secondary-error))
 225                             (unit-file (nth 0 item))
 226                             (choice (ada-ada-name-from-file-name unit-file)))
 227                        (unless (member choice choices) (push choice choices))
 228                        (goto-char (1+ pos))
 229                        (goto-char (1+ (next-single-property-change (point) 'ada-secondary-error nil limit)))
 230                        (when (eolp) (forward-line 1))
 231                        ))
 232                    )));; unless while let
 233
 234              (setq unit-name
 235                    (cond
 236                     ((= 0 (length choices)) nil)
 237                     ((= 1 (length choices)) (car choices))
 238                     (t ;; multiple choices
 239                      (completing-read "package name: " choices))))
 240
 241              (when unit-name
 242                (pop-to-buffer source-buffer)
 243                ;; We either need to add a with_clause for a package, or
 244                ;; prepend the package name here (or add a use clause, but I
 245                ;; don't want to do that automatically).
 246                ;;
 247                ;; If we need to add a with_clause, unit-name may be only
 248                ;; the prefix of the real package name, but in that case
 249                ;; we'll be back after the next compile; no way to get the
 250                ;; full package name (without the function/type name) now.
 251                ;; Note that we can't use gnat find, because the code
 252                ;; doesn't compile.
 253                (cond
 254                 ((looking-at (concat unit-name "\\."))
 255                  (ada-fix-add-with-clause unit-name))
 256                 (t
 257                  (ada-fix-insert-unit-name unit-name)
 258                  (insert ".")))
 259                t) ;; success, else nil => fail
 260              ))
 261
 262           ((or (looking-at (concat ada-gnat-quoted-name-regexp " is undefined"))
 263                (looking-at (concat ada-gnat-quoted-name-regexp " is not a predefined library unit")))
 264            ;; We either need to add a with_clause for a package, or
 265            ;; something is spelled wrong.
 266            (save-excursion
 267              (let ((unit-name (match-string 1))
 268                    (correct-spelling (ada-gnat-misspelling)))
 269                (if correct-spelling
 270                    (progn
 271                      (pop-to-buffer source-buffer)
 272                      (search-forward unit-name)
 273                      (replace-match correct-spelling))
 274
 275                  ;; else assume missing with
 276                  (pop-to-buffer source-buffer)
 277                  (ada-fix-add-with-clause unit-name))))
 278            t)
 279
 280           ((looking-at (concat ada-gnat-quoted-name-regexp " not declared in " ada-gnat-quoted-name-regexp))
 281            (save-excursion
 282              (let ((child-name (match-string 1))
 283                    (correct-spelling (ada-gnat-misspelling)))
 284                (if correct-spelling
 285                    (progn
 286                      (setq correct-spelling (match-string 1))
 287                      (pop-to-buffer source-buffer)
 288                      (search-forward child-name)
 289                      (replace-match correct-spelling))
 290
 291                  ;; else guess that "child" is a child package, and extend the with_clause
 292                  (pop-to-buffer source-buffer)
 293                  (ada-fix-extend-with-clause child-name))))
 294            t)
 295
 296           ((looking-at (concat ada-gnat-quoted-punctuation-regexp
 297                                " should be "
 298                                ada-gnat-quoted-punctuation-regexp))
 299            (let ((bad (match-string-no-properties 1))
 300                  (good (match-string-no-properties 2)))
 301              (pop-to-buffer source-buffer)
 302              (looking-at bad)
 303              (delete-region (match-beginning 0) (match-end 0))
 304              (insert good))
 305            t)
 306
 307 ;;;; strings
 308           ((looking-at (concat "misspelling of " ada-gnat-quoted-name-regexp))
 309            (let ((expected-name (match-string 1)))
 310              (pop-to-buffer source-buffer)
 311              (looking-at ada-name-regexp)
 312              (delete-region (match-beginning 1) (match-end 1))
 313              (insert expected-name))
 314            t)
 315
 316           ((looking-at (concat "\"end " ada-name-regexp ";\" expected"))
 317            (let ((expected-name (match-string 1)))
 318              (pop-to-buffer source-buffer)
 319              (if (looking-at (concat "end " ada-name-regexp ";"))
 320                  (progn
 321                    (goto-char (match-end 1))   ; just before ';'
 322                    (delete-region (match-beginning 1) (match-end 1)))
 323                ;; else we have just 'end;'
 324                (forward-word 1)
 325                (insert " "))
 326              (insert expected-name))
 327            t)
 328
 329           ((looking-at (concat "\"end loop " ada-name-regexp ";\" expected"))
 330            (let ((expected-name (match-string 1)))
 331              (pop-to-buffer source-buffer)
 332              (if (looking-at (concat "end loop " ada-name-regexp ";"))
 333                  (progn
 334                    (goto-char (match-end 1))   ; just before ';'
 335                    (delete-region (match-beginning 1) (match-end 1)))
 336                ;; else we have just 'end loop;'
 337                (forward-word 2)
 338                (insert " "))
 339              (insert expected-name))
 340            t)
 341
 342           ((looking-at "expected an access type")
 343            (progn
 344              (set-buffer source-buffer)
 345              (backward-char 1)
 346              (when (looking-at "\\.all")
 347                (delete-char 4)
 348                t)))
 349
 350           ((looking-at (concat "expected \\(private \\)?type " ada-gnat-quoted-name-regexp))
 351            (let ((type (match-string 2)))
 352              (forward-line 1)
 353              (move-to-column message-column)
 354              (cond
 355               ((looking-at "found type access")
 356                (pop-to-buffer source-buffer)
 357                (if (looking-at "'Access")
 358                    (kill-word 1)
 359                  (forward-word 1)
 360                  (insert ".all"))
 361                t)
 362              ((looking-at "found type .*_Access_Type")
 363                ;; assume just need '.all'
 364                (pop-to-buffer source-buffer)
 365                (forward-word 1)
 366                (insert ".all")
 367                t)
 368              )))
 369
 370           ((looking-at "extra \".\" ignored")
 371            (set-buffer source-buffer)
 372            (delete-char 1)
 373            t)
 374
 375           ((looking-at (concat "keyword " ada-gnat-quoted-name-regexp " expected here"))
 376            (let ((expected-keyword (match-string 1)))
 377              (pop-to-buffer source-buffer)
 378              (insert " " expected-keyword))
 379            t)
 380
 381           ((looking-at "\\(?:possible \\)?missing \"with \\([a-zA-Z0-9_.]+\\);")
 382            ;; also 'possible missing "with Ada.Text_IO; use Ada.Text_IO"' - ignoring the 'use'
 383            (let ((package-name (match-string-no-properties 1)))
 384              (pop-to-buffer source-buffer)
 385              ;; FIXME (later): should check if prefix is already with'd, extend it
 386              (ada-fix-add-with-clause package-name))
 387            t)
 388
 389           ;; must be after above
 390           ((looking-at "missing \"\\(.+\\)\"")
 391            (let ((stuff (match-string-no-properties 1)))
 392              (set-buffer source-buffer)
 393              (insert (concat stuff)));; if missing ")", don't need space; otherwise do?
 394            t)
 395
 396           ((looking-at "No legal interpretation for operator")
 397            (forward-line 1)
 398            (move-to-column message-column)
 399            (looking-at (concat "use clause on " ada-gnat-quoted-name-regexp))
 400            (let ((package (match-string 1)))
 401              (pop-to-buffer source-buffer)
 402              (ada-fix-add-use package))
 403            t)
 404
 405           ((looking-at (concat "no selector " ada-gnat-quoted-name-regexp))
 406            ;; Check next line for spelling error.
 407            (save-excursion
 408              (let ((unit-name (match-string 1))
 409                    (correct-spelling (ada-gnat-misspelling)))
 410                (when correct-spelling
 411                  (pop-to-buffer source-buffer)
 412                  (search-forward unit-name)
 413                  (replace-match correct-spelling)
 414                  t))))
 415
 416           ((looking-at (concat "operator for \\(private \\)?type " ada-gnat-quoted-name-regexp))
 417            (let ((type (match-string 2)))
 418              (pop-to-buffer source-buffer)
 419              (ada-goto-declarative-region-start)
 420              (newline-and-indent)
 421              (insert "use type " type ";"))
 422            t)
 423
 424           ((looking-at "parentheses required for unary minus")
 425            (set-buffer source-buffer)
 426            (insert "(")
 427            (forward-word 1)
 428            (insert ")")
 429            t)
 430
 431           ((looking-at "prefix of dereference must be an access type")
 432            (pop-to-buffer source-buffer)
 433            ;; point is after '.' in '.all'
 434            (delete-region (- (point) 1) (+ (point) 3))
 435            t)
 436
 437 ;;;; warnings
 438           ((looking-at (concat "warning: " ada-gnat-quoted-name-regexp " is already use-visible"))
 439            ;; just delete the 'use'; assume it's on a line by itself.
 440            (pop-to-buffer source-buffer)
 441            (beginning-of-line)
 442            (delete-region (point) (progn (forward-line 1) (point)))
 443            t)
 444
 445           ((looking-at (concat "warning: " ada-gnat-quoted-name-regexp " is not modified, could be declared constant"))
 446            (pop-to-buffer source-buffer)
 447            (search-forward ":")
 448            (forward-comment (- (point-max) (point)))
 449            ;; "aliased" must be before "constant", so check for it
 450            (when (looking-at "aliased")
 451              (forward-word 1)
 452              (forward-char 1))
 453            (insert "constant ")
 454            t)
 455
 456           ((looking-at (concat "warning: constant " ada-gnat-quoted-name-regexp " is not referenced"))
 457            (let ((constant (match-string 1)))
 458              (pop-to-buffer source-buffer)
 459              (end-of-line)
 460              (newline-and-indent)
 461              (insert "pragma Unreferenced (" constant ");"))
 462            t)
 463
 464           ((looking-at (concat "warning: formal parameter " ada-gnat-quoted-name-regexp " is not referenced"))
 465            (let ((param (match-string 1)))
 466              (pop-to-buffer source-buffer)
 467              (ada-goto-declarative-region-start)
 468              (newline-and-indent)
 469              (insert "pragma Unreferenced (" param ");"))
 470            t)
 471
 472           ((looking-at (concat "warning: formal parameter " ada-gnat-quoted-name-regexp " is not modified"))
 473            (let ((param (match-string 1))
 474                  (mode-regexp "\"\\([in out]+\\)\"")
 475                  new-mode
 476                  old-mode)
 477              (forward-line 1)
 478              (search-forward-regexp
 479               (concat "mode could be " mode-regexp " instead of " mode-regexp))
 480              (setq new-mode (match-string 1))
 481              (setq old-mode (match-string 2))
 482              (pop-to-buffer source-buffer)
 483              (search-forward old-mode)
 484              (replace-match new-mode)
 485              (ada-align)
 486              )
 487            t)
 488
 489           ((or
 490             (looking-at (concat "warning: no entities of " ada-gnat-quoted-name-regexp " are referenced$"))
 491             (looking-at (concat "warning: unit " ada-gnat-quoted-name-regexp " is never instantiated$"))
 492             (looking-at "warning: redundant with clause"))
 493            ;; just delete the 'with'; assume it's on a line by itself.
 494            (pop-to-buffer source-buffer)
 495            (beginning-of-line)
 496            (delete-region (point) (progn (forward-line 1) (point)))
 497            t)
 498
 499           ((looking-at (concat "warning: variable " ada-gnat-quoted-name-regexp " is assigned but never read"))
 500            (let ((param (match-string 1)))
 501              (pop-to-buffer source-buffer)
 502              (ada-goto-end) ;; leaves point before semicolon
 503              (forward-char 1)
 504              (newline-and-indent)
 505              (insert "pragma Unreferenced (" param ");"))
 506            t)
 507
 508           ((looking-at (concat "warning: unit " ada-gnat-quoted-name-regexp " is not referenced$"))
 509            ;; just delete the 'with'; assume it's on a line by itself.
 510            (pop-to-buffer source-buffer)
 511            (beginning-of-line)
 512            (delete-region (point) (progn (forward-line 1) (point)))
 513            t)
 514
 515 ;;;; style errors
 516           ((looking-at "(style) \".*\" in wrong column")
 517            (set-buffer source-buffer)
 518            (funcall indent-line-function)
 519            t)
 520
 521           ((looking-at "(style) bad capitalization, mixed case required")
 522            (set-buffer source-buffer)
 523            (forward-word)
 524            (ada-case-adjust-identifier)
 525            t)
 526
 527           ((looking-at (concat "(style) bad casing of " ada-gnat-quoted-name-regexp))
 528            (let ((correct (match-string-no-properties 1))
 529                  end)
 530              ;; gnat leaves point on first bad character, but we need to replace the whole word
 531              (set-buffer source-buffer)
 532              (skip-syntax-backward "w_")
 533              (setq end (point))
 534              (skip-syntax-forward "w_")
 535              (delete-region (point) end)
 536              (insert correct))
 537            t)
 538
 539           ((or
 540             (looking-at "(style) bad column")
 541             (looking-at "(style) bad indentation")
 542             (looking-at "(style) incorrect layout"))
 543            (set-buffer source-buffer)
 544            (funcall indent-line-function)
 545            t)
 546
 547           ((looking-at "(style) misplaced \"then\"")
 548            (set-buffer source-buffer)
 549            (delete-indentation)
 550            t)
 551
 552          ((looking-at "(style) missing \"overriding\" indicator")
 553           (set-buffer source-buffer)
 554           (cond
 555            ((looking-at "\\(procedure\\)\\|\\(function\\)")
 556             (insert "overriding ")
 557             t)
 558            (t
 559             nil)))
 560
 561           ((looking-at "(style) space not allowed")
 562            (set-buffer source-buffer)
 563            ;; Error places point on space. More than one trailing space
 564            ;; should be fixed by delete-trailing-whitespace in
 565            ;; before-save-hook, once the file is modified.
 566            (delete-char 1)
 567            t)
 568
 569           ((looking-at "(style) space required")
 570            (set-buffer source-buffer)
 571            (insert " ")
 572            t)
 573           )));; end of setq unwind-protect cond
 574     (if result
 575         t
 576       (goto-char start-pos)
 577       nil)
 578     ))
 579
 580 ;;;;; setup
 581
 582 (defun ada-gnat-compile-select-prj ()
 583   (setq ada-fix-error-hook 'ada-gnat-fix-error-hook)
 584   (setq ada-prj-show-path 'gnat-prj-show-path)
 585   (add-to-list 'completion-ignored-extensions ".ali") ;; gnat library files
 586   (add-hook 'ada-syntax-propertize-hook 'ada-gnat-syntax-propertize)
 587   (add-hook 'ada-syntax-propertize-hook 'gnatprep-syntax-propertize)
 588
 589   ;; There is no common convention for a file extension for gnatprep files.
 590   ;;
 591   ;; find error locations in .gpr files
 592   (setq compilation-search-path (append compilation-search-path (ada-prj-get 'prj_dir)))
 593
 594   ;; must be after indentation engine setup, because that resets the
 595   ;; indent function list.
 596   (add-hook 'ada-mode-hook 'gnatprep-setup t)
 597
 598   (add-hook 'compilation-filter-hook 'ada-gnat-compilation-filter)
 599
 600   ;; ada-mode.el project file parser sets this to other compilers used
 601   ;; in the project, so we only add here.
 602   (add-to-list 'compilation-error-regexp-alist 'gnat)
 603   )
 604
 605 (defun ada-gnat-compile-deselect-prj ()
 606   (setq ada-fix-error-hook nil)
 607   (setq completion-ignored-extensions (delete ".ali" completion-ignored-extensions))
 608   (setq ada-syntax-propertize-hook (delq 'gnatprep-syntax-propertize ada-syntax-propertize-hook))
 609   (setq ada-syntax-propertize-hook (delq 'ada-gnat-syntax-propertize ada-syntax-propertize-hook))
 610
 611   ;; don't need to delete from compilation-search-path; completely rewritten in ada-select-prj-file
 612
 613   (setq ada-mode-hook (delq 'gnatprep-setup ada-mode-hook))
 614
 615   (setq compilation-filter-hook (delete 'ada-gnat-compilation-filter compilation-filter-hook))
 616   (setq compilation-error-regexp-alist (delete 'gnat compilation-error-regexp-alist))
 617   )
 618
 619 (defun ada-gnat-compile ()
 620   "Set Ada mode global vars to use 'gnat' for compiling."
 621   (add-to-list 'ada-prj-file-ext-extra     "gpr")
 622   (add-to-list 'ada-prj-parser-alist       '("gpr" . gnat-parse-gpr))
 623   (add-to-list 'ada-select-prj-compiler    '(gnat  . ada-gnat-compile-select-prj))
 624   (add-to-list 'ada-deselect-prj-compiler  '(gnat  . ada-gnat-compile-deselect-prj))
 625
 626   (add-to-list 'ada-prj-parse-one-compiler   (cons 'gnat 'gnat-prj-parse-emacs-one))
 627   (add-to-list 'ada-prj-parse-final-compiler (cons 'gnat 'gnat-prj-parse-emacs-final))
 628
 629   (font-lock-add-keywords 'ada-mode
 630    ;; gnatprep preprocessor line
 631    (list (list "^[ \t]*\\(#.*\n\\)"  '(1 font-lock-preprocessor-face t))))
 632
 633   (add-hook 'ada-gnat-fix-error-hook 'ada-gnat-fix-error))
 634
 635 (provide 'ada-gnat-compile)
 636 (provide 'ada-compiler)
 637
 638 (ada-gnat-compile)
 639
 640 (add-to-list
 641  'compilation-error-regexp-alist-alist
 642  '(gnat
 643    ;; typical:
 644    ;;   cards_package.adb:45:32: expected private type "System.Address"
 645    ;;
 646    ;; with full path Source_Reference pragma :
 647    ;;   d:/maphds/version_x/1773/sbs-abi-dll_lib.ads.gp:39:06: file "interfaces_c.ads" not found
 648    ;;
 649    ;; gnu cc1: (gnatmake can invoke the C compiler)
 650    ;;   foo.c:2: `TRUE' undeclared here (not in a function)
 651    ;;   foo.c:2 : `TRUE' undeclared here (not in a function)
 652    "^\\(\\(.:\\)?[^ :\n]+\\):\\([0-9]+\\)\\s-?:?\\([0-9]+\\)?" 1 3 4))
 653
 654 (unless (default-value 'ada-compiler)
 655     (set-default 'ada-compiler 'gnat))
 656
 657 ;; end of file