--- /dev/null
+;; Ada mode compiling functionality provided by the 'gnat'
+;; tool.
+;;
+;; These tools are all Ada-specific; use Makefiles for multi-language
+;; GNAT compilation tools.
+;;
+;; GNAT is provided by AdaCore; see http://libre.adacore.com/
+;;
+;;; Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+;;
+;; Author: Stephen Leake <stephen_leake@member.fsf.org>
+;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
+;;
+;; This file is part of GNU Emacs.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+;;
+;;; Usage:
+;;
+;; Emacs should enter Ada mode automatically when you load an Ada
+;; file, based on the file extension.
+;;
+;; By default, ada-mode is configured to load this file, so nothing
+;; special needs to done to use it.
+
+(require 'compile)
+(require 'gnat-core)
+
+;;;;; code
+
+;;;; compiler message handling
+
+(defun ada-gnat-compilation-filter ()
+ "Filter to add text properties to secondary file references.
+For `compilation-filter-hook'."
+ (save-excursion
+ (goto-char compilation-filter-start)
+
+ ;; primary references are handled by font-lock functions; see
+ ;; `compilation-mode-font-lock-keywords'.
+ ;;
+ ;; compilation-filter might insert partial lines, or it might insert multiple lines
+ (when (bolp)
+ (while (not (eobp))
+ ;; We don't want 'next-error' to always go to secondary
+ ;; references, so we _don't_ set 'compilation-message text
+ ;; property. Instead, we set 'ada-secondary-error, so
+ ;; `ada-goto-secondary-error' will handle it. We also set
+ ;; fonts, so the user can see the reference.
+
+ ;; typical secondary references look like:
+ ;;
+ ;; trivial_productions_test.adb:57:77: ==> in call to "Get" at \
+ ;; opentoken-token-enumerated-analyzer.ads:88, instance at line 41
+ ;;
+ ;; c:/foo/bar/lookahead_test.adb:379:14: found type access to "Standard.String" defined at line 379
+ ;;
+ ;; lookahead_test.ads:23:09: "Name" has been inherited from subprogram at aunit-simple_test_cases.ads:47
+ ;;
+ ;; lalr.adb:668:37: non-visible declaration at analyzer.ads:60, instance at parser.ads:38
+ ;;
+ ;; save the file from the primary reference, look for "*.ad?:nn", "at line nnn"
+
+ (let (file)
+ (when (looking-at "^\\(\\(.:\\)?[^ :\n]+\\):")
+ (setq file (match-string-no-properties 1)))
+
+ (skip-syntax-forward "^-"); space following primary reference
+
+ (while (search-forward-regexp "\\s-\\(\\([^[:blank:]]+\\.[[:alpha:]]+\\):\\([0-9]+\\)\\)"
+ (line-end-position) t)
+
+ (goto-char (match-end 0))
+ (with-silent-modifications
+ (compilation--put-prop 2 'font-lock-face compilation-info-face); file
+ (compilation--put-prop 3 'font-lock-face compilation-line-face); line
+ (put-text-property
+ (match-beginning 0) (match-end 0)
+ 'ada-secondary-error
+ (list
+ (match-string-no-properties 2); file
+ (string-to-number (match-string-no-properties 3)); line
+ 1)); column
+ ))
+
+ (when (search-forward-regexp "\\(at line \\)\\([0-9]+\\)" (line-end-position) t)
+ (with-silent-modifications
+ (compilation--put-prop 1 'font-lock-face compilation-info-face); "at line" instead of file
+ (compilation--put-prop 2 'font-lock-face compilation-line-face); line
+ (put-text-property
+ (match-beginning 1) (match-end 1)
+ 'ada-secondary-error
+ (list
+ file
+ (string-to-number (match-string-no-properties 2)); line
+ 1)); column
+ ))
+ (forward-line 1))
+ ))
+ ))
+
+(defun ada-gnat-debug-filter ()
+ ;; call ada-gnat-compilation-filter with `compilation-filter-start' bound
+ (interactive)
+ (beginning-of-line)
+ (let ((compilation-filter-start (point)))
+ (ada-gnat-compilation-filter)))
+
+;;;;; auto fix compilation errors
+
+(defconst ada-gnat-quoted-name-regexp
+ "\"\\([a-zA-Z0-9_.']+\\)\""
+ "regexp to extract the quoted names in error messages")
+
+(defconst ada-gnat-quoted-punctuation-regexp
+ "\"\\([,:;=()|]+\\)\""
+ "regexp to extract quoted punctuation in error messages")
+
+(defvar ada-gnat-fix-error-hook nil
+ "For `ada-fix-error-alist'.")
+
+(defun ada-gnat-misspelling ()
+ "Return correct spelling from current compiler error, if there are corrections offered.
+Prompt user if more than one."
+ ;; wisi-output.adb:115:41: no selector "Productions" for type "RHS_Type" defined at wisi.ads:77
+ ;; wisi-output.adb:115:41: invalid expression in loop iterator
+ ;; wisi-output.adb:115:42: possible misspelling of "Production"
+ ;; wisi-output.adb:115:42: possible misspelling of "Production"
+ ;;
+ ;; column number can vary, so only check the line number
+
+ (let ((line (progn (beginning-of-line) (nth 1 (compilation--message->loc (ada-get-compilation-message)))))
+ done choices)
+ (while (not done)
+ (forward-line 1)
+ (setq done (or (not (ada-get-compilation-message))
+ (not (equal line (nth 1 (compilation--message->loc (ada-get-compilation-message)))))))
+ (when (and (not done)
+ (progn
+ (skip-syntax-forward "^-")
+ (forward-char 1)
+ (looking-at (concat "possible misspelling of " ada-gnat-quoted-name-regexp))))
+ (push (match-string 1) choices)))
+
+ ;; return correct spelling
+ (cond
+ ((= 0 (length choices))
+ nil)
+
+ ((= 1 (length choices))
+ (car choices))
+
+ (t ;; multiple choices
+ (completing-read "correct spelling: " choices))
+ )))
+
+(defun ada-gnat-fix-error (msg source-buffer source-window)
+ "For `ada-gnat-fix-error-hook'."
+ (let ((start-pos (point))
+ message-column
+ result)
+ ;; Move to start of error message text
+ (skip-syntax-forward "^-")
+ (forward-char 1)
+ (setq message-column (current-column))
+
+ ;; recognize it, handle it
+ (setq
+ result
+ (unwind-protect
+ (cond
+ ;; It is tempting to define an alist of (MATCH . ACTION), but
+ ;; that is too hard to debug
+ ;;
+ ;; This list will get long, so let's impose some order.
+ ;;
+ ;; First expressions that start with a named regexp, alphabetical by variable name.
+ ;;
+ ;; Then expressions that start with a string, alphabetical by string.
+ ;;
+ ;; Then style errors.
+
+ ((looking-at (concat ada-gnat-quoted-name-regexp " is not visible"))
+ (let ((ident (match-string 1))
+ (done nil)
+ (file-line-struct (progn (beginning-of-line) (ada-get-compilation-message)))
+ pos choices unit-name)
+ ;; next line may contain a reference to where ident is
+ ;; defined; if present, it will have been marked by
+ ;; ada-gnat-compilation-filter
+ ;;
+ ;; or the next line may contain "multiple use clauses cause hiding"
+ ;;
+ ;; the lines after that may contain alternate matches;
+ ;; collect all, let user choose.
+ (while (not done)
+ (forward-line 1)
+ (unless (looking-at ".* multiple use clauses cause hiding")
+ (setq done (not
+ (and
+ (equal file-line-struct (ada-get-compilation-message))
+ (let ((limit (1- (line-end-position))))
+ ;; 1- because next compilation error is at next line beginning
+ (setq pos (next-single-property-change (point) 'ada-secondary-error nil limit))
+ (< pos limit)))))
+ (when (not done)
+ (let* ((item (get-text-property pos 'ada-secondary-error))
+ (unit-file (nth 0 item)))
+ (add-to-list 'choices (ada-ada-name-from-file-name unit-file)))))
+ );; while
+
+ (cond
+ ((= 0 (length choices))
+ (setq unit-name nil))
+
+ ((= 1 (length choices))
+ (setq unit-name (car choices)))
+
+ (t ;; multiple choices
+ (setq unit-name
+ (completing-read "package name: " choices)))
+ );; cond
+
+ (when unit-name
+ (pop-to-buffer source-buffer)
+ ;; We either need to add a with_clause for a package, or
+ ;; prepend the package name here (or add a use clause, but I
+ ;; don't want to do that automatically).
+ ;;
+ ;; If we need to add a with_clause, unit-name may be only
+ ;; the prefix of the real package name, but in that case
+ ;; we'll be back after the next compile; no way to get the
+ ;; full package name (without the function/type name) now.
+ ;; Note that we can't use gnat find, because the code
+ ;; doesn't compile.
+ (cond
+ ((looking-at (concat unit-name "\\."))
+ (ada-fix-add-with-clause unit-name))
+ (t
+ (ada-fix-insert-unit-name unit-name)
+ (insert ".")))
+ t) ;; success, else nil => fail
+ ))
+
+ ((or (looking-at (concat ada-gnat-quoted-name-regexp " is undefined"))
+ (looking-at (concat ada-gnat-quoted-name-regexp " is not a predefined library unit")))
+ ;; We either need to add a with_clause for a package, or
+ ;; something is spelled wrong.
+ (save-excursion
+ (let ((unit-name (match-string 1))
+ (correct-spelling (ada-gnat-misspelling)))
+ (if correct-spelling
+ (progn
+ (pop-to-buffer source-buffer)
+ (search-forward unit-name)
+ (replace-match correct-spelling))
+
+ ;; else assume missing with
+ (pop-to-buffer source-buffer)
+ (ada-fix-add-with-clause unit-name))))
+ t)
+
+ ((looking-at (concat ada-gnat-quoted-name-regexp " not declared in " ada-gnat-quoted-name-regexp))
+ (save-excursion
+ (let ((child-name (match-string 1))
+ (correct-spelling (ada-gnat-misspelling)))
+ (if correct-spelling
+ (progn
+ (setq correct-spelling (match-string 1))
+ (pop-to-buffer source-buffer)
+ (search-forward child-name)
+ (replace-match correct-spelling))
+
+ ;; else guess that "child" is a child package, and extend the with_clause
+ (pop-to-buffer source-buffer)
+ (ada-fix-extend-with-clause child-name))))
+ t)
+
+ ((looking-at (concat ada-gnat-quoted-punctuation-regexp
+ " should be "
+ ada-gnat-quoted-punctuation-regexp))
+ (let ((bad (match-string-no-properties 1))
+ (good (match-string-no-properties 2)))
+ (pop-to-buffer source-buffer)
+ (looking-at bad)
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert good))
+ t)
+
+;;;; strings
+ ((looking-at (concat "misspelling of " ada-gnat-quoted-name-regexp))
+ (let ((expected-name (match-string 1)))
+ (pop-to-buffer source-buffer)
+ (looking-at ada-name-regexp)
+ (delete-region (match-beginning 1) (match-end 1))
+ (insert expected-name))
+ t)
+
+ ((looking-at (concat "\"end " ada-name-regexp ";\" expected"))
+ (let ((expected-name (match-string 1)))
+ (pop-to-buffer source-buffer)
+ (if (looking-at (concat "end " ada-name-regexp ";"))
+ (progn
+ (goto-char (match-end 1)) ; just before ';'
+ (delete-region (match-beginning 1) (match-end 1)))
+ ;; else we have just 'end;'
+ (forward-word 1)
+ (insert " "))
+ (insert expected-name))
+ t)
+
+ ((looking-at "expected an access type")
+ (progn
+ (set-buffer source-buffer)
+ (backward-char 1)
+ (when (looking-at "\\.all")
+ (delete-char 4)
+ t)))
+
+ ((looking-at (concat "expected \\(private \\)?type " ada-gnat-quoted-name-regexp))
+ (let ((type (match-string 2)))
+ (forward-line 1)
+ (move-to-column message-column)
+ (when (or (looking-at "found type access")
+ (looking-at "found type .*_Access_Type"))
+ ;; assume just need '.all'
+ (pop-to-buffer source-buffer)
+ (forward-word 1)
+ (insert ".all")
+ t)))
+
+ ((looking-at "extra \".\" ignored")
+ (set-buffer source-buffer)
+ (delete-char 1)
+ t)
+
+ ((looking-at (concat "keyword " ada-gnat-quoted-name-regexp " expected here"))
+ (let ((expected-keyword (match-string 1)))
+ (pop-to-buffer source-buffer)
+ (insert " " expected-keyword))
+ t)
+
+ ((looking-at "\\(?:possible \\)?missing \"with \\([a-zA-Z0-9_.]+\\);")
+ ;; also 'possible missing "with Ada.Text_IO; use Ada.Text_IO"' - ignoring the 'use'
+ (let ((package-name (match-string-no-properties 1)))
+ (pop-to-buffer source-buffer)
+ ;; FIXME (later): should check if prefix is already with'd, extend it
+ (ada-fix-add-with-clause package-name))
+ t)
+
+ ;; must be after above
+ ((looking-at "missing \"\\(.+\\)\"")
+ (let ((stuff (match-string-no-properties 1)))
+ (set-buffer source-buffer)
+ (insert (concat stuff)));; if missing ")", don't need space; otherwise do?
+ t)
+
+ ((looking-at "No legal interpretation for operator")
+ (forward-line 1)
+ (move-to-column message-column)
+ (looking-at (concat "use clause on " ada-gnat-quoted-name-regexp))
+ (let ((package (match-string 1)))
+ (pop-to-buffer source-buffer)
+ (ada-fix-add-use package))
+ t)
+
+ ((looking-at (concat "no selector " ada-gnat-quoted-name-regexp))
+ ;; Check next line for spelling error.
+ (save-excursion
+ (let ((unit-name (match-string 1))
+ (correct-spelling (ada-gnat-misspelling)))
+ (when correct-spelling
+ (pop-to-buffer source-buffer)
+ (search-forward unit-name)
+ (replace-match correct-spelling)
+ t))))
+
+ ((looking-at (concat "operator for \\(private \\)?type " ada-gnat-quoted-name-regexp))
+ (let ((type (match-string 2)))
+ (pop-to-buffer source-buffer)
+ (ada-goto-declarative-region-start)
+ (newline-and-indent)
+ (insert "use type " type ";"))
+ t)
+
+ ((looking-at "parentheses required for unary minus")
+ (set-buffer source-buffer)
+ (insert "(")
+ (forward-word 1)
+ (insert ")")
+ t)
+
+ ((looking-at "prefix of dereference must be an access type")
+ (pop-to-buffer source-buffer)
+ ;; point is after '.' in '.all'
+ (delete-region (- (point) 1) (+ (point) 3))
+ t)
+
+;;;; warnings
+ ((looking-at (concat "warning: " ada-gnat-quoted-name-regexp " is already use-visible"))
+ ;; just delete the 'use'; assume it's on a line by itself.
+ (pop-to-buffer source-buffer)
+ (beginning-of-line)
+ (delete-region (point) (progn (forward-line 1) (point)))
+ t)
+
+ ((looking-at (concat "warning: " ada-gnat-quoted-name-regexp " is not modified, could be declared constant"))
+ (pop-to-buffer source-buffer)
+ (search-forward ":")
+ (forward-comment (- (point-max) (point)))
+ ;; "aliased" must be before "constant", so check for it
+ (when (looking-at "aliased")
+ (forward-word 1)
+ (forward-char 1))
+ (insert "constant ")
+ t)
+
+ ((looking-at (concat "warning: constant " ada-gnat-quoted-name-regexp " is not referenced"))
+ (let ((constant (match-string 1)))
+ (pop-to-buffer source-buffer)
+ (end-of-line)
+ (newline-and-indent)
+ (insert "pragma Unreferenced (" constant ");"))
+ t)
+
+ ((looking-at (concat "warning: formal parameter " ada-gnat-quoted-name-regexp " is not referenced"))
+ (let ((param (match-string 1)))
+ (pop-to-buffer source-buffer)
+ (ada-goto-declarative-region-start)
+ (newline-and-indent)
+ (insert "pragma Unreferenced (" param ");"))
+ t)
+
+ ((looking-at (concat "warning: formal parameter " ada-gnat-quoted-name-regexp " is not modified"))
+ (let ((param (match-string 1))
+ (mode-regexp "\"\\([in out]+\\)\"")
+ new-mode
+ old-mode)
+ (forward-line 1)
+ (search-forward-regexp
+ (concat "mode could be " mode-regexp " instead of " mode-regexp))
+ (setq new-mode (match-string 1))
+ (setq old-mode (match-string 2))
+ (pop-to-buffer source-buffer)
+ (search-forward old-mode)
+ (replace-match new-mode)
+ (ada-align)
+ )
+ t)
+
+ ((or
+ (looking-at (concat "warning: no entities of " ada-gnat-quoted-name-regexp " are referenced$"))
+ (looking-at (concat "warning: unit " ada-gnat-quoted-name-regexp " is never instantiated$"))
+ (looking-at "warning: redundant with clause"))
+ ;; just delete the 'with'; assume it's on a line by itself.
+ (pop-to-buffer source-buffer)
+ (beginning-of-line)
+ (delete-region (point) (progn (forward-line 1) (point)))
+ t)
+
+ ((looking-at (concat "warning: variable " ada-gnat-quoted-name-regexp " is assigned but never read"))
+ (let ((param (match-string 1)))
+ (pop-to-buffer source-buffer)
+ (ada-goto-end)
+ (newline-and-indent)
+ (insert "pragma Unreferenced (" param ");"))
+ t)
+
+ ((looking-at (concat "warning: unit " ada-gnat-quoted-name-regexp " is not referenced$"))
+ ;; just delete the 'with'; assume it's on a line by itself.
+ (pop-to-buffer source-buffer)
+ (beginning-of-line)
+ (delete-region (point) (progn (forward-line 1) (point)))
+ t)
+
+;;;; style errors
+ ((looking-at "(style) \".*\" in wrong column")
+ (progn
+ (set-buffer source-buffer)
+ (funcall indent-line-function))
+ t)
+
+ ((looking-at "(style) bad capitalization, mixed case required")
+ (progn
+ (set-buffer source-buffer)
+ (forward-word)
+ (ada-case-adjust-identifier)
+ t))
+
+ ((looking-at (concat "(style) bad casing of " ada-gnat-quoted-name-regexp))
+ (let ((correct (match-string-no-properties 1))
+ end)
+ ;; gnat leaves point on first bad character, but we need to replace the whole word
+ (set-buffer source-buffer)
+ (skip-syntax-backward "w_")
+ (setq end (point))
+ (skip-syntax-forward "w_")
+ (delete-region (point) end)
+ (insert correct))
+ t)
+
+ ((or
+ (looking-at "(style) bad column")
+ (looking-at "(style) bad indentation")
+ (looking-at "(style) incorrect layout"))
+ (set-buffer source-buffer)
+ (funcall indent-line-function)
+ t)
+
+ ((looking-at "(style) missing \"overriding\" indicator")
+ (set-buffer source-buffer)
+ (cond
+ ((looking-at "\\(procedure\\)\\|\\(function\\)")
+ (insert "overriding ")
+ t)
+ (t
+ nil)))
+
+ ((looking-at "(style) space not allowed")
+ (set-buffer source-buffer)
+ ;; Error places point on space. More than one trailing space
+ ;; should be fixed by delete-trailing-whitespace in
+ ;; before-save-hook, once the file is modified.
+ (delete-char 1)
+ t)
+
+ ((looking-at "(style) space required")
+ (set-buffer source-buffer)
+ (insert " ")
+ t)
+ )));; end of setq unwind-protect cond
+ (if result
+ t
+ (goto-char start-pos)
+ nil)
+ ))
+
+;;;;; setup
+
+(defun ada-gnat-compile-select-prj ()
+ (setq ada-fix-error-hook 'ada-gnat-fix-error-hook)
+ (add-to-list 'completion-ignored-extensions ".ali") ;; gnat library files
+
+ (add-hook 'compilation-filter-hook 'ada-gnat-compilation-filter)
+
+ ;; ada-mode.el project file parser sets this to other compilers used
+ ;; in the project, so we only add here.
+ (add-to-list 'compilation-error-regexp-alist 'gnat)
+ )
+
+(defun ada-gnat-compile-deselect-prj ()
+ (setq ada-fix-error-hook nil)
+ (setq completion-ignored-extensions (delete ".ali" completion-ignored-extensions))
+ (setq compilation-filter-hook (delete 'ada-gnat-compilation-filter compilation-filter-hook))
+ (setq compilation-error-regexp-alist (delete 'gnat compilation-error-regexp-alist))
+ )
+
+(defun ada-gnat-compile ()
+ "Set Ada mode global vars to use 'gnat' for compiling."
+ (add-to-list 'ada-prj-file-ext-extra "gpr")
+ (add-to-list 'ada-prj-parser-alist '("gpr" . gnat-parse-gpr))
+ (add-to-list 'ada-select-prj-compiler '(gnat . ada-gnat-compile-select-prj))
+ (add-to-list 'ada-deselect-prj-compiler '(gnat . ada-gnat-compile-deselect-prj))
+
+ (add-to-list 'ada-prj-parse-one-compiler (cons 'gnat 'gnat-prj-parse-emacs-one))
+ (add-to-list 'ada-prj-parse-final-compiler (cons 'gnat 'gnat-prj-parse-emacs-final))
+
+ (add-hook 'ada-gnat-fix-error-hook 'ada-gnat-fix-error))
+
+(provide 'ada-gnat-compile)
+(provide 'ada-compiler)
+
+(ada-gnat-compile)
+
+(add-to-list
+ 'compilation-error-regexp-alist-alist
+ '(gnat
+ ;; typical:
+ ;; cards_package.adb:45:32: expected private type "System.Address"
+ ;;
+ ;; with full path Source_Reference pragma :
+ ;; d:/maphds/version_x/1773/sbs-abi-dll_lib.ads.gp:39:06: file "interfaces_c.ads" not found
+ ;;
+ ;; gnu cc1: (gnatmake can invoke the C compiler)
+ ;; foo.c:2: `TRUE' undeclared here (not in a function)
+ ;; foo.c:2 : `TRUE' undeclared here (not in a function)
+ "^\\(\\(.:\\)?[^ :\n]+\\):\\([0-9]+\\)\\s-?:?\\([0-9]+\\)?" 1 3 4))
+
+(unless (default-value ada-compiler)
+ (set-default 'ada-compiler 'gnat))
+
+;; end of file