[gnu-emacs-elpa] / packages / ada-mode / ada-mode.el

;;; ada-mode.el --- major-mode for editing Ada sources
;;
;;; Copyright (C) 1994, 1995, 1997 - 2014  Free Software Foundation, Inc.
;;
;; Author: Stephen Leake <stephen_leake@member.fsf.org>
;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
;; Keywords FIXME: languages, ada ELPA broken for multiple keywords
;; Version: 5.1.4
;; package-requires: ((wisi "1.0.4") (cl-lib "0.4") (emacs "24.2"))
;; url: http://stephe-leake.org/emacs/ada-mode/emacs-ada-mode.html
;;
;; (Gnu ELPA requires single digits between dots in versions)
;;
;; 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.  The default extensions for Ada
;; files are .ads, .adb; use ada-add-extensions to add other
;; extensions.
;;
;; By default, ada-mode is configured to take full advantage of the
;; GNAT compiler.  If you are using another compiler, you
;; should load that compiler's ada-* file first; that will define
;; ada-compiler as a feature, so ada-gnat.el will not be loaded.
;;
;; See the user guide (info "ada-mode"), built from ada-mode.texi.

;;; Design:
;;
;; In order to support multiple compilers, we use indirect function
;; calls for all operations that depend on the compiler.
;;
;; We also support a cross reference tool (also called xref tool) that
;; is different from the compiler. For example, you can use a local
;; GNAT compiler to generate and access cross-reference information,
;; while using a cross-compiler for compiling the final executable.
;;
;; Other functions are lumped with the choice of xref tool; mapping
;; Ada names to file names, creating package bodies; any tool function
;; that does not create executable code.
;;
;; The indentation engine and skeleton tools are also called
;; indirectly, to allow parallel development of new versions of these
;; tools (inspired by experience with ada-smie and ada-wisi).
;;
;; We also support using different compilers for different projects;
;; `ada-compiler' can be set in Ada mode project files.  Note that
;; there is only one project active at a time; the most recently
;; selected one. All Ada files are assumed to belong to this project
;; (which is not correct, but works well in practice; the user is
;; typically only concerned about files that belong to the current
;; project).
;;
;; There are several styles of indirect calls:
;;
;; - scalar global variable set during load
;;
;;   Appropriate when the choice of implementation is fixed at load
;;   time; it does not depend on the current Ada project. Used for
;;   indentation and skeleton functions.
;;
;; - scalar global variable set during project select
;;
;;   Appropriate when the choice of implementation is determined by
;;   the choice of compiler or xref tool, which is per-project.  The
;;   user sets the compiler choice in the project file, but not the
;;   lower-level redirect choice.
;;
;;   For example, `ada-file-name-from-ada-name' depends on the naming
;;   convention used by the compiler. If the project file sets
;;   ada_compiler to 'gnat (either directly or by default),
;;   ada-gnat-select-prj sets `ada-file-name-from-ada-name' to
;;   `ada-gnat-file-name-from-ada-name'.
;;
;; - scalar buffer-local variable set during project select or file open
;;
;;   Appropriate when choice of implementation is normally
;;   per-project, but can be per-buffer.
;;
;;   For example, `ada-case-strict' will normally be set by the
;;   project, but some files may deviate from the project standard (if
;;   they are generated by -fdumpspec, for example). Those files set
;;   `ada-case-strict' in a file local variable comment.
;;
;; - scalar buffer-local variable set by ada-mode or ada-mode-hook
;;   function
;;
;;   Appropriate when the variable is a non-Ada mode variable, also
;;   used by other modes, and choice should not affect those modes.
;;
;;   `indent-line-function', `comment-indent-function' use this style
;;
;; - alist global variable indexed by ada-compiler
;;
;;   Appropriate when the choice of implementation is determined by
;;   the compiler, but the function is invoked during project parse,
;;   so we can't depend on a value set by project select.
;;
;;   alist entries are set during load by the implementation elisp files.
;;
;;   `ada-prj-default-compiler-alist' uses this style.

;;; History:
;;
;; The first Ada mode for GNU Emacs was written by V. Broman in
;; 1985. He based his work on the already existing Modula-2 mode.
;; This was distributed as ada.el in versions of Emacs prior to 19.29.
;;
;; Lynn Slater wrote an extensive Ada mode in 1989. It consisted of
;; several files with support for dired commands and other nice
;; things.
;;
;; The probably very first Ada mode (called electric-ada.el) was
;; written by Steven D. Litvintchouk and Steven M. Rosen for the
;; Gosling Emacs. L. Slater based his development on ada.el and
;; electric-ada.el.
;;
;; A complete rewrite by Rolf Ebert <ebert@inf.enst.fr> and Markus
;; Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> was done at
;; some point.  Some ideas from the Ada mode mailing list have been
;; added.  Some of the functionality of L. Slater's mode has not (yet)
;; been recoded in this new mode.
;;
;; A complete rewrite for Emacs-20 / GNAT-3.11 was done by Emmanuel
;; Briot <briot@gnat.com> at Ada Core Technologies.
;;
;; A complete rewrite, to restructure the code more orthogonally, and
;; to use wisi for the indentation engine, was done in 2012 - 2013 by
;; Stephen Leake <stephen_leake@stephe-leake.org>.

;;; Credits:
;;
;;   Many thanks to John McCabe <john@assen.demon.co.uk> for sending so
;;     many patches included in this package.
;;   Christian Egli <Christian.Egli@hcsd.hac.com>:
;;     ada-imenu-generic-expression
;;   Many thanks also to the following persons that have contributed
;;   to the ada-mode
;;     Philippe Waroquiers (PW) <philippe@cfmu.eurocontrol.be> in particular,
;;     woodruff@stc.llnl.gov (John Woodruff)
;;     jj@ddci.dk (Jesper Joergensen)
;;     gse@ocsystems.com (Scott Evans)
;;     comar@gnat.com (Cyrille Comar)
;;     robin-reply@reagans.org
;;    and others for their valuable hints.

(require 'align)
(require 'cl-lib)
(require 'compile)
(require 'find-file)

(defun ada-mode-version ()
  "Return Ada mode version."
  (interactive)
  (let ((version-string "5.1.4"))
    ;; must match:
    ;; ada-mode.texi
    ;; README
    ;; Version: above
    (if (called-interactively-p 'interactive)
        (message version-string)
      version-string)))

;;;;; User variables

(defvar ada-mode-hook nil
  "List of functions to call when Ada mode is invoked.
This hook is executed after `ada-mode' is fully loaded, but
before file local variables are processed.")

