--- /dev/null
+;;; ada-mode.el --- major-mode for editing Ada sources
+;;
+;;; Copyright (C) 1994, 1995, 1997 - 2013 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.0
+;; package-requires: ((wisi "1.0"))
+;; 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-parse-file-ext' 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 'find-file)
+(require 'align)
+(require 'which-func)
+(require 'compile)
+
+(eval-when-compile (require 'cl-macs))
+
+(defun ada-mode-version ()
+ "Return Ada mode version."
+ (interactive)
+ (let ((version-string "5.0"))
+ ;; must match:
+ ;; ada-mode.texi
+ ;; README
+ ;; gpr-mode.el
+ ;; 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 an Ada keywords."
+ :type '(choice (const downcase-word)
+ (const upcase-word))
+ :group 'ada
+ :safe 'functionp)
+(make-variable-buffer-local 'ada-case-keyword)
+
+(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'.
+Only affects the keywords to highlight."
+ :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)
+
+(defcustom ada-fill-comment-postfix " --"
+ "Comment fill postfix."
+ :type 'string
+ :group 'ada)
+
+(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-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\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-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]
+ )
+ ("Edit"
+ ["Expand skeleton" ada-expand t]
+ ["Indent line" 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 selection" comment-region t]
+ ["Uncomment selection" (comment-region t) 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]
+ ["Refresh cross reference cache" ada-xref-refresh t]
+ )))
+
+;; 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] ;; FIXME: include only if will succeed
+ ["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] ;; FIXME: only if skeleton
+ ["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-*\\)--")
+ (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 2)" here; missing a match
+ ;; is a bug in the regexp.
+ (goto-char (match-beginning 2))
+ (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)))
+ )
+
+ (unless (save-excursion (skip-chars-backward " \t") (bolp))
+ ;; paramlist starts on same line as subprogram identifier; clean up whitespace
+ (end-of-line)
+ (delete-char (- (skip-syntax-backward " ")))
+ (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-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
+ (error
+ "No exception file specified. 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_]+\\)"))
+
+(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-case-adjust-identifier ()
+ "Adjust case of the previous word as an identifier.
+Uses Mixed_Case, 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 Mixed_Case and partial-exceptions
+ (if ada-case-strict
+ (downcase-region start end))
+ (while (not done)
+ (setq next
+ (or
+ (save-excursion (when (search-forward "_" end t) (point-marker)))
+ (copy-marker (1+ end))))
+
+ (if (setq match (assoc-string (buffer-substring-no-properties start (1- next))
+ ada-case-partial-exceptions t))
+ (progn
+ ;; see comment above at 'full word exception' for why
+ ;; we do insert first.
+ (insert (car match))
+ (delete-region (point) (1- next)))
+
+ ;; else 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 (&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))
+ ))
+
+ (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))
+ (memq (char-syntax (char-after)) '(?w ?_)))
+ (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)
+ "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)
+ (ada-case-adjust lastk)
+ (funcall ada-lfd-binding))
+
+ ((eq lastk ?\r)
+ (ada-case-adjust lastk)
+ (funcall ada-ret-binding))
+
+ (t
+ (ada-case-adjust lastk)
+ (self-insert-command (prefix-numeric-value arg)))
+ )
+ ))
+
+(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. So we make ada-mode-map buffer local, and don't
+ ;; call this function if ada-auto-case is off. That means
+ ;; ada-auto-case cannot be changed after an Ada buffer is created.
+
+ ;; The 'or ...' is there to be sure that the value will not be
+ ;; changed again when Ada mode 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")))
+
+ (mapcar (function
+ (lambda(key)
+ (define-key
+ ada-mode-map
+ (char-to-string key)
+ 'ada-case-adjust-interactive)))
+ '( ?_ ?% ?& ?* ?( ?) ?- ?= ?+
+ ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?/ ?\n 32 ?\r ))
+ )
+
+;;;; 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'."
+ (plist-get (or plist ada-prj-current-project) prop))
+
+(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
+ 'ada_ref_tool ada-xref-tool
+ 'auto_case ada-auto-case
+ 'case_keyword ada-case-keyword
+ '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.
+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))
+
+ (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_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))
+
+;;;; 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")
+ (let ((modified (buffer-modified-p))
+ (buffer-undo-list t)
+ (inhibit-read-only t)
+ (inhibit-point-motion-hooks t)
+ (inhibit-modification-hooks t))
+ (goto-char start)
+ (while (re-search-forward
+ (concat
+ "[^a-zA-Z0-9)]\\('\\)[^'\n]\\('\\)"; 1, 2: character constants, not attributes
+ "\\|[^a-zA-Z0-9)]\\('''\\)"; 3: character constant '''
+ "\\|\\(--\\)"; 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)
+ (unless modified
+ (restore-buffer-modified-p nil))))
+
+(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
+ ;; depends on ada-compiler, per-project
+ "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)
+ (when (search-forward-regexp ff-function-name nil t)
+ (setq found (match-beginning 0)))
+ (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-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")
+ (when (null (car compilation-search-path))
+ (error "no file search path defined; set project file?"))
+
+ (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"))
+ )))
+
+(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."
+ (setq file (ff-get-file-name compilation-search-path file))
+ (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
+- 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")
+
+ (when (null ada-xref-other-function)
+ (error "no cross reference information available"))
+
+ (let ((target
+ (funcall ada-xref-other-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)
+ ))
+
+(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)
+ (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)
+
+ (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)
+ (cl-case (char-after)
+ (?\" (+ 2 (current-column))) ;; FIXME: work around bug in gnat find
+ (t (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)
+
+ (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")
+
+ (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.
+ "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-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 compiler
+ "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)
+ (if ada-make-package-body
+ (funcall ada-make-package-body body-file-name)
+ (error "`ada-make-package-body' not set")))
+
+(defun ada-ff-create-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.")
+
+(defvar ada-keywords nil
+ "List of Ada keywords for current `ada-language-version'.")
+
+(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
+
+;; 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-which-function)
+ (setq ff-search-directories 'compilation-search-path)
+ (ada-set-ff-special-constructs)
+
+ (set (make-local-variable 'add-log-current-defun-function)
+ 'ada-add-log-current-function)
+
+ (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 ada-auto-case (ada-case-activate-keys))
+
+ (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))))
+ )
+
+(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-compiler)
+ (require 'ada-gnat-compile))
+
+(unless (featurep 'ada-xref-tool)
+ (require 'ada-gnat-xref))
+
+(unless (featurep 'ada-skeletons)
+ (require 'ada-skel))
+
+;;; end of file