(defgroup ada nil
  "Major mode for editing Ada source code in Emacs."
  :group 'languages)

(defcustom ada-auto-case t
  ;; can be per-buffer
  "Buffer-local value that may override project variable `auto_case'.
Global value is default for project variable `auto_case'.
Non-nil means automatically change case of preceding word while typing.
Casing of Ada keywords is done according to `ada-case-keyword',
identifiers are Mixed_Case."
  :type  'boolean
  :group 'ada
  :safe  'booleanp)
(make-variable-buffer-local 'ada-auto-case)

(defcustom ada-case-exception-file nil
  "Default list of special casing exceptions dictionaries for identifiers.
Override with 'casing' project variable.

New exceptions may be added interactively via `ada-case-create-exception'.
If an exception is defined in multiple files, the first occurence is used.

The file format is one word per line, that gives the casing to be
used for that word in Ada source code.  If the line starts with
the character *, then the exception will be used for partial
words that either start at the beginning of a word or after a _
character, and end either at the end of the word or at a _
character.  Characters after the first word are ignored, and not
preserved when the list is written back to the file."
  :type  '(repeat (file))
  :group 'ada
  :safe  'listp)

(defcustom ada-case-keyword 'downcase-word
  "Buffer-local value that may override project variable `case_keyword'.
Global value is default for project variable `case_keyword'.
Function to call to adjust the case of Ada keywords."
  :type '(choice (const downcase-word)
                 (const upcase-word))
  :group 'ada
  :safe  'functionp)
(make-variable-buffer-local 'ada-case-keyword)

(defcustom ada-case-identifier 'ada-mixed-case
  "Buffer-local value that may override project variable `case_keyword'.
Global value is default for project variable `case_keyword'.
Function to call to adjust the case of Ada keywords."
  :type '(choice (const ada-mixed-case)
                 (const downcase-region)
                 (const upcase-region))
  :group 'ada
  :safe  'functionp)
(make-variable-buffer-local 'ada-case-identifier)

(defcustom ada-case-strict t
  "Buffer-local value that may override project variable `case_strict'.
Global value is default for project variable `case_strict'.
If non-nil, force Mixed_Case for identifiers.
Otherwise, allow UPPERCASE for identifiers."
  :type 'boolean
  :group 'ada
  :safe  'booleanp)
(make-variable-buffer-local 'ada-case-strict)

(defcustom ada-language-version 'ada2012
  "Ada language version; one of `ada83', `ada95', `ada2005', `ada2012'.
Only affects the keywords to highlight, not which version the
indentation parser accepts."
  :type '(choice (const ada83)
                 (const ada95)
                 (const ada2005)
                 (const ada2012))
  :group 'ada
  :safe  'symbolp)
(make-variable-buffer-local 'ada-language-version)

(defcustom ada-fill-comment-prefix "-- "
  "Comment fill prefix."
  :type 'string
  :group 'ada)
(make-variable-buffer-local 'ada-language-version)

(defcustom ada-fill-comment-postfix " --"
  "Comment fill postfix."
  :type 'string
  :group 'ada)
(make-variable-buffer-local 'ada-language-version)

(defcustom ada-prj-file-extensions '("adp" "prj")
  "List of Emacs Ada mode project file extensions.
Used when searching for a project file.
Any file with one of these extensions will be parsed by `ada-prj-parse-file-1'."
  :type 'list
  :group 'ada)

(defcustom ada-prj-file-ext-extra nil
  "List of secondary project file extensions.
Used when searching for a project file that can be a primary or
secondary project file (referenced from a primary).  The user
must provide a parser for a file with one of these extensions."
  :type 'list
  :group 'ada)

;;;;; end of user variables

(defconst ada-symbol-end
  ;; we can't just add \> here; that might match _ in a user modified ada-mode-syntax-table
  "\\([ \t]+\\|$\\)"
  "Regexp to add to symbol name in `ada-which-function'.")

(defvar ada-compiler nil
  "Default Ada compiler; can be overridden in project files.
Values defined by compiler packages.")

(defvar ada-xref-tool nil
  "Default Ada cross reference tool; can be overridden in project files.
Values defined by cross reference packages.")

;;;; keymap and menus

(defvar ada-ret-binding nil)
(defvar ada-lfd-binding nil)

(defun ada-case-activate-keys ()
  "Modify the key bindings for all the keys that should adjust casing."
  (interactive)
  ;; We can't use post-self-insert-hook for \n, \r, because they are
  ;; not self-insert.

  ;; The 'or ...' is there to be sure that the value will not be
  ;; changed again when this is called more than once, since we
  ;; are rebinding the keys.
  (or ada-ret-binding (setq ada-ret-binding (key-binding "\C-M")))
  (or ada-lfd-binding (setq ada-lfd-binding (key-binding "\C-j")))

  (mapc (function
         (lambda(key)
           (define-key
             ada-mode-map
             (char-to-string key)
             'ada-case-adjust-interactive)))
        '( ?_ ?% ?& ?* ?( ?) ?- ?= ?+
              ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?/ ?\n 32 ?\r ))

  (define-key ada-mode-map [return] 'ada-case-adjust-interactive)
  )

(defvar ada-mode-map
  (let ((map (make-sparse-keymap)))
    ;; C-c <letter> are reserved for users

    ;; global-map has C-x ` 'next-error
    (define-key map [return]     'ada-indent-newline-indent)
    (define-key map "\C-c`"      'ada-show-secondary-error)
    (define-key map "\C-c;"      (lambda () (error "use M-; instead"))) ; comment-dwim
    (define-key map "\C-c\M-`"   'ada-fix-compiler-error)
    (define-key map "\C-c\C-a"   'ada-align)
    (define-key map "\C-c\C-b"   'ada-make-subprogram-body)
    (define-key map "\C-c\C-c"   'ada-build-make)
    (define-key map "\C-c\C-d"   'ada-goto-declaration)
    (define-key map "\C-c\M-d"   'ada-show-declaration-parents)
    (define-key map "\C-c\C-e"   'ada-expand)
    (define-key map "\C-c\C-f"   'ada-show-parse-error)
    (define-key map "\C-c\C-i"   'ada-indent-statement)
    (define-key map "\C-c\C-m"   'ada-build-set-make)
    (define-key map "\C-c\C-n"   'ada-next-statement-keyword)
    (define-key map "\C-c\C-o"   'ada-find-other-file)
    (define-key map "\C-c\M-o"   'ada-find-other-file-noset)
    (define-key map "\C-c\C-p"   'ada-prev-statement-keyword)
    (define-key map "\C-c\C-q"   'ada-xref-refresh)
    (define-key map "\C-c\C-r"   'ada-show-references)
    (define-key map "\C-c\M-r"   'ada-build-run)
    (define-key map "\C-c\C-s"   'ada-goto-previous-pos)
    (define-key map "\C-c\C-v"   'ada-build-check)
    (define-key map "\C-c\C-w"   'ada-case-adjust-at-point)
    (define-key map "\C-c\C-x"   'ada-show-overriding)
    (define-key map "\C-c\M-x"   'ada-show-overridden)
    (define-key map "\C-c\C-y"   'ada-case-create-exception)
    (define-key map "\C-c\M-y"   'ada-case-create-partial-exception)
    (define-key map [C-down-mouse-3] 'ada-popup-menu)

    map
  )  "Local keymap used for Ada mode.")

(defvar ada-mode-menu (make-sparse-keymap "Ada"))
(easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode"
  '("Ada"
    ("Help"
     ["Ada Mode"             (info "ada-mode") t]
     ["Ada Reference Manual" (info "arm2012") t]
     ["Key bindings"         describe-bindings t]
     )
    ["Customize"                  (customize-group 'ada)    t]
    ("Project files"
     ["Find and select project ..."   ada-build-prompt-select-prj-file t]
     ["Select project ..."            ada-prj-select                   t]
     ["Show project"                  ada-prj-show                     t]
    )
    ("Build"
     ["Next compilation error"     next-error                t]
     ["Show secondary error"       ada-show-secondary-error  t]
     ["Fix compilation error"      ada-fix-compiler-error    t]
     ["Show last parse error"      ada-show-parse-error      t]
     ["Check syntax"               ada-build-check       t]
     ["Show main"                  ada-build-show-main   t]
     ["Build"                      ada-build-make        t]
     ["Set main and Build"         ada-build-set-make    t]
     ["Run"                        ada-build-run         t]
     )
    ("Navigate"
     ["Other file"                    ada-find-other-file          t]
     ["Other file don't find decl"    ada-find-other-file-noset    t]
     ["Goto declaration/body"         ada-goto-declaration         t]
     ["Goto next statement keyword"   ada-next-statement-keyword   t]
     ["Goto prev statement keyword"   ada-next-statement-keyword   t]
     ["Show parent declarations"      ada-show-declaration-parents t]
     ["Show references"               ada-show-references          t]
     ["Show overriding"               ada-show-overriding          t]
     ["Show overridden"               ada-show-overridden          t]
     ["Goto prev position"            ada-goto-previous-pos        t]
     )
    ("Edit"
     ["Expand skeleton"             ada-expand              t]
     ["Indent line or selection"    indent-for-tab-command  t]
     ["Indent current statement"    ada-indent-statement    t]
     ["Indent lines in file"        (indent-region (point-min) (point-max))  t]
     ["Align"                       ada-align               t]
     ["Comment/uncomment selection" comment-dwim            t]
     ["Fill comment paragraph"         ada-fill-comment-paragraph           t]
     ["Fill comment paragraph justify" (ada-fill-comment-paragraph 'full)   t]
     ["Fill comment paragraph postfix" (ada-fill-comment-paragraph 'full t) t]
     ["Make body for subprogram"    ada-make-subprogram-body     t]
     )
    ("Casing"
     ["Create full exception"       ada-case-create-exception t]
     ["Create partial exception"    ada-case-create-partial-exception t]
     ["Adjust case at point"        ada-case-adjust-at-point  t]
     ["Adjust case region"          ada-case-adjust-region    t]
     ["Adjust case buffer"          ada-case-adjust-buffer    t]
     )
    ("Misc"
     ["Show last parse error"         ada-show-parse-error         t]
     ["Show xref tool buffer"         ada-show-xref-tool-buffer    t]
     ["Refresh cross reference cache" ada-xref-refresh             t]
     ["Reset parser"                  ada-reset-parser             t]
     )))
(ada-case-activate-keys)

;; This doesn't need to be buffer-local because there can be only one
;; popup menu at a time.
(defvar ada-context-menu-on-identifier nil)

(easy-menu-define ada-context-menu nil
  "Context menu keymap for Ada mode"
  '("Ada"
    ["Make body for subprogram"      ada-make-subprogram-body     t]
    ["Goto declaration/body"         ada-goto-declaration         :included ada-context-menu-on-identifier]
    ["Show parent declarations"      ada-show-declaration-parents :included ada-context-menu-on-identifier]
    ["Show references"               ada-show-references          :included ada-context-menu-on-identifier]
    ["Show overriding"               ada-show-overriding          :included ada-context-menu-on-identifier]
    ["Show overridden"               ada-show-overridden          :included ada-context-menu-on-identifier]
    ["Expand skeleton"               ada-expand                        t]
    ["Create full case exception"    ada-case-create-exception         t]
    ["Create partial case exception" ada-case-create-partial-exception t]

    ["-"                nil nil]
    ["Align"                       ada-align                  t]
    ["Adjust case at point"        ada-case-adjust-at-point   (not (use-region-p))]
    ["Adjust case region"          ada-case-adjust-region     (use-region-p)]
    ["Indent current statement"    ada-indent-statement       t]
    ["Goto next statement keyword" ada-next-statement-keyword t]
    ["Goto prev statement keyword" ada-next-statement-keyword t]
    ["Other File"                  ada-find-other-file        t]
    ["Other file don't find decl"  ada-find-other-file-noset  t]))

(defun ada-popup-menu (position)
  "Pops up a `ada-context-menu', with `ada-context-menu-on-identifer' set appropriately.
POSITION is the location the mouse was clicked on.
Sets `ada-context-menu-last-point' to the current position before
displaying the menu.  When a function from the menu is called,
point is where the mouse button was clicked."
  (interactive "e")

  (mouse-set-point last-input-event)

  (setq ada-context-menu-on-identifier
        (and (char-after)
             (or (= (char-syntax (char-after)) ?w)
                 (= (char-after) ?_))
             (not (ada-in-string-or-comment-p))
             (save-excursion (skip-syntax-forward "w")
                             (not (ada-after-keyword-p)))
             ))
    (popup-menu ada-context-menu)
    )

(defun ada-indent-newline-indent ()
  "insert a newline, indent the old and new lines."
  (interactive "*")
  ;; point may be in the middle of a word, so insert newline first,
  ;; then go back and indent.
  (newline)
  (forward-char -1)
  (funcall indent-line-function)
  (forward-char 1)
  (funcall indent-line-function))

(defvar ada-indent-statement nil
  ;; indentation function
  "Function to indent the statement/declaration point is in or after.
Function is called with no arguments.")

(defun ada-indent-statement ()
  "Indent current statement."
  (interactive)
  (when ada-indent-statement
    (funcall ada-indent-statement)))

(defvar ada-expand nil
  ;; skeleton function
  "Function to call to expand tokens (ie insert skeletons).")

(defun ada-expand ()
  "Expand previous word into a statement skeleton."
  (interactive)
  (when ada-expand
    (funcall ada-expand)))

;;;; abbrev, align

(defvar ada-mode-abbrev-table nil
  "Local abbrev table for Ada mode.")

(defvar ada-align-rules
  '((ada-declaration-assign
     (regexp  . "[^:]\\(\\s-*\\)\\(:\\)[^:]")
     (valid   . (lambda () (ada-align-valid)))
     (repeat . t)
     (modes   . '(ada-mode)))
    (ada-associate
     (regexp  . "[^=]\\(\\s-*\\)\\(=>\\)")
     (valid   . (lambda () (ada-align-valid)))
     (modes   . '(ada-mode)))
    (ada-comment
     (regexp  . "\\(\\s-*\\)--")
     (valid   . (lambda () (ada-align-valid)))
     (modes   . '(ada-mode)))
    (ada-use
     (regexp  . "\\(\\s-*\\)\\<\\(use\\s-\\)")
     (valid   . (lambda () (ada-align-valid)))
     (modes   . '(ada-mode)))
    (ada-at
     (regexp . "\\(\\s-+\\)\\(at\\)\\>")
     (valid   . (lambda () (ada-align-valid)))
     (modes . '(ada-mode))))
  "Rules to use to align different lines.")

(defun ada-align-valid ()
  "See use in `ada-align-rules'."
  (save-excursion
    ;; we don't put "when (match-beginning n)" here; missing a match
    ;; is a bug in the regexp.
    (goto-char (or (match-beginning 2) (match-beginning 1)))
    (not (ada-in-string-or-comment-p))))

(defconst ada-align-region-separate
  (eval-when-compile
    (concat
     "^\\s-*\\($\\|\\("
     "begin\\|"
     "declare\\|"
     "else\\|"
     "end\\|"
     "exception\\|"
     "for\\|"
     "function\\|"
     "generic\\|"
     "if\\|"
     "is\\|"
     "procedure\\|"
     "private\\|"
     "record\\|"
     "return\\|"
     "type\\|"
     "when"
     "\\)\\>\\)"))
  "See the variable `align-region-separate' for more information.")

(defun ada-align ()
  "If region is active, apply 'align'. If not, attempt to align
current construct."
  (interactive)
  (if (use-region-p)
      (progn
        (align (region-beginning) (region-end))
        (deactivate-mark))

    ;; else see if we are in a construct we know how to align
    (cond
     ((ada-in-paramlist-p)
        (ada-format-paramlist))

     (t
      (align-current))
     )))

(defvar ada-in-paramlist-p nil
  ;; Supplied by indentation engine parser
  "Function to return t if point is inside the parameter-list of a subprogram declaration.
Function is called with no arguments.")

(defun ada-in-paramlist-p ()
  "Return t if point is inside the parameter-list of a subprogram declaration."
  (when ada-in-paramlist-p
    (funcall ada-in-paramlist-p)))

(defun ada-format-paramlist ()
  "Reformat the parameter list point is in."
  (interactive)
  (ada-goto-open-paren)
  (funcall indent-line-function); so new list is indented properly

  (let* ((inibit-modification-hooks t)
         (begin (point))
         (delend (progn (forward-sexp) (point))); just after matching closing paren
         (end (progn (backward-char) (forward-comment (- (point))) (point))); end of last parameter-declaration
         (multi-line (> end (save-excursion (goto-char begin) (line-end-position))))
         (paramlist (ada-scan-paramlist (1+ begin) end)))

    (when paramlist
      ;; delete the original parameter-list
      (delete-region begin delend)

      ;; insert the new parameter-list
      (goto-char begin)
      (if multi-line
          (ada-insert-paramlist-multi-line paramlist)
        (ada-insert-paramlist-single-line paramlist)))
    ))

(defvar ada-scan-paramlist nil
  ;; Supplied by indentation engine parser
  "Function to scan a region, return a list of subprogram parameter declarations (in inverse declaration order).
Function is called with two args BEGIN END (the region).
Each parameter declaration is represented by a list
'((identifier ...) in-p out-p not-null-p access-p constant-p protected-p type default)."
  ;; mode is 'in | out | in out | [not null] access [constant | protected]'
  ;; IMPROVEME: handle single-line trailing comments, or longer comments, in paramlist?
  )

(defun ada-scan-paramlist (begin end)
  (when ada-scan-paramlist
    (funcall ada-scan-paramlist begin end)))

(defun ada-insert-paramlist-multi-line (paramlist)
  "Insert a multi-line formatted PARAMLIST in the buffer."
  (let ((i (length paramlist))
        param
        j
        len
        (ident-len 0)
        (type-len 0)
        (in-p nil)
        (out-p nil)
        (not-null-p nil)
        (access-p nil)
        ident-col
        colon-col
        out-col
        type-col
        default-col)

    ;; accumulate info across all params
    (while (not (zerop i))
      (setq i (1- i))
      (setq param (nth i paramlist))

      ;; identifier list
      (setq len 0
            j   0)
      (mapc (lambda (ident)
              (setq j (1+ j))
              (setq len (+ len (length ident))))
            (nth 0 param))
      (setq len (+ len (* 2 (1- j)))); space for commas
      (setq ident-len (max ident-len len))

      ;; we align the defaults after the types that have defaults, not after all types.
      ;; "constant", "protected" are treated as part of 'type'
      (when (nth 8 param)
        (setq type-len
              (max type-len
                   (+ (length (nth 7 param))
                      (if (nth 5 param) 10 0); "constant "
                      (if (nth 6 param) 10 0); protected
                      ))))

      (setq in-p (or in-p (nth 1 param)))
      (setq out-p (or out-p (nth 2 param)))
      (setq not-null-p (or not-null-p (nth 3 param)))
      (setq access-p (or access-p (nth 4 param)))
      )

    (let ((space-before-p (save-excursion (skip-chars-backward " \t") (not (bolp))))
          (space-after-p (save-excursion (skip-chars-forward " \t") (not (or (= (char-after) ?\;) (eolp))))))
      (when space-before-p
        ;; paramlist starts on same line as subprogram identifier; clean
        ;; up whitespace. Allow for code on same line as closing paren
        ;; ('return' or ';').
        (skip-syntax-forward " ")
        (delete-char (- (skip-syntax-backward " ")))
        (if space-after-p
            (progn
              (insert "  ")
              (forward-char -1))
          (insert " "))
        ))

    (insert "(")

    ;; compute columns.
    (setq ident-col (current-column))
    (setq colon-col (+ ident-col ident-len 1))
    (setq out-col (+ colon-col (if in-p 5 0))); ": in "
    (setq type-col
          (+ colon-col
             (cond
              (not-null-p 18);    ": not null access "
              (access-p 9);        ": access"
              ((and in-p out-p) 9); ": in out "
              (out-p 6);           ": out "
              (in-p 5);            ": in "
              (t 2))));           ": "

    (setq default-col (+ 1 type-col type-len))

    (setq i (length paramlist))
    (while (not (zerop i))
      (setq i (1- i))
      (setq param (nth i paramlist))

      ;; insert identifiers, space and colon
      (mapc (lambda (ident)
              (insert ident)
              (insert ", "))
            (nth 0 param))
      (delete-char -2); last ", "
      (indent-to colon-col)
      (insert ": ")

      (when (nth 1 param)
        (insert "in "))

      (when (nth 2 param)
        (indent-to out-col)
        (insert "out "))

      (when (nth 3 param)
        (insert "not null "))

      (when (nth 4 param)
        (insert "access "))

      (indent-to type-col)
      (when (nth 5 param)
        (insert "constant "))
      (when (nth 6 param)
        (insert "protected "))
      (insert (nth 7 param)); type

      (when (nth 8 param); default
        (indent-to default-col)
        (insert ":= ")
        (insert (nth 8 param)))

      (if (zerop i)
          (insert ")")
        (insert ";")
        (newline)
        (indent-to ident-col))
      )
    ))

(defun ada-insert-paramlist-single-line (paramlist)
  "Insert a single-line formatted PARAMLIST in the buffer."
  (let ((i (length paramlist))
        param)

    ;; clean up whitespace
    (skip-syntax-forward " ")
    (delete-char (- (skip-syntax-backward " ")))
    (insert " (")

    (setq i (length paramlist))
    (while (not (zerop i))
      (setq i (1- i))
      (setq param (nth i paramlist))

      ;; insert identifiers, space and colon
      (mapc (lambda (ident)
              (insert ident)
              (insert ", "))
            (nth 0 param))
      (delete-char -2); last ", "

      (insert " : ")

      (when (nth 1 param)
        (insert "in "))

      (when (nth 2 param)
        (insert "out "))

      (when (nth 3 param)
        (insert "not null "))

      (when (nth 4 param)
        (insert "access "))

      (when (nth 5 param)
        (insert "constant "))
      (when (nth 6 param)
        (insert "protected "))
      (insert (nth 7 param)); type

      (when (nth 8 param); default
        (insert " := ")
        (insert (nth 8 param)))

      (if (zerop i)
          (if (= (char-after) ?\;)
              (insert ")")
            (insert ") "))
        (insert "; "))
      )
    ))

(defvar ada-reset-parser nil
  ;; Supplied by indentation engine parser
  "Function to reset parser, to clear confused state."
  )

(defun ada-reset-parser ()
  (interactive)
  (when ada-reset-parser
    (funcall ada-reset-parser)))

(defvar ada-show-parse-error nil
  ;; Supplied by indentation engine parser
  "Function to show last error reported by indentation parser."
  )

(defun ada-show-parse-error ()
  (interactive)
  (when ada-show-parse-error
    (funcall ada-show-parse-error)))

;;;; auto-casing

(defvar ada-case-full-exceptions '()
  "Alist of words (entities) that have special casing, built from
`ada-case-exception-file' full word exceptions. Indexed by
properly cased word; value is t.")

(defvar ada-case-partial-exceptions '()
  "Alist of partial words that have special casing, built from
`ada-case-exception-file' partial word exceptions. Indexed by
properly cased word; value is t.")

(defun ada-case-save-exceptions (full-exceptions partial-exceptions file-name)
  "Save FULL-EXCEPTIONS, PARTIAL-EXCEPTIONS to the file FILE-NAME."
  (with-temp-file (expand-file-name file-name)
    (mapc (lambda (x) (insert (car x) "\n"))
          (sort (copy-sequence full-exceptions)
                (lambda(a b) (string< (car a) (car b)))))
    (mapc (lambda (x) (insert "*" (car x) "\n"))
          (sort (copy-sequence partial-exceptions)
                (lambda(a b) (string< (car a) (car b)))))
    ))

(defun ada-case-read-exceptions (file-name)
  "Read the content of the casing exception file FILE-NAME.
Return (cons full-exceptions partial-exceptions)."
  (setq file-name (expand-file-name (substitute-in-file-name file-name)))
  (if (file-readable-p file-name)
      (let (full-exceptions partial-exceptions word)
        (with-temp-buffer
          (insert-file-contents file-name)
          (while (not (eobp))

            (setq word (buffer-substring-no-properties
                        (point) (save-excursion (skip-syntax-forward "w_") (point))))

            (if (char-equal (string-to-char word) ?*)
                ;; partial word exception
                (progn
                  (setq word (substring word 1))
                  (unless (assoc-string word partial-exceptions t)
                    (add-to-list 'partial-exceptions (cons word t))))

              ;; full word exception
              (unless (assoc-string word full-exceptions t)
                (add-to-list 'full-exceptions (cons word t))))

            (forward-line 1))
          )
        (cons full-exceptions partial-exceptions))

    ;; else file not readable; might be a new project with no
    ;; exceptions yet, so just warn user, return empty pair
    (message "'%s' is not a readable file." file-name)
    '(nil . nil)
    ))

(defun ada-case-merge-exceptions (result new)
  "Merge NEW exeptions into RESULT.
An item in both lists has the RESULT value."
  (dolist (item new)
    (unless (assoc-string (car item) result t)
      (add-to-list 'result item)))
  result)

(defun ada-case-merge-all-exceptions (exceptions)
  "Merge EXCEPTIONS into `ada-case-full-exceptions', `ada-case-partial-exceptions'."
  (setq ada-case-full-exceptions (ada-case-merge-exceptions ada-case-full-exceptions (car exceptions)))
  (setq ada-case-partial-exceptions (ada-case-merge-exceptions ada-case-partial-exceptions (cdr exceptions))))

(defun ada-case-read-all-exceptions ()
  "Read case exceptions from all files in `ada-case-exception-file',
replacing current values of `ada-case-full-exceptions', `ada-case-partial-exceptions'."
  (interactive)
  (setq ada-case-full-exceptions '()
        ada-case-partial-exceptions '())

  (when (ada-prj-get 'casing)
    (dolist (file (ada-prj-get 'casing))
      (ada-case-merge-all-exceptions (ada-case-read-exceptions file))))
  )

(defun ada-case-add-exception (word exceptions)
  "Add case exception WORD to EXCEPTIONS, replacing current entry, if any."
  (if (assoc-string word exceptions t)
      (setcar (assoc-string word exceptions t) word)
    (add-to-list 'exceptions (cons word t)))
  exceptions)

(defun ada-case-create-exception (&optional word file-name partial)
  "Define WORD as an exception for the casing system, save it in FILE-NAME.
If PARTIAL is non-nil, create a partial word exception.  WORD
defaults to the active region, or the word at point.  User is
prompted to choose a file from project variable casing if it is a
list."
  (interactive)
  (let ((casing (ada-prj-get 'casing)))
    (setq file-name
          (cond
           (file-name file-name)

           ((< 1 (length casing))
            (completing-read "case exception file: " casing
                             nil ;; predicate
                             t   ;; require-match
                             nil ;; initial-input
                             nil ;; hist
                             (car casing) ;; default
                             ))
           ((= 1 (length casing))
            (car casing))

           (t
            (if ada-prj-current-file
                (error "No exception file specified; set `casing' in project file.")
              ;; IMPROVEME: could prompt, but then need to write to actual project file
              ;;        (let ((temp
              ;;               (read-file-name
              ;;                "No exception file specified; adding to project. file: ")))
              ;;          (message "remember to add %s to project file" temp)
              ;;          (ada-prj-put 'casing temp)
              ;;          temp)
              (error "No exception file specified, and no project active. See variable `ada-case-exception-file'.")))
           )))

  (unless word
    (if (use-region-p)
        (setq word (buffer-substring-no-properties (region-beginning) (region-end)))
      (save-excursion
        (skip-syntax-backward "w_")
        (setq word
              (buffer-substring-no-properties
               (point)
               (progn (skip-syntax-forward "w_") (point))
               )))))

  (let* ((exceptions (ada-case-read-exceptions file-name))
         (full-exceptions (car exceptions))
         (partial-exceptions (cdr exceptions)))

    (cond
     ((null partial)
      (setq ada-case-full-exceptions (ada-case-add-exception word ada-case-full-exceptions))
      (setq full-exceptions (ada-case-add-exception word full-exceptions)))

     (t
      (setq ada-case-partial-exceptions (ada-case-add-exception word ada-case-partial-exceptions))
      (setq partial-exceptions (ada-case-add-exception word partial-exceptions)))
     )
    (ada-case-save-exceptions full-exceptions partial-exceptions file-name)
    (message "created %s case exception '%s' in file '%s'"
             (if partial "partial" "full")
             word
             file-name)
    ))

(defun ada-case-create-partial-exception ()
  "Define active region or word at point as a partial word exception.
User is prompted to choose a file from project variable casing if it is a list."
  (interactive)
  (ada-case-create-exception nil nil t))

(defun ada-in-numeric-literal-p ()
  "Return t if point is after a prefix of a numeric literal."
  (looking-back "\\([0-9]+#[0-9a-fA-F_]+\\)"))

(defvar ada-keywords nil
  "List of Ada keywords for current `ada-language-version'.")

(defun ada-after-keyword-p ()
  "Return non-nil if point is after an element of `ada-keywords'."
  (let ((word (buffer-substring-no-properties
               (save-excursion (skip-syntax-backward "w_") (point))
               (point))))
    (member (downcase word) ada-keywords)))

(defun ada-mixed-case (start end)
  "Adjust case of region START END to Mixed_Case."
  (let ((done nil)
        next)
    (if ada-case-strict
        (downcase-region start end))
    (goto-char start)
    (while (not done)
      (setq next
            (or
             (save-excursion (when (search-forward "_" end t) (point-marker)))
             (copy-marker (1+ end))))

      ;; upcase first char
      (insert-char (upcase (following-char)) 1)
      (delete-char 1)

      (goto-char next)
      (if (< (point) end)
          (setq start (point))
        (setq done t))
      )))

(defun ada-case-adjust-identifier ()
  "Adjust case of the previous word as an identifier.
Uses `ada-case-identifier', with exceptions defined in
`ada-case-full-exceptions', `ada-case-partial-exceptions'."
  (interactive)
  (save-excursion
    (let ((end   (point-marker))
          (start (progn (skip-syntax-backward "w_") (point)))
          match
          next
          (done nil))

      (if (setq match (assoc-string (buffer-substring-no-properties start end) ada-case-full-exceptions t))
          ;; full word exception
          (progn
            ;; 'save-excursion' puts a marker at 'end'; if we do
            ;; 'delete-region' first, it moves that marker to 'start',
            ;; then 'insert' inserts replacement text after the
            ;; marker, defeating 'save-excursion'. So we do 'insert' first.
            (insert (car match))
            (delete-region (point) end))

        ;; else apply ada-case-identifier
        (funcall ada-case-identifier start end)

        ;; apply partial-exceptions
        (goto-char start)
        (while (not done)
          (setq next
                (or
                 (save-excursion (when (search-forward "_" end t) (point-marker)))
                 (copy-marker (1+ end))))

          (when (setq match (assoc-string (buffer-substring-no-properties start (1- next))
                                        ada-case-partial-exceptions t))
            ;; see comment above at 'full word exception' for why
            ;; we do insert first.
            (insert (car match))
            (delete-region (point) (1- next)))

          (goto-char next)
          (if (< (point) end)
              (setq start (point))
            (setq done t))
        )))))

(defun ada-case-adjust (&optional typed-char in-comment)
  "Adjust the case of the word before point.
When invoked interactively, TYPED-CHAR must be
`last-command-event', and it must not have been inserted yet.
If IN-COMMENT is non-nil, adjust case of words in comments."
  (when (not (bobp))
    (when (save-excursion
            (forward-char -1); back to last character in word
            (and (not (bobp))
                 (eq (char-syntax (char-after)) ?w); it can be capitalized

                 (not (and (eq typed-char ?')
                           (eq (char-before (point)) ?'))); character literal

                 (or in-comment
                     (not (ada-in-string-or-comment-p)))
                 ;; we sometimes want to capitialize an Ada identifier
                 ;; referenced in a comment, via
                 ;; ada-case-adjust-at-point.

                 (not (ada-in-numeric-literal-p))
                 ))

      ;; The indentation engine may trigger a reparse on
      ;; non-whitespace changes, but we know we don't need to reparse
      ;; for this change (assuming the user has not abused case
      ;; exceptions!).
      (let ((inhibit-modification-hooks t))
        (cond
         ;; Some attributes are also keywords, but captialized as
         ;; attributes. So check for attribute first.
         ((and
           (not in-comment)
           (save-excursion
             (skip-syntax-backward "w_")
             (eq (char-before) ?')))
          (ada-case-adjust-identifier))

         ((and
           (not in-comment)
           (not (eq typed-char ?_))
           (ada-after-keyword-p))
          (funcall ada-case-keyword -1))

         (t (ada-case-adjust-identifier))
         ))
      )))

(defun ada-case-adjust-at-point (&optional in-comment)
  "Adjust case of word at point, move to end of word.
With prefix arg, adjust case even if in comment."
  (interactive "P")
  (when
      (and (not (eobp))
           ;; we use '(syntax-after (point))' here, not '(char-syntax
           ;; (char-after))', because the latter does not respect
           ;; ada-syntax-propertize.
           (memq (syntax-class (syntax-after (point))) '(2 3)))
    (skip-syntax-forward "w_"))
  (ada-case-adjust nil in-comment))

(defun ada-case-adjust-region (begin end)
  "Adjust case of all words in region BEGIN END."
  (interactive "r")
  (narrow-to-region begin end)
  (save-excursion
    (goto-char begin)
    (while (not (eobp))
      (forward-comment (point-max))
      (skip-syntax-forward "^w_")
      (skip-syntax-forward "w_")
      (ada-case-adjust)))
  (widen))

(defun ada-case-adjust-buffer ()
  "Adjust case of current buffer."
  (interactive)
  (ada-case-adjust-region (point-min) (point-max)))

(defun ada-case-adjust-interactive (arg)
  "If `ada-auto-case' is non-nil, adjust the case of the previous word, and process the character just typed.
To be bound to keys that should cause auto-casing.
ARG is the prefix the user entered with \\[universal-argument]."
  (interactive "P")

  ;; character typed has not been inserted yet
  (let ((lastk last-command-event))

    (cond
     ((eq lastk ?\n)
        (when ada-auto-case
          (ada-case-adjust lastk))
        (funcall ada-lfd-binding))

     ((memq lastk '(?\r return))
      (when ada-auto-case
        (ada-case-adjust lastk))
      (funcall ada-ret-binding))

     (t
      (when ada-auto-case
        (ada-case-adjust lastk))
      (self-insert-command (prefix-numeric-value arg)))
     )))

;;;; project files

;; An Emacs Ada mode project file can specify several things:
;;
;; - a compiler-specific project file
;;
;; - compiler-specific environment variables
;;
;; - other compiler-specific things (see the compiler support elisp code)
;;
;; - a list of source directories (in addition to those specified in the compiler project file)
;;
;; - a casing exception file
;;
;; All of the data used by Emacs Ada mode functions specified in a
;; project file is stored in a property list. The property list is
;; stored in an alist indexed by the project file name, so multiple
;; project files can be selected without re-parsing them (some
;; compiler project files can take a long time to parse).

(defvar ada-prj-alist nil
  "Alist holding currently parsed Emacs Ada project files. Indexed by absolute project file name.")

(defvar ada-prj-current-file nil
  "Current Emacs Ada project file.")

(defvar ada-prj-current-project nil
  "Current Emacs Ada mode project; a plist.")

(defun ada-prj-get (prop &optional plist)
  "Return value of PROP in PLIST.
Optional PLIST defaults to `ada-prj-current-project'."
  (let ((prj (or plist ada-prj-current-project)))
    (if prj
        (plist-get prj prop)

      ;; no project, just use default vars
      ;; must match code in ada-prj-default
      (cl-case plist
        (ada_compiler    ada-compiler)
        (auto_case       ada-auto-case)
        (case_keyword    ada-case-keyword)
        (case_identifier ada-case-identifier)
        (case_strict     ada-case-strict)
        (casing          (if (listp ada-case-exception-file)
                             ada-case-exception-file
                           (list ada-case-exception-file)))
        (path_sep        path-separator)
        (proc_env        process-environment)
        (src_dir         (list "."))
        (xref_tool       ada-xref-tool)
        ))))

(defun ada-prj-put (prop val &optional plist)
  "Set value of PROP in PLIST to VAL.
Optional PLIST defaults to `ada-prj-current-project'."
  (plist-put (or plist ada-prj-current-project) prop val))

(defun ada-require-project-file ()
  (unless ada-prj-current-file
    (error "no Emacs Ada project file specified")))

(defvar ada-prj-default-list nil
  ;; project file parse
  "List of functions to add default project variables. Called
with one argument; the default project properties list. Function
should add to the properties list and return it.")

(defvar ada-prj-default-compiler-alist nil
  ;; project file parse
  "Compiler-specific function to set default project variables.
Indexed by ada-compiler.  Called with one argument; the default
project properties list. Function should add to the properties
list and return it.")

(defvar ada-prj-default-xref-alist nil
  ;; project file parse
  "Xref-tool-specific function to set default project variables.
Indexed by ada-xref-tool.  Called with one argument; the default
project properties list. Function should add to the properties
list and return it.")

(defun ada-prj-default ()
  "Return the default project properties list.
Include properties set via `ada-prj-default-compiler-alist',
`ada-prj-default-xref-alist'."

  (let (project func)
    (setq
     project
     (list
      ;; variable name alphabetical order
      'ada_compiler    ada-compiler
      'auto_case       ada-auto-case
      'case_keyword    ada-case-keyword
      'case_identifier ada-case-identifier
      'case_strict     ada-case-strict
      'casing          (if (listp ada-case-exception-file)
                           ada-case-exception-file
                         (list ada-case-exception-file))
      'path_sep        path-separator;; prj variable so users can override it for their compiler
      'proc_env        process-environment
      'src_dir         (list ".")
      'xref_tool       ada-xref-tool
      ))

    (cl-dolist (func ada-prj-default-list)
      (setq project (funcall func project)))

    (setq func (cdr (assq ada-compiler ada-prj-default-compiler-alist)))
    (when func (setq project (funcall func project)))
    (setq func (cdr (assq ada-xref-tool ada-prj-default-xref-alist)))
    (when func (setq project (funcall func project)))
    project))

(defvar ada-prj-parser-alist
  (mapcar
   (lambda (ext) (cons ext 'ada-prj-parse-file-1))
   ada-prj-file-extensions)
  ;; project file parse
  "Alist of parsers for project files, indexed by file extension.
Default provides the minimal Ada mode parser; compiler support
code may add other parsers.  Parser is called with two arguments;
the project file name and the current project property
list. Parser must modify or add to the property list and return it.")

;; This autoloaded because it is often used in Makefiles, and thus
;; will be the first ada-mode function executed.
;;;###autoload
(defun ada-parse-prj-file (prj-file)
  "Read Emacs Ada or compiler-specific project file PRJ-FILE, set project properties in `ada-prj-alist'."
  ;; Not called ada-prj-parse-file for Ada mode 4.01 compatibility
  (let ((project (ada-prj-default))
        (parser (cdr (assoc (file-name-extension prj-file) ada-prj-parser-alist))))

    (setq prj-file (expand-file-name prj-file))

    (unless (file-readable-p prj-file)
      (error "Project file '%s' is not readable" prj-file))

    (if parser
        ;; parser may reference the "current project", so bind that now.
        (let ((ada-prj-current-project project)
              (ada-prj-current-file prj-file))
          (setq project (funcall parser prj-file project)))
      (error "no project file parser defined for '%s'" prj-file))

    ;; Store the project properties
    (if (assoc prj-file ada-prj-alist)
        (setcdr (assoc prj-file ada-prj-alist) project)
      (add-to-list 'ada-prj-alist (cons prj-file project)))

    ;; return t for interactive use
    t))

(defun ada-prj-reparse-select-current ()
  "Reparse the current project file, re-select it.
Useful when the project file has been edited."
  (ada-parse-prj-file ada-prj-current-file)
  (ada-select-prj-file ada-prj-current-file))

(defvar ada-prj-parse-one-compiler nil
  ;; project file parse
  "Compiler-specific function to process one Ada project property.
Indexed by project variable ada_compiler.
Called with three arguments; the property name, property value,
and project properties list. Function should add to or modify the
properties list and return it, or return nil if the name is not
recognized.")

(defvar ada-prj-parse-one-xref nil
  ;; project file parse
  "Xref-tool-specific function to process one Ada project property.
Indexed by project variable xref_tool.
Called with three arguments; the property name, property value,
and project properties list. Function should add to or modify the
properties list and return it, or return nil if the name is not
recognized.")

(defvar ada-prj-parse-final-compiler nil
  ;; project file parse
  "Alist of compiler-specific functions to finish processing Ada project properties.
Indexed by project variable ada_compiler.
Called with one argument; the project properties list. Function
should add to or modify the list and return it.")

(defvar ada-prj-parse-final-xref nil
  ;; project file parse
  "Alist of xref-tool-specific functions to finish processing Ada project properties.
Indexed by project variable xref_tool.
Called with one argument; the project properties list. Function
should add to or modify the list and return it.")

(defun ada-prj-parse-file-1 (prj-file project)
  "Parse the Ada mode project file PRJ-FILE, set project properties in PROJECT.
Return new value of PROJECT."
  (let (;; fields that are lists or that otherwise require special processing
        casing src_dir
        tmp-prj
        (parse-one-compiler (cdr (assoc ada-compiler ada-prj-parse-one-compiler)))
        (parse-final-compiler (cdr (assoc ada-compiler ada-prj-parse-final-compiler)))
        (parse-one-xref (cdr (assoc ada-xref-tool ada-prj-parse-one-xref)))
        (parse-final-xref (cdr (assoc ada-xref-tool ada-prj-parse-final-xref))))

    (with-current-buffer (find-file-noselect prj-file)
      (goto-char (point-min))

      ;; process each line
      (while (not (eobp))

        ;; ignore lines that don't have the format "name=value", put
        ;; 'name', 'value' in match-string.
        (when (looking-at "^\\([^=\n]+\\)=\\(.*\\)")
          (cond
           ;; variable name alphabetical order

           ((string= (match-string 1) "ada_compiler")
            (let ((comp (intern (match-string 2))))
              (setq project (plist-put project 'ada_compiler comp))
              (setq parse-one-compiler (cdr (assq comp ada-prj-parse-one-compiler)))
              (setq parse-final-compiler (cdr (assq comp ada-prj-parse-final-compiler)))))

           ((string= (match-string 1) "auto_case")
            (setq project (plist-put project 'auto_case (intern (match-string 2)))))

           ((string= (match-string 1) "case_keyword")
            (setq project (plist-put project 'case_keyword (intern (match-string 2)))))

           ((string= (match-string 1) "case_identifier")
            (setq project (plist-put project 'case_identifier (intern (match-string 2)))))

           ((string= (match-string 1) "case_strict")
            (setq project (plist-put project 'case_strict (intern (match-string 2)))))

           ((string= (match-string 1) "casing")
            (add-to-list 'casing
                         (expand-file-name
                          (substitute-in-file-name (match-string 2)))))

           ((string= (match-string 1) "el_file")
            (let ((file (expand-file-name (substitute-in-file-name (match-string 2)))))
              (setq project (plist-put project 'el_file file))
              ;; eval now as well as in select, since it might affect parsing
              (load-file file)))

           ((string= (match-string 1) "src_dir")
            (add-to-list 'src_dir
                         (file-name-as-directory
                          (expand-file-name (match-string 2)))))

           ((string= (match-string 1) "xref_tool")
            (let ((xref (intern (match-string 2))))
              (setq project (plist-put project 'xref_tool xref))
              (setq parse-one-xref (cdr (assq xref ada-prj-parse-one-xref)))
              (setq parse-final-xref (cdr (assq xref ada-prj-parse-final-xref)))))

           (t
            (if (or
                 (and parse-one-compiler
                      (setq tmp-prj (funcall parse-one-compiler (match-string 1) (match-string 2) project)))
                 (and parse-one-xref
                      (setq tmp-prj (funcall parse-one-xref (match-string 1) (match-string 2) project))))

                (setq project tmp-prj)

              ;; Any other field in the file is set as an environment
              ;; variable or a project file.
              (if (= ?$ (elt (match-string 1) 0))
                  ;; process env var. We don't do expand-file-name
                  ;; here because the application may be expecting a
                  ;; simple string.
                  (let ((process-environment (plist-get project 'proc_env)))
                    (setenv (substring (match-string 1) 1)
                            (substitute-in-file-name (match-string 2)))
                    (setq project
                          (plist-put project 'proc_env process-environment)))

                ;; not recognized; assume it is a user-defined variable like "comp_opt"
                (setq project (plist-put project (intern (match-string 1)) (match-string 2)))
              )))
           ))

        (forward-line 1))

      );; done reading file

    ;; process accumulated lists
    (if casing (set 'project (plist-put project 'casing (reverse casing))))
    (if src_dir (set 'project (plist-put project 'src_dir (reverse src_dir))))

    (when parse-final-compiler
      ;; parse-final-compiler may reference the "current project", so
      ;; bind that now, to include the properties set above.
      (let ((ada-prj-current-project project)
            (ada-prj-current-file prj-file))
        (setq project (funcall parse-final-compiler project))))

    (when parse-final-xref
      (let ((ada-prj-current-project project)
            (ada-prj-current-file prj-file))
        (setq project (funcall parse-final-xref project))))

    project
    ))

(defvar ada-project-search-path nil
  "Search path for finding Ada project files")

(defvar ada-select-prj-compiler nil
  "Alist of functions to call for compiler specific project file selection.
Indexed by project variable ada_compiler.")

(defvar ada-deselect-prj-compiler nil
  "Alist of functions to call for compiler specific project file deselection.
Indexed by project variable ada_compiler.")

(defvar ada-select-prj-xref-tool nil
  "Alist of functions to call for xref-tool specific project file selection.
Indexed by project variable xref_tool.")

(defvar ada-deselect-prj-xref-tool nil
  "Alist of functions to call for xref-tool specific project file deselection.
Indexed by project variable xref_tool.")

(defun ada-select-prj-file (prj-file)
  "Select PRJ-FILE as the current project file."
  (interactive)
  (setq prj-file (expand-file-name prj-file))

  (setq ada-prj-current-project (cdr (assoc prj-file ada-prj-alist)))

  (when (null ada-prj-current-project)
    (setq ada-prj-current-file nil)
    (error "Project file '%s' was not previously parsed." prj-file))

  (let ((func (cdr (assq (ada-prj-get 'ada_compiler) ada-deselect-prj-compiler))))
    (when func (funcall func)))

  (let ((func (cdr (assq (ada-prj-get 'xref_tool) ada-deselect-prj-xref-tool))))
    (when func (funcall func)))

  (setq ada-prj-current-file prj-file)

  ;; Project file should fully specify what compilers are used,
  ;; including what compilation filters they need. There may be more
  ;; than just an Ada compiler.
  (setq compilation-error-regexp-alist nil)
  (setq compilation-filter-hook nil)

  (when (ada-prj-get 'el_file)
    (load-file (ada-prj-get 'el_file)))

  (ada-case-read-all-exceptions)

  (setq compilation-search-path (ada-prj-get 'src_dir))
  (setq ada-project-search-path (ada-prj-get 'prj_dir))

  (let ((func (cdr (assq (ada-prj-get 'ada_compiler) ada-select-prj-compiler))))
    (when func (funcall func)))

  (let ((func (cdr (assq (ada-prj-get 'xref_tool) ada-select-prj-xref-tool))))
    (when func (funcall func)))

  ;; return 't', for decent display in message buffer when called interactively
  t)

(defun ada-prj-select ()
  "Select the current project file from the list of currently available project files."
  (interactive)
  (ada-select-prj-file (completing-read "project: " ada-prj-alist nil t))
  )

(defun ada-prj-show ()
  "Show current Emacs Ada mode project file."
  (interactive)
  (message "current Emacs Ada mode project file: %s" ada-prj-current-file))

(defvar ada-show-xref-tool-buffer nil
  ;; Supplied by xref tool
  "Function to show process buffer used by xref tool."
  )

(defun ada-show-xref-tool-buffer ()
  (interactive)
  (when ada-show-xref-tool-buffer
    (funcall ada-show-xref-tool-buffer)))

;;;; syntax properties

(defvar ada-mode-syntax-table
  (let ((table (make-syntax-table)))
    ;; (info "(elisp)Syntax Class Table" "*info syntax class table*")
    ;; make-syntax-table sets all alphanumeric to w, etc; so we only
    ;; have to add ada-specific things.

    ;; string brackets. `%' is the obsolete alternative string
    ;; bracket (arm J.2); if we make it syntax class ", it throws
    ;; font-lock and indentation off the track, so we use syntax class
    ;; $.
    (modify-syntax-entry ?%  "$" table)
    (modify-syntax-entry ?\" "\"" table)

    ;; punctuation; operators etc
    (modify-syntax-entry ?#  "w" table); based number - word syntax, since we don't need the number
    (modify-syntax-entry ?&  "." table)
    (modify-syntax-entry ?*  "." table)
    (modify-syntax-entry ?+  "." table)
    (modify-syntax-entry ?-  ". 12" table); operator; see ada-syntax-propertize for double hyphen as comment
    (modify-syntax-entry ?. "." table)
    (modify-syntax-entry ?/  "." table)
    (modify-syntax-entry ?:  "." table)
    (modify-syntax-entry ?<  "." table)
    (modify-syntax-entry ?=  "." table)
    (modify-syntax-entry ?>  "." table)
    (modify-syntax-entry ?\' "." table); attribute; see ada-syntax-propertize for character literal
    (modify-syntax-entry ?\; "." table)
    (modify-syntax-entry ?\\ "." table); default is escape; not correct for Ada strings
    (modify-syntax-entry ?\|  "." table)

    ;; and \f and \n end a comment
    (modify-syntax-entry ?\f  ">" table)
    (modify-syntax-entry ?\n  ">" table)

    (modify-syntax-entry ?_ "_" table); symbol constituents, not word.

    (modify-syntax-entry ?\( "()" table)
    (modify-syntax-entry ?\) ")(" table)

    ;; skeleton placeholder delimiters; see ada-skel.el. We use generic
    ;; comment delimiter class, not comment starter/comment ender, so
    ;; these can be distinguished from line end.
    (modify-syntax-entry ?{ "!" table)
    (modify-syntax-entry ?} "!" table)

    table
    )
  "Syntax table to be used for editing Ada source code.")

(defvar ada-syntax-propertize-hook nil
  ;; provided by preprocessor, lumped with xref-tool
  "Hook run from `ada-syntax-propertize'.
Called by `syntax-propertize', which is called by font-lock in
`after-change-functions'. Therefore, care must be taken to avoid
race conditions with the grammar parser.")

(defun ada-syntax-propertize (start end)
  "Assign `syntax-table' properties in accessible part of buffer.
In particular, character constants are set to have string syntax."
  ;; (info "(elisp)Syntax Properties")
  ;;
  ;; called from `syntax-propertize', inside save-excursion with-silent-modifications
  (let ((inhibit-read-only t)
        (inhibit-point-motion-hooks t))
    (goto-char start)
    (save-match-data
      (while (re-search-forward
              (concat
               "[^a-zA-Z0-9)]\\('\\)[^'\n]\\('\\)"; 1, 2: character literal, not attribute
               "\\|[^a-zA-Z0-9)]\\('''\\)"; 3: character literal '''
               "\\|\\(--\\)"; 4: comment start
               )
              end t)
        ;; The help for syntax-propertize-extend-region-functions
        ;; implies that 'start end' will always include whole lines, in
        ;; which case we don't need
        ;; syntax-propertize-extend-region-functions
        (cond
         ((match-beginning 1)
          (put-text-property
           (match-beginning 1) (match-end 1) 'syntax-table '(7 . ?'))
          (put-text-property
           (match-beginning 2) (match-end 2) 'syntax-table '(7 . ?')))
         ((match-beginning 3)
          (put-text-property
           (match-beginning 3) (1+ (match-beginning 3)) 'syntax-table '(7 . ?'))
          (put-text-property
           (1- (match-end 3)) (match-end 3) 'syntax-table '(7 . ?')))
         ((match-beginning 4)
          (put-text-property
           (match-beginning 4) (match-end 4) 'syntax-table '(11 . nil)))
         )))
    (run-hook-with-args 'ada-syntax-propertize-hook start end))
  )

(defun ada-in-comment-p (&optional parse-result)
  "Return t if inside a comment.
If PARSE-RESULT is non-nil, use it instead of calling `syntax-ppss'."
  (nth 4 (or parse-result (syntax-ppss))))

(defun ada-in-string-p (&optional parse-result)
  "Return t if point is inside a string.
If PARSE-RESULT is non-nil, use it instead of calling `syntax-ppss'."
  (nth 3 (or parse-result (syntax-ppss))))

(defun ada-in-string-or-comment-p (&optional parse-result)
  "Return t if inside a comment or string.
If PARSE-RESULT is non-nil, use it instead of calling `syntax-ppss'."
  (setq parse-result (or parse-result (syntax-ppss)))
  (or (ada-in-string-p parse-result) (ada-in-comment-p parse-result)))

(defun ada-in-paren-p (&optional parse-result)
  "Return t if point is inside a pair of parentheses.
If PARSE-RESULT is non-nil, use it instead of calling `syntax-ppss'."
  (> (nth 0 (or parse-result (syntax-ppss))) 0))

(defun ada-goto-open-paren (&optional offset parse-result)
  "Move point to innermost opening paren surrounding current point, plus OFFSET.
Throw error if not in paren.  If PARSE-RESULT is non-nil, use it
instead of calling `syntax-ppss'."
  (goto-char (+ (or offset 0) (nth 1 (or parse-result (syntax-ppss))))))

;;;; navigation within and between files

(defvar ada-body-suffixes '(".adb")
  "List of possible suffixes for Ada body files.
The extensions should include a `.' if needed.")

(defvar ada-spec-suffixes '(".ads")
  "List of possible suffixes for Ada spec files.
The extensions should include a `.' if needed.")

(defvar ada-other-file-alist
  '(("\\.ads$" (".adb"))
    ("\\.adb$" (".ads")))
  "Alist used by `find-file' to find the name of the other package.
See `ff-other-file-alist'.")

(defconst ada-name-regexp
  "\\(\\(?:\\sw\\|[_.]\\)+\\)")

(defconst ada-parent-name-regexp
  "\\([a-zA-Z0-9_\\.]+\\)\\.[a-zA-Z0-9_]+"
  "Regexp for extracting the parent name from fully-qualified name.")

(defvar ada-file-name-from-ada-name nil
  ;; determined by ada-xref-tool, set by *-select-prj
  "Function called with one parameter ADA-NAME, which is a library
unit name; it should return the filename in which ADA-NAME is
found.")

(defun ada-file-name-from-ada-name (ada-name)
  "Return the filename in which ADA-NAME is found."
  (funcall ada-file-name-from-ada-name ada-name))

(defvar ada-ada-name-from-file-name nil
  ;; depends on ada-compiler, per-project
  "Function called with one parameter FILE-NAME, which is a library
unit name; it should return the Ada name that should be found in FILE-NAME.")

(defun ada-ada-name-from-file-name (file-name)
  "Return the ada-name that should be found in FILE-NAME."
  (funcall ada-ada-name-from-file-name file-name))

(defun ada-ff-special-extract-parent ()
  (setq ff-function-name (match-string 1))
  (file-name-nondirectory
   (or
    (ff-get-file-name
     compilation-search-path
     (ada-file-name-from-ada-name ff-function-name)
     ada-spec-suffixes)
    (error "parent '%s' not found; set project file?" ff-function-name))))

(defun ada-ff-special-extract-separate ()
  (let ((package-name (match-string 1)))
    (save-excursion
      (goto-char (match-end 0))
      (when (eolp) (forward-char 1))
      (skip-syntax-forward " ")
      (looking-at
       (concat "\\(function\\|package body\\|procedure\\|protected body\\|task body\\)\\s +"
               ada-name-regexp))
      (setq ff-function-name (match-string 0))
      )
    (file-name-nondirectory
     (or
      (ff-get-file-name
       compilation-search-path
       (ada-file-name-from-ada-name package-name)
       ada-body-suffixes)
      (error "package '%s' not found; set project file?" package-name)))))

(defun ada-ff-special-with ()
  (let ((package-name (match-string 1)))
    (setq ff-function-name (concat "^package\\s-+" package-name "\\([^_]\\|$\\)"))
    (file-name-nondirectory
     (or
      (ff-get-file-name
       compilation-search-path
       (ada-file-name-from-ada-name package-name)
       (append ada-spec-suffixes ada-body-suffixes))
      (error "package '%s' not found; set project file?" package-name)))
    ))

(defun ada-set-ff-special-constructs ()
  "Add Ada-specific pairs to `ff-special-constructs'."
  (set (make-local-variable 'ff-special-constructs) nil)
  (mapc (lambda (pair) (add-to-list 'ff-special-constructs pair))
        ;; Each car is a regexp; if it matches at point, the cdr is invoked.
        ;; Each cdr should set ff-function-name to a string or regexp
        ;; for ada-set-point-accordingly, and return the file name
        ;; (sans directory, must include suffix) to go to.
        (list
         ;; Top level child package declaration (not body), or child
         ;; subprogram declaration or body; go to the parent package.
         (cons (concat "^\\(?:private[ \t]+\\)?\\(?:package\\|procedure\\|function\\)[ \t]+"
                       ada-parent-name-regexp "\\(?:;\\|[ \t]+\\|$\\)")
               'ada-ff-special-extract-parent)

         ;; A "separate" clause.
         (cons (concat "^separate[ \t\n]*(" ada-name-regexp ")")
               'ada-ff-special-extract-separate)

         ;; A "with" clause. Note that it may refer to a procedure body, as well as a spec
         (cons (concat "^\\(?:limited[ \t]+\\)?\\(?:private[ \t]+\\)?with[ \t]+" ada-name-regexp)
               'ada-ff-special-with)
         )))

(defvar ada-which-function nil
  ;; supplied by indentation engine
  ;;
  ;; This is run from ff-pre-load-hook, so ff-function-name may have
  ;; been set by ff-treat-special; don't reset it.
  "Function called with no parameters; it should return the name
of the package, protected type, subprogram, or task type whose
definition/declaration point is in or just after, or nil.  In
addition, if ff-function-name is non-nil, store in
ff-function-name a regexp that will find the function in the
other file.")

(defun ada-which-function ()
  "See `ada-which-function' variable."
  (interactive)
  (when ada-which-function
    (funcall ada-which-function)))

(defun ada-add-log-current-function ()
  "For `add-log-current-defun-function'; uses `ada-which-function'."
  ;; add-log-current-defun is typically called with point at the start
  ;; of an ediff change section, which is before the start of the
  ;; declaration of a new item. So go to the end of the current line
  ;; first, then call `ada-which-function'
  (save-excursion
    (end-of-line 1)
    (ada-which-function)))

(defun ada-set-point-accordingly ()
  "Move to the string specified in `ff-function-name', which may be a regexp,
previously set by a file navigation command."
  (when ff-function-name
    (let ((done nil)
          (found nil))
      (goto-char (point-min))
      ;; We are looking for an Ada declaration, so don't stop for strings or comments
      ;;
      ;; This will still be confused by multiple references; we need
      ;; to use compiler cross reference info for more precision.
      (while (not done)
        (if (search-forward-regexp ff-function-name nil t)
            (setq found (match-beginning 0))
          ;; not in remainder of buffer
          (setq done t))
        (if (ada-in-string-or-comment-p)
            (setq found nil)
          (setq done t)))
      (when found
        (goto-char found)
        ;; different parsers find different points on the line; normalize here
        (back-to-indentation))
      (setq ff-function-name nil))))

(defun ada-check-current-project (file-name)
  "Throw error if FILE-NAME (must be absolute) is not found in
the current project source directories, or if no project has been
set."
  (when (null (car compilation-search-path))
    (error "no file search path defined; set project file?"))

  (unless (string= file-name
                   (locate-file (file-name-nondirectory file-name)
                                compilation-search-path))
    (error "current file not part of current project; wrong project?")))

(defun ada-find-other-file-noset (other-window)
  "Same as `ada-find-other-file', but preserve point in the other file,
don't move to corresponding declaration."
  (interactive "P")
  (ada-find-other-file other-window t))

(defun ada-find-other-file (other-window &optional no-set-point)
  "Move to the corresponding declaration in another file.

- If region is active, assume it contains a package name;
  position point on that package declaration.

- If point is in the start line of a non-nested child package or
  subprogram declaration, position point on the corresponding
  parent package specification.

- If point is in the start line of a separate body,
  position point on the corresponding separate stub declaration.

- If point is in a context clause line, position point on the
  first package declaration that is mentioned.

- If point is in a subprogram body or specification, position point
  on the corresponding specification or body.

If OTHER-WINDOW (set by interactive prefix) is non-nil, show the
buffer in another window.

If NO-SET-POINT is nil, set point in the other file on the
corresponding declaration. If non-nil, preserve existing point in
the other file."

  ;; ff-get-file, ff-find-other file first process
  ;; ff-special-constructs, then run the following hooks:
  ;;
  ;; ff-pre-load-hook      set to ada-which-function
  ;; ff-file-created-hook  set to ada-ff-create-body
  ;; ff-post-load-hook     set to ada-set-point-accordingly,
  ;;                       or to a compiler-specific function that
  ;;                       uses compiler-generated cross reference
  ;;                       information

  (interactive "P")
  (ada-check-current-project (buffer-file-name))

  (if mark-active
      (progn
        (setq ff-function-name (buffer-substring-no-properties (point) (mark)))
        (ff-get-file
         compilation-search-path
         (ada-file-name-from-ada-name ff-function-name)
         ada-spec-suffixes
         other-window)
        (deactivate-mark))

    ;; else use name at point
    (ff-find-other-file other-window)))

(defvar ada-operator-re
  "\\+\\|-\\|/\\|\\*\\*\\|\\*\\|=\\|&\\|abs\\|mod\\|rem\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>"
  "Regexp matching Ada operator_symbol.")

(defun ada-identifier-at-point ()
  "Return the identifier around point, move point to start of
identifier.  May be an Ada identifier or operator function name."

  (when (ada-in-comment-p)
    (error "Inside comment"))

  (let (identifier)

    (skip-chars-backward "a-zA-Z0-9_<>=+\\-\\*/&")

    ;; Just in front of, or inside, a string => we could have an operator
    (cond
     ((ada-in-string-p)
      (cond

       ((and (= (char-before) ?\")
             (progn
               (forward-char -1)
               (looking-at (concat "\"\\(" ada-operator-re "\\)\""))))
        (setq identifier (concat "\"" (match-string-no-properties 1) "\"")))

       (t
        (error "Inside string or character constant"))
       ))

     ((and (= (char-after) ?\")
           (looking-at (concat "\"\\(" ada-operator-re "\\)\"")))
      (setq identifier (concat "\"" (match-string-no-properties 1) "\"")))

     ((looking-at "[a-zA-Z0-9_]+")
      (setq identifier (match-string-no-properties 0)))

     (t
      (error "No identifier around"))
     )))

(defvar ada-goto-pos-ring '()
  "List of positions selected by navigation functions. Used
to go back to these positions.")

(defconst ada-goto-pos-ring-max 16
  "Number of positions kept in the list `ada-goto-pos-ring'.")

(defun ada-goto-push-pos ()
  "Push current filename, position on `ada-goto-pos-ring'. See `ada-goto-previous-pos'."
  (setq ada-goto-pos-ring (cons (list (point) (buffer-file-name)) ada-goto-pos-ring))
  (if (> (length ada-goto-pos-ring) ada-goto-pos-ring-max)
      (setcdr (nthcdr (1- ada-goto-pos-ring-max) ada-goto-pos-ring) nil)))

(defun ada-goto-previous-pos ()
  "Go to the first position in `ada-goto-pos-ring', pop `ada-goto-pos-ring'."
  (interactive)
  (when ada-goto-pos-ring
    (let ((pos (pop ada-goto-pos-ring)))
      (find-file (cadr pos))
      (goto-char (car pos)))))

(defun ada-goto-source (file line column other-window)
  "Find and select FILE, at LINE and COLUMN.
FILE may be absolute, or on `compilation-search-path'.

If OTHER-WINDOW is non-nil, show the buffer in another window."
  (let ((file-1
         (if (file-name-absolute-p file) file
           (ff-get-file-name compilation-search-path file))))
    (if file-1
        (setq file file-1)
      (error "File %s not found; installed library, or set project?" file))
    )

  (ada-goto-push-pos)

  (let ((buffer (get-file-buffer file)))
    (cond
     ((bufferp buffer)
      (cond
       ((null other-window)
        (switch-to-buffer buffer))

       (t (switch-to-buffer-other-window buffer))
       ))

     ((file-exists-p file)
      (cond
       ((null other-window)
        (find-file file))

       (t
        (find-file-other-window file))
       ))

     (t
      (error "'%s' not found" file))))


  ;; move the cursor to the correct position
  (push-mark nil t)
  (goto-char (point-min))
  (forward-line (1- line))
  (forward-char column)
  )

(defvar ada-xref-refresh-function nil
  ;; determined by xref_tool, set by *-select-prj-xref
  "Function that refreshes cross reference information cache.")

(defun ada-xref-refresh ()
  "Refresh cross reference information cache, if any."
  (interactive)

  (when (null ada-xref-refresh-function)
    (error "no cross reference information available"))

  (funcall ada-xref-refresh-function)
  )

(defvar ada-xref-other-function nil
  ;; determined by xref_tool, set by *-select-prj-xref
  "Function that returns cross reference information.
Function is called with four arguments:
- an Ada identifier or operator_symbol
- filename containing the identifier (full path)
- line number containing the identifier
- column of the start of the identifier
Returns a list '(file line column) giving the corresponding location.
'file' may be absolute, or on `compilation-search-path'.  If point is
at the specification, the corresponding location is the body, and vice
versa.")

(defun ada-goto-declaration (other-window)
  "Move to the declaration or body of the identifier around point.
If at the declaration, go to the body, and vice versa.

If OTHER-WINDOW (set by interactive prefix) is non-nil, show the
buffer in another window."
  (interactive "P")
  (ada-check-current-project (buffer-file-name))

  (when (null ada-xref-other-function)
    (error "no cross reference information available"))

    (let ((target
           (funcall ada-xref-other-function
                    (ada-identifier-at-point)
                    (buffer-file-name)
                    (line-number-at-pos)
                    (1+ (current-column))
                    )))

      (ada-goto-source (nth 0 target)
                       (nth 1 target)
                       (nth 2 target)
                       other-window)
    ))

(defvar ada-xref-parent-function nil
  ;; determined by xref_tool, set by *-select-prj-xref
  "Function that returns cross reference information.
Function is called with four arguments:
- an Ada identifier or operator_symbol
- filename containing the identifier
- line number containing the identifier
- column of the start of the identifier
Displays a buffer in compilation-mode giving locations of the parent type declarations.")

(defun ada-show-declaration-parents ()
  "Display the locations of the parent type declarations of the type identifier around point."
  (interactive)
  (ada-check-current-project (buffer-file-name))

  (when (null ada-xref-parent-function)
    (error "no cross reference information available"))

  (funcall ada-xref-parent-function
           (ada-identifier-at-point)
           (file-name-nondirectory (buffer-file-name))
           (line-number-at-pos)
           (1+ (current-column)))
  )

(defvar ada-xref-all-function nil
  ;; determined by xref_tool, set by *-select-prj-xref
  "Function that displays cross reference information.
Called with four arguments:
- an Ada identifier or operator_symbol
- filename containing the identifier
- line number containing the identifier
- column of the start of the identifier
Displays a buffer in compilation-mode giving locations where the
identifier is declared or referenced.")

(defun ada-show-references ()
  "Show all references of identifier at point."
  (interactive)
  (ada-check-current-project (buffer-file-name))

  (when (null ada-xref-all-function)
    (error "no cross reference information available"))

  (funcall ada-xref-all-function
           (ada-identifier-at-point)
           (file-name-nondirectory (buffer-file-name))
           (line-number-at-pos)
           (1+ (current-column)))
  )

(defvar ada-xref-overriding-function nil
  ;; determined by ada-xref-tool, set by *-select-prj
  "Function that displays cross reference information for overriding subprograms.
Called with four arguments:
- an Ada identifier or operator_symbol
- filename containing the identifier
- line number containing the identifier
- column of the start of the identifier
Displays a buffer in compilation-mode giving locations of the overriding declarations.")

(defun ada-show-overriding ()
  "Show all overridings of identifier at point."
  (interactive)
  (ada-check-current-project (buffer-file-name))

  (when (null ada-xref-overriding-function)
    (error "no cross reference information available"))

  (funcall ada-xref-overriding-function
           (ada-identifier-at-point)
           (file-name-nondirectory (buffer-file-name))
           (line-number-at-pos)
           (1+ (current-column)))
  )

(defvar ada-xref-overridden-function nil
  ;; determined by ada-xref-tool, set by *-select-prj
  "Function that displays cross reference information for overridden subprogram.
Called with four arguments:
- an Ada identifier or operator_symbol
- filename containing the identifier
- line number containing the identifier
- column of the start of the identifier
Returns a list '(file line column) giving the corresponding location.
'file' may be absolute, or on `compilation-search-path'.")

(defun ada-show-overridden (other-window)
  "Show the overridden declaration of identifier at point."
  (interactive "P")
  (ada-check-current-project (buffer-file-name))

  (when (null ada-xref-overridden-function)
    (error "'show overridden' not supported, or no cross reference information available"))

  (let ((target
         (funcall ada-xref-overridden-function
                  (ada-identifier-at-point)
                  (file-name-nondirectory (buffer-file-name))
                  (line-number-at-pos)
                  (1+ (current-column)))))

    (ada-goto-source (nth 0 target)
                     (nth 1 target)
                     (nth 2 target)
                     other-window)

  ))

;; This is autoloaded because it may be used in ~/.emacs
;;;###autoload
(defun ada-add-extensions (spec body)
  "Define SPEC and BODY as being valid extensions for Ada files.
SPEC and BODY are two regular expressions that must match against
the file name."
  (let* ((reg (concat (regexp-quote body) "$"))
         (tmp (assoc reg ada-other-file-alist)))
    (if tmp
        (setcdr tmp (list (cons spec (cadr tmp))))
      (add-to-list 'ada-other-file-alist (list reg (list spec)))))

  (let* ((reg (concat (regexp-quote spec) "$"))
         (tmp (assoc reg ada-other-file-alist)))
    (if tmp
        (setcdr tmp (list (cons body (cadr tmp))))
      (add-to-list 'ada-other-file-alist (list reg (list body)))))

  (add-to-list 'auto-mode-alist
               (cons (concat (regexp-quote spec) "\\'") 'ada-mode))
  (add-to-list 'auto-mode-alist
               (cons (concat (regexp-quote body) "\\'") 'ada-mode))

  (add-to-list 'ada-spec-suffixes spec)
  (add-to-list 'ada-body-suffixes body)

  (when (fboundp 'speedbar-add-supported-extension)
    (speedbar-add-supported-extension spec)
    (speedbar-add-supported-extension body))
  )

(defun ada-show-secondary-error (other-window)
  "Show the next secondary file reference in the compilation buffer.
A secondary file reference is defined by text having text
property `ada-secondary-error'.  These can be set by
compiler-specific compilation filters.

If OTHER-WINDOW (set by interactive prefix) is non-nil, show the
buffer in another window."
  (interactive "P")

  ;; preserving the current window works only if the frame
  ;; doesn't change, at least on Windows.
  (let ((start-buffer (current-buffer))
        (start-window (selected-window))
        pos item file)
    (set-buffer compilation-last-buffer)
    (setq pos (next-single-property-change (point) 'ada-secondary-error))
    (when pos
      (setq item (get-text-property pos 'ada-secondary-error))
      ;; file-relative-name handles absolute Windows paths from
      ;; g++. Do this in compilation buffer to get correct
      ;; default-directory.
      (setq file (file-relative-name (nth 0 item)))

      ;; Set point in compilation buffer past this secondary error, so
      ;; user can easily go to the next one. For some reason, this
      ;; doesn't change the visible point!?
      (forward-line 1))

    (set-buffer start-buffer);; for windowing history
    (when item
      (ada-goto-source
       file
       (nth 1 item); line
       (nth 2 item); column
       other-window)
      (select-window start-window)
      )
    ))

(defvar ada-goto-declaration-start nil
  ;; Supplied by indentation engine.
  ;;
  ;; This is run from ff-pre-load-hook, so ff-function-name may have
  ;; been set by ff-treat-special; don't reset it.
  "For `beginning-of-defun-function'. Function to move point to
start of the generic, package, protected, subprogram, or task
declaration point is currently in or just after.  Called with no
parameters.")

(defun ada-goto-declaration-start ()
  "Call `ada-goto-declaration-start'."
  (when ada-goto-declaration-start
    (funcall ada-goto-declaration-start)))

(defvar ada-goto-declaration-end nil
  ;; supplied by indentation engine
  "For `end-of-defun-function'. Function to move point to end of
current declaration.")

(defun ada-goto-declaration-end ()
  "See `ada-goto-declaration-end' variable."
  (interactive)
  (when ada-goto-declaration-end
    (funcall ada-goto-declaration-end)))

(defvar ada-goto-declarative-region-start nil
  ;; Supplied by indentation engine
  "Function to move point to start of the declarative region of
the subprogram, package, task, or declare block point
is currently in.  Called with no parameters.")

(defun ada-goto-declarative-region-start ()
  "Call `ada-goto-declarative-region-start'."
  (when ada-goto-declarative-region-start
    (funcall ada-goto-declarative-region-start)))

(defvar ada-next-statement-keyword nil
  ;; Supplied by indentation engine
  "Function called with no parameters; it should move forward to
the next keyword in the statement following the one point is
in (ie from 'if' to 'then').  If not in a keyword, move forward
to the next keyword in the current statement. If at the last keyword,
move forward to the first keyword in the next statement or next
keyword in the containing statement.")

(defvar ada-goto-end nil
  ;; Supplied by indentation engine
  "Function to move point to end of the declaration or statement point is in or before.
Called with no parameters.")

(defun ada-goto-end ()
  "Call `ada-goto-end'."
  (when ada-goto-end
    (funcall ada-goto-end)))

(defun ada-next-statement-keyword ()
  ;; Supplied by indentation engine
  "See `ada-next-statement-keyword' variable."
  (interactive)
  (when ada-next-statement-keyword
    (funcall ada-next-statement-keyword)))

(defvar ada-prev-statement-keyword nil
  ;; Supplied by indentation engine
  "Function called with no parameters; it should move to the previous
keyword in the statement following the one point is in (ie from
'then' to 'if').  If at the first keyword, move to the previous
keyword in the previous statement or containing statement.")

(defun ada-prev-statement-keyword ()
  "See `ada-prev-statement-keyword' variable."
  (interactive)
  (when ada-prev-statement-keyword
    (funcall ada-prev-statement-keyword)))

;;;; code creation

(defvar ada-make-subprogram-body nil
  ;; Supplied by indentation engine
  "Function to convert subprogram specification after point into a subprogram body stub.
Called with no args, point at declaration start. Leave point in
subprogram body, for user to add code.")

(defun ada-make-subprogram-body ()
  "If point is in or after a subprogram specification, convert it
into a subprogram body stub, by calling `ada-make-subprogram-body'."
  (interactive)
  (ada-goto-declaration-start)
  (if ada-make-subprogram-body
      (funcall ada-make-subprogram-body)
    (error "`ada-make-subprogram-body' not set")))

(defvar ada-make-package-body nil
  ;; Supplied by xref tool
  "Function to create a package body from a package spec.
Called with one argument; the absolute path to the body
file. Current buffer is the package spec.  Should create the
package body file, containing skeleton code that will compile.")

(defun ada-make-package-body (body-file-name)
  ;; no error if not set; let ada-skel do its thing.
  (when ada-make-package-body
      (funcall ada-make-package-body body-file-name)))

(defun ada-ff-create-body ()
  ;; no error if not set; let ada-skel do its thing.
  (when ada-make-package-body
    ;; ff-find-other-file calls us with point in an empty buffer for the
    ;; body file; ada-make-package-body expects to be in the spec. So go
    ;; back.
    (let ((body-file-name (buffer-file-name)))
      (ff-find-the-other-file)

      (ada-make-package-body body-file-name)
      ;; FIXME (later): if 'ada-make-package-body' fails, delete the body buffer
      ;; so it doesn't get written to disk, and we can try again.

      ;; back to the body, read in from the disk.
      (ff-find-the-other-file)
      (revert-buffer t t))
    ))

;;;; fill-comment

(defun ada-fill-comment-paragraph (&optional justify postfix)
  "Fill the current comment paragraph.
If JUSTIFY is non-nil, each line is justified as well.
If POSTFIX and JUSTIFY are non-nil, `ada-fill-comment-postfix' is appended
to each line filled and justified.
The paragraph is indented on the first line."
  (interactive "P")
  (if (and (not (ada-in-comment-p))
           (not (looking-at "[ \t]*--")))
      (error "Not inside comment"))

  (let* (indent from to
         (opos (point-marker))
         ;; we bind `fill-prefix' here rather than in ada-mode because
         ;; setting it in ada-mode causes indent-region to use it for
         ;; all indentation.
         (fill-prefix ada-fill-comment-prefix)
         (fill-column (current-fill-column)))

    ;;  Find end of comment paragraph
    (back-to-indentation)
    (while (and (not (eobp)) (looking-at ".*--[ \t]*[^ \t\n]"))
      (forward-line 1)

      ;;  If we were at the last line in the buffer, create a dummy empty
      ;;  line at the end of the buffer.
      (if (eobp)
          (insert "\n")
        (back-to-indentation)))
    (beginning-of-line)
    (setq to (point-marker))
    (goto-char opos)

    ;;  Find beginning of paragraph
    (back-to-indentation)
    (while (and (not (bobp)) (looking-at ".*--[ \t]*[^ \t\n]"))
      (forward-line -1)
      (back-to-indentation))

    (unless (bobp)
      (forward-line 1))
    (beginning-of-line)
    (setq from (point-marker))

    ;;  Calculate the indentation we will need for the paragraph
    (back-to-indentation)
    (setq indent (current-column))
    ;;  unindent the first line of the paragraph
    (delete-region from (point))

    ;;  Remove the old postfixes
    (goto-char from)
    (while (re-search-forward (concat "\\(" ada-fill-comment-postfix "\\)" "\n") to t)
      (delete-region (match-beginning 1) (match-end 1)))

    (goto-char (1- to))
    (setq to (point-marker))

    ;;  Indent and justify the paragraph
    (set-left-margin from to indent)
    (if postfix
        (setq fill-column (- fill-column (length ada-fill-comment-postfix))))

    (fill-region-as-paragraph from to justify)

    ;;  Add the postfixes if required
    (if postfix
        (save-restriction
          (goto-char from)
          (narrow-to-region from to)
          (while (not (eobp))
            (end-of-line)
            (insert-char ?  (- fill-column (current-column)))
            (insert ada-fill-comment-postfix)
            (forward-line))
          ))

    (goto-char opos)))

;;;; support for font-lock.el

;; casing keywords defined here to keep the two lists together
(defconst ada-83-keywords
  '("abort" "abs" "accept" "access" "all" "and" "array" "at" "begin"
    "body" "case" "constant" "declare" "delay" "delta" "digits" "do"
    "else" "elsif" "end" "entry" "exception" "exit" "for" "function"
    "generic" "goto" "if" "in" "is" "limited" "loop" "mod" "new"
    "not" "null" "of" "or" "others" "out" "package" "pragma" "private"
    "procedure" "raise" "range" "record" "rem" "renames" "return"
    "reverse" "select" "separate" "subtype" "task" "terminate" "then"
    "type" "use" "when" "while" "with" "xor")
  "List of Ada 83 keywords.")

(defconst ada-95-keywords
  '("abstract" "aliased" "protected" "requeue" "tagged" "until")
  "List of keywords new in Ada 95.")

(defconst ada-2005-keywords
  '("interface" "overriding" "synchronized")
  "List of keywords new in Ada 2005.")

(defconst ada-2012-keywords
  '("some")
  "List of keywords new in Ada 2012.")

(defun ada-font-lock-keywords ()
  "Return Ada mode value for `font-lock-keywords', depending on `ada-language-version'."
  (list

   ;; keywords followed by a name that should be in function-name-face.
   (list
    (apply
     'concat
     (append
      '("\\<\\("
        "accept\\|"
        "entry\\|"
        "function\\|"
        "package[ \t]+body\\|"
        "package\\|"
        "pragma\\|"
        "procedure\\|"
        "task[ \t]+body\\|"
        "task[ \t]+type\\|"
        "task\\|"
        )
      (when (member ada-language-version '(ada95 ada2005 ada2012))
        '("\\|"
          "protected[ \t]+body\\|"
          "protected[ \t]+function\\|"
          "protected[ \t]+procedure\\|"
          "protected[ \t]+type\\|"
          "protected"
          ))
      (list
       "\\)\\>[ \t]*"
       ada-name-regexp "?")))
    '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t))

   ;; keywords followed by a name that should be in type-face.
   (list (concat
          "\\<\\("
          "access[ \t]+all\\|"
          "access[ \t]+constant\\|"
          "access\\|"
          "constant\\|"
          "in[ \t]+reverse\\|"; loop iterator
          "in[ \t]+not[ \t]+null\\|"
          "in[ \t]+out[ \t]+not[ \t]+null\\|"
          "in[ \t]+out\\|"
          "in\\|"
          ;; "return\\|" can't distinguish between 'function ... return <type>;' and 'return ...;'
          ;; An indentation engine can, so a rule for this is added there
          "of[ \t]+reverse\\|"
          "of\\|"
          "out\\|"
          "subtype\\|"
          "type"
          "\\)\\>[ \t]*"
          ada-name-regexp "?")
         '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t))

   ;; Keywords not treated elsewhere. After above so it doesn't
   ;; override fontication of second or third word in those patterns.
   (list (concat
          "\\<"
          (regexp-opt
           (append
            '("abort" "abs" "accept" "all"
              "and" "array" "at" "begin" "case" "declare" "delay" "delta"
              "digits" "do" "else" "elsif" "entry" "exception" "exit" "for"
              "generic" "if" "in" "limited" "loop" "mod" "not"
              "null" "or" "others" "private" "raise"
              "range" "record" "rem" "renames" "reverse"
              "select" "separate" "task" "terminate"
              "then" "when" "while" "xor")
            (when (member ada-language-version '(ada95 ada2005 ada2012))
              '("abstract" "aliased" "requeue" "tagged" "until"))
            (when (member ada-language-version '(ada2005 ada2012))
              '("interface" "overriding" "synchronized"))
            (when (member ada-language-version '(ada2012))
              '("some"))
            )
           t)
          "\\>")
         '(0 font-lock-keyword-face))

   ;; object and parameter declarations; word after ":" should be in
   ;; type-face if not already fontified or an exception.
   (list (concat
          ":[ \t]*"
          ada-name-regexp
          "[ \t]*\\(=>\\)?")
     '(1 (if (match-beginning 2)
             'default
           font-lock-type-face)
         nil t))

   ;; keywords followed by a name that should be in function-name-face if not already fontified
   (list (concat
          "\\<\\("
          "end"
          "\\)\\>[ \t]*"
          ada-name-regexp "?")
     '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t))

   ;; Keywords followed by a name that could be a type or a function (generic instantiation).
   (list (concat
          "\\<\\("
          "new"
          "\\)\\>[ \t]*"
          ada-name-regexp "?[ \t]*\\((\\)?")
         '(1 font-lock-keyword-face)
         '(2 (if (match-beginning 3)
                 font-lock-function-name-face
               font-lock-type-face)
             nil t))

   ;; keywords followed by a name that should be in type-face if not already fontified (for subtypes)
   ;; after "new" to handle "is new"
   (list (concat
          "\\<\\("
          "is"
          "\\)\\>[ \t]*"
          ada-name-regexp "?")
     '(1 font-lock-keyword-face) '(2 font-lock-type-face nil t))

   ;; Keywords followed by a comma separated list of names which
   ;; should be in constant-face, unless already fontified. Ada mode 4.01 used this.
   (list (concat
          "\\<\\("
          "goto\\|"
          "use\\|"
          ;; don't need "limited" "private" here; they are matched separately
          "with"; context clause
          "\\)\\>[ \t]*"
          "\\(\\(?:\\sw\\|[_., \t]\\)+\\>\\)?"; ada-name-regexp, plus ", \t"
          )
         '(1 font-lock-keyword-face) '(2 font-lock-constant-face nil t))

   ;; statement labels
   '("<<\\(\\sw+\\)>>" 1 font-lock-constant-face)

   ;; based numberic literals
   (list "\\([0-9]+#[0-9a-fA-F_]+#\\)" '(1 font-lock-constant-face t))

   ;; numeric literals
   (list "\\W\\([-+]?[0-9._]+\\)\\>" '(1 font-lock-constant-face))

   ))

;;;; ada-mode

;; ada-mode does not derive from prog-mode, because we need to call
;; ada-mode-post-local-vars, and prog-mode does not provide a way to
;; do that.
;;
;; autoload required by automatic mode setting
;;;###autoload
(defun ada-mode ()
  "The major mode for editing Ada code."
  ;; the other ada-*.el files add to ada-mode-hook for their setup

  (interactive)
  (kill-all-local-variables)
  (setq major-mode 'ada-mode)
  (setq mode-name "Ada")
  (use-local-map ada-mode-map)
  (set-syntax-table ada-mode-syntax-table)
  (define-abbrev-table 'ada-mode-abbrev-table ())
  (setq local-abbrev-table ada-mode-abbrev-table)

  (set (make-local-variable 'syntax-propertize-function) 'ada-syntax-propertize)
  (set (make-local-variable 'syntax-begin-function) nil)
  (set (make-local-variable 'parse-sexp-ignore-comments) t)
  (set (make-local-variable 'parse-sexp-lookup-properties) t)
  (set 'case-fold-search t); Ada is case insensitive; the syntax parsing requires this setting
  (set (make-local-variable 'comment-start) "--")
  (set (make-local-variable 'comment-end) "")
  (set (make-local-variable 'comment-start-skip) "---*[ \t]*")
  (set (make-local-variable 'comment-multi-line) nil)

  ;; we _don't_ set `fill-prefix' here because that causes
  ;; indent-region to use it for all indentation. See
  ;; ada-fill-comment-paragraph.

  ;; AdaCore standard style (enforced by -gnaty) requires two spaces
  ;; after '--' in comments; this makes it easier to distinguish
  ;; special comments that have something else after '--'
  (set (make-local-variable 'comment-padding) "  ")

  (set (make-local-variable 'require-final-newline) t)

  (setq font-lock-defaults
        '(ada-font-lock-keywords
          nil t
          ((?\_ . "w")))); treat underscore as a word component

  (set (make-local-variable 'ff-other-file-alist)
       'ada-other-file-alist)
  (setq ff-post-load-hook    'ada-set-point-accordingly
        ff-file-created-hook 'ada-ff-create-body)
  (add-hook 'ff-pre-load-hook 'ada-goto-push-pos)
  (add-hook 'ff-pre-load-hook 'ada-which-function)
  (setq ff-search-directories 'compilation-search-path)
  (when (null (car compilation-search-path))
    ;; find-file doesn't handle nil in search path
    (setq compilation-search-path (list (file-name-directory (buffer-file-name)))))
  (ada-set-ff-special-constructs)

  (set (make-local-variable 'add-log-current-defun-function)
       'ada-add-log-current-function)

  (when (boundp 'which-func-functions)
    (add-hook 'which-func-functions 'ada-which-function nil t))

  ;;  Support for align
  (add-to-list 'align-dq-string-modes 'ada-mode)
  (add-to-list 'align-open-comment-modes 'ada-mode)
  (set (make-local-variable 'align-region-separate) ada-align-region-separate)
  (set (make-local-variable 'align-indent-before-aligning) t)

  ;; Exclude comments alone on line from alignment.
  (add-to-list 'align-exclude-rules-list
               '(ada-solo-comment
                 (regexp  . "^\\(\\s-*\\)--")
                 (modes   . '(ada-mode))))
  (add-to-list 'align-exclude-rules-list
               '(ada-solo-use
                 (regexp  . "^\\(\\s-*\\)\\<use\\>")
                 (modes   . '(ada-mode))))

  (setq align-mode-rules-list ada-align-rules)

  (easy-menu-add ada-mode-menu ada-mode-map)

  (run-mode-hooks 'ada-mode-hook)

  ;; If global-font-lock is not enabled, ada-syntax-propertize is
  ;; not run when the text is first loaded into the buffer. Recover
  ;; from that.
  (syntax-ppss-flush-cache (point-min))
  (syntax-propertize (point-max))

  (add-hook 'hack-local-variables-hook 'ada-mode-post-local-vars nil t)
  )

(defun ada-mode-post-local-vars ()
  ;; These are run after ada-mode-hook and file local variables
  ;; because users or other ada-* files might set the relevant
  ;; variable inside the hook or file local variables (file local
  ;; variables are processed after the mode is set, and thus after
  ;; ada-mode is run).

  ;; This means to fully set ada-mode interactively, user must
  ;; do M-x ada-mode M-; (hack-local-variables)

  (when global-font-lock-mode
    ;; This calls ada-font-lock-keywords, which depends on
    ;; ada-language-version
    (font-lock-refresh-defaults))

  (cl-case ada-language-version
   (ada83
    (setq ada-keywords ada-83-keywords))

   (ada95
    (setq ada-keywords
          (append ada-83-keywords
                  ada-95-keywords)))

   (ada2005
    (setq ada-keywords
          (append ada-83-keywords
                  ada-95-keywords
                  ada-2005-keywords)))
   (ada2012
    (setq ada-keywords
          (append ada-83-keywords
                  ada-95-keywords
                  ada-2005-keywords
                  ada-2012-keywords))))

  (when ada-goto-declaration-start
    (set (make-local-variable 'beginning-of-defun-function) ada-goto-declaration-start))

  (when ada-goto-declaration-end
    (set (make-local-variable 'end-of-defun-function) ada-goto-declaration-end))
  )

(put 'ada-mode 'custom-mode-group 'ada)

(provide 'ada-mode)

;;;;; Global initializations

(require 'ada-build)

(unless (featurep 'ada-indent-engine)
  (require 'ada-wisi))

(unless (featurep 'ada-xref-tool)
  (cl-case ada-xref-tool
    ((nil 'gnat) (require 'ada-gnat-xref))
    ('gnat_inspect (require 'gnat-inspect))
    ('gpr_query (require 'gpr-query))
    ))

(unless (featurep 'ada-compiler)
  (require 'ada-gnat-compile))

(unless (featurep 'ada-skeletons)
  (require 'ada-skel))

(when (featurep 'imenu)
  (require 'ada-imenu))

;;; end of file