-;;; ada-mode.el --- An Emacs major-mode for editing Ada source.
-
-;; Copyright (C) 1994, 1995, 1997 Free Software Foundation, Inc.
-
-;; Authors: Rolf Ebert <re@waporo.muc.de>
-;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
-;; Maintainer: Emmanual Briot <briot@gnat.com>
-;; Keywords: languages oop ada
-;; Rolf Ebert's version: 2.27
-
-;; 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 2, 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; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; This mode is a complete rewrite of a major mode for editing Ada 83
-;;; and Ada 95 source code under Emacs-19. It contains completely new
-;;; indenting code and support for code browsing (see ada-xref).
-
-
-;;; USAGE
-;;; =====
-;;; Emacs should enter Ada mode when you load an Ada source (*.ad[abs]).
-;;;
-;;; When you have entered ada-mode, you may get more info by pressing
-;;; C-h m. You may also get online help describing various functions by:
-;;; C-h d <Name of function you want described>
-
-
-;;; 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. It is currently available from the PAL
-;;; (wuarchive.wustl.edu:/languages/ada) as ada-mode-1.06a.tar.Z.
-;;;
-;;; 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.
-;;;
-;;; The current Ada mode is a complete rewrite by M. Heritsch and
-;;; R. Ebert. 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. Perhaps you prefer sticking
-;;; to his version.
-
-
-;;; KNOWN BUGS
-;;; ==========
-;;;
-;;; In the presence of comments and/or incorrect syntax
-;;; ada-format-paramlist produces weird results.
-;;; -------------------
-;;; Character constants with otherwise syntactic relevant characters
-;;; like `(' or `"' throw indentation off the track. Fontification
-;;; should work now in Emacs-19.35
-;;; C : constant Character := Character'('"');
-;;; -------------------
-
-
-;;; TODO
-;;; ====
-;;;
-;;; o bodify-single-subprogram
-;;; o make a function "separate" and put it in the corresponding file.
-
-
-
-;;; CREDITS
-;;; =======
-;;;
-;;; Many thanks to
-;;; 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@LANG8.CS.NYU.EDU (Cyrille Comar)
-;;; and others for their valuable hints.
-\f
-;;;--------------------
-;;; USER OPTIONS
-;;;--------------------
-
-
-;; ---- customize support
-
-(defgroup ada nil
- "Major mode for editing Ada source in Emacs"
- :group 'languages)
-
-;; ---- configure indentation
-
-(defcustom ada-indent 3
- "*Defines the size of Ada indentation."
- :type 'integer
- :group 'ada)
-
-(defcustom ada-broken-indent 2
- "*# of columns to indent the continuation of a broken line."
- :type 'integer
- :group 'ada)
-
-(defcustom ada-label-indent -4
- "*# of columns to indent a label."
- :type 'integer
- :group 'ada)
-
-(defcustom ada-stmt-end-indent 0
- "*# of columns to indent a statement end keyword in a separate line.
-Examples are 'is', 'loop', 'record', ..."
- :type 'integer
- :group 'ada)
-
-(defcustom ada-when-indent 3
- "*Defines the indentation for 'when' relative to 'exception' or 'case'."
- :type 'integer
- :group 'ada)
-
-(defcustom ada-indent-record-rel-type 3
- "*Defines the indentation for 'record' relative to 'type' or 'use'."
- :type 'integer
- :group 'ada)
-
-(defcustom ada-indent-comment-as-code t
- "*If non-nil, comment-lines get indented as Ada code."
- :type 'boolean
- :group 'ada)
-
-(defcustom ada-indent-is-separate t
- "*If non-nil, 'is separate' or 'is abstract' on a single line are indented."
- :type 'boolean
- :group 'ada)
-
-(defcustom ada-indent-to-open-paren t
- "*If non-nil, indent according to the innermost open parenthesis."
- :type 'boolean
- :group 'ada)
-
-(defcustom ada-search-paren-char-count-limit 3000
- "*Search that many characters for an open parenthesis."
- :type 'integer
- :group 'ada)
-
-
-;; ---- other user options
-
-(defcustom ada-tab-policy 'indent-auto
- "*Control behaviour of the TAB key.
-Must be one of `indent-rigidly', `indent-auto', `gei', `indent-af'
-or `always-tab'.
-
-`indent-rigidly' : always adds ada-indent blanks at the beginning of the line.
-`indent-auto' : use indentation functions in this file.
-`gei' : use David Kågedal's Generic Indentation Engine.
-`indent-af' : use Gary E. Barnes' ada-format.el
-`always-tab' : do indent-relative."
- :type '(choice (const indent-auto)
- (const indent-rigidly)
- (const gei)
- (const indent-af)
- (const always-tab))
- :group 'ada)
-
-(defcustom ada-move-to-declaration nil
- "*If non-nil, `ada-move-to-start' moves point to the subprog declaration,
-not to 'begin'."
- :type 'boolean
- :group 'ada)
-
-(defcustom ada-spec-suffix ".ads"
- "*Suffix of Ada specification files."
- :type 'string
- :group 'ada)
-
-(defcustom ada-body-suffix ".adb"
- "*Suffix of Ada body files."
- :type 'string
- :group 'ada)
-
-(defcustom ada-spec-suffix-as-regexp "\\.ads$"
- "*Regexp to find Ada specification files."
- :type 'string
- :group 'ada)
-
-(defcustom ada-body-suffix-as-regexp "\\.adb$"
- "*Regexp to find Ada body files."
- :type 'string
- :group 'ada)
-
-(defvar ada-other-file-alist
- (list
- (list ada-spec-suffix-as-regexp (list ada-body-suffix))
- (list ada-body-suffix-as-regexp (list ada-spec-suffix))
- )
- "*Alist of extensions to find given the current file's extension.
-
-This list should contain the most used extensions before the others,
-since the search algorithm searches sequentially through each directory
-specified in `ada-search-directories'. If a file is not found, a new one
-is created with the first matching extension (`.adb' yields `.ads').")
-
-(defcustom ada-search-directories
- '("." "/usr/adainclude" "/usr/local/adainclude" "/opt/gnu/adainclude")
- "*List of directories to search for Ada files.
-See the description for the `ff-search-directories' variable."
- :type '(repeat (choice :tag "Directory"
- (const :tag "default" nil)
- (directory :format "%v")))
- :group 'ada)
-
-(defcustom ada-language-version 'ada95
- "*Do we program in `ada83' or `ada95'?"
- :type '(choice (const ada83)
- (const ada95))
- :group 'ada)
-
-(defcustom ada-case-keyword 'downcase-word
- "*Function to call to adjust the case of Ada keywords.
-It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
-`capitalize-word'."
- :type '(choice (const downcase-word)
- (const upcase-word)
- (const capitalize-word)
- (const ada-loose-case-word))
- :group 'ada)
-
-(defcustom ada-case-identifier 'ada-loose-case-word
- "*Function to call to adjust the case of an Ada identifier.
-It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
-`capitalize-word'."
- :type '(choice (const downcase-word)
- (const upcase-word)
- (const capitalize-word)
- (const ada-loose-case-word))
- :group 'ada)
-
-(defcustom ada-case-attribute 'capitalize-word
- "*Function to call to adjust the case of Ada attributes.
-It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
-`capitalize-word'."
- :type '(choice (const downcase-word)
- (const upcase-word)
- (const capitalize-word)
- (const ada-loose-case-word))
- :group 'ada)
-
-(defcustom ada-auto-case t
- "*Non-nil automatically changes case of preceding word while typing.
-Casing is done according to `ada-case-keyword', `ada-case-identifier'
-and `ada-case-attribute'."
- :type 'boolean
- :group 'ada)
-
-(defcustom ada-clean-buffer-before-saving t
- "*If non-nil, `remove-trailing-spaces' and `untabify' buffer before saving."
- :type 'boolean
- :group 'ada)
-
-(defvar ada-mode-hook nil
- "*List of functions to call when Ada mode is invoked.
-This is a good place to add Ada environment specific bindings.")
-
-(defcustom ada-external-pretty-print-program "aimap"
- "*External pretty printer to call from within Ada mode."
- :type 'string
- :group 'ada)
-
-(defcustom ada-tmp-directory "/tmp/"
- "*Directory to store the temporary file for the Ada pretty printer."
- :type 'string
- :group 'ada)
-
-(defcustom ada-compile-options "-c"
- "*Buffer local options passed to the Ada compiler.
-These options are used when the compiler is invoked on the current buffer."
- :type 'string
- :group 'ada)
-(make-variable-buffer-local 'ada-compile-options)
-
-(defcustom ada-make-options "-c"
- "*Buffer local options passed to `ada-compiler-make' (usually `gnatmake').
-These options are used when `gnatmake' is invoked on the current buffer."
- :type 'string
- :group 'ada)
-(make-variable-buffer-local 'ada-make-options)
-
-(defcustom ada-compiler-syntax-check "gcc -c -gnats"
- "*Compiler command with options for syntax checking."
- :type 'string
- :group 'ada)
-
-(defcustom ada-compiler-make "gnatmake"
- "*The `make' command for the given compiler."
- :type 'string
- :group 'ada)
-
-(defcustom ada-fill-comment-prefix "-- "
- "*This is inserted in the first columns when filling a comment paragraph."
- :type 'string
- :group 'ada)
-
-(defcustom ada-fill-comment-postfix " --"
- "*This is inserted at the end of each line when filling a comment paragraph.
-with `ada-fill-comment-paragraph-postfix'."
- :type 'string
- :group 'ada)
-
-(defcustom ada-krunch-args "0"
- "*Argument of gnatkr, a string containing the max number of characters.
-Set to 0, if you don't use crunched filenames."
- :type 'string
- :group 'ada)
-
-;;; ---- end of user configurable variables
-\f
-
-(defvar ada-mode-abbrev-table nil
- "Abbrev table used in Ada mode.")
-(define-abbrev-table 'ada-mode-abbrev-table ())
-
-(defvar ada-mode-map ()
- "Local keymap used for Ada mode.")
-
-(defvar ada-mode-syntax-table nil
- "Syntax table to be used for editing Ada source code.")
-
-(defvar ada-mode-symbol-syntax-table nil
- "Syntax table for Ada, where `_' is a word constituent.")
-
-(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\\)\\>"
-; "\\<\\(a\\(b\\(ort\\|s\\)\\|cce\\(pt\\|ss\\)\\|ll\\|nd\\|rray\\|t\\)\\|\
-;b\\(egin\\|ody\\)\\|c\\(ase\\|onstant\\)\\|\
-;d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|\
-;e\\(ls\\(e\\|if\\)\\|n\\(d\\|try\\)\\|x\\(ception\\|it\\)\\)\\|\
-;f\\(or\\|unction\\)\\|g\\(eneric\\|oto\\)\\|i[fns]\\|l\\(imited\\|oop\\)\\|\
-;mod\\|n\\(ew\\|ot\\|ull\\)\\|o\\([fr]\\|thers\\|ut\\)\\|\
-;p\\(ackage\\|r\\(agma\\|ivate\\|ocedure\\)\\)\\|\
-;r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|turn\\|verse\\)\\)\\|\
-;s\\(e\\(lect\\|parate\\)\\|ubtype\\)\\|use\\|
-;t\\(ask\\|erminate\\|hen\\|ype\\)\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\|xor\\)\\>"
- "Regular expression for looking at Ada83 keywords.")
-
-(defconst ada-95-keywords
- "\\<\\(abort\\|abs\\|abstract\\|accept\\|access\\|aliased\\|\
-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\\|protected\\|raise\\|\
-range\\|record\\|rem\\|renames\\|requeue\\|return\\|reverse\\|\
-select\\|separate\\|subtype\\|tagged\\|task\\|terminate\\|then\\|\
-type\\|until\\|use\\|when\\|while\\|with\\|xor\\)\\>"
- "Regular expression for looking at Ada95 keywords.")
-
-(defvar ada-keywords ada-95-keywords
- "Regular expression for looking at Ada keywords.")
-
-(defvar ada-ret-binding nil
- "Variable to save key binding of RET when casing is activated.")
-
-(defvar ada-lfd-binding nil
- "Variable to save key binding of LFD when casing is activated.")
-
-;;; ---- Regexps to find procedures/functions/packages
-
-(defconst ada-ident-re
- "[a-zA-Z0-9_\\.]+"
- "Regexp matching Ada (qualified) identifiers.")
-
-(defvar ada-procedure-start-regexp
- "^[ \t]*\\(procedure\\|function\\|task\\)[ \t\n]+\\([a-zA-Z0-9_\\.]+\\)"
- "Regexp used to find Ada procedures/functions.")
-
-(defvar ada-package-start-regexp
- "^[ \t]*\\(package\\)"
- "Regexp used to find Ada packages")
-
-
-;;; ---- regexps for indentation functions
-
-(defvar ada-block-start-re
- "\\<\\(begin\\|select\\|declare\\|private\\|or\\|generic\\|\
-exception\\|loop\\|else\\|\
-\\(\\(limited\\|abstract\\|tagged\\)[ \t]+\\)*record\\)\\>"
- "Regexp for keywords starting Ada blocks.")
-
-(defvar ada-end-stmt-re
- "\\(;\\|=>\\|^[ \t]*separate[ \t]+([a-zA-Z0-9_\\.]+)\\|\
-\\<\\(begin\\|else\\|record\\|loop\\|select\\|do\\|then\\|\
-declare\\|generic\\|private\\)\\>\\|\
-^[ \t]*\\(package\\|procedure\\|function\\)\\>[ \ta-zA-Z0-9_\\.]+\\<is\\>\\|\
-^[ \t]*exception\\>\\)"
- "Regexp of possible ends for a non-broken statement.
-A new statement starts after these.")
-
-(defvar ada-loop-start-re
- "\\<\\(for\\|while\\|loop\\)\\>"
- "Regexp for the start of a loop.")
-
-(defvar ada-subprog-start-re
- "\\<\\(procedure\\|protected\\|package\\|function\\|\
-task\\|accept\\|entry\\)\\>"
- "Regexp for the start of a subprogram.")
-
-(defvar ada-named-block-re
- "[ \t]*[a-zA-Z_0-9]+ *:[^=]"
- "Regexp of the name of a block or loop.")
-
-\f
-;; Written by Christian Egli <Christian.Egli@hcsd.hac.com>
-;;
-(defvar ada-imenu-generic-expression
- '((nil "^\\s-*\\(procedure\\|function\\)\\s-+\\([A-Za-z0-9_]+\\)" 2)
- ("Type Defs" "^\\s-*\\(sub\\)?type\\s-+\\([A-Za-z0-9_]+\\)" 2))
-
- "Imenu generic expression for Ada mode. See `imenu-generic-expression'.")
-\f
-;;;-------------
-;;; functions
-;;;-------------
-
-(defun ada-xemacs ()
- (or (string-match "Lucid" emacs-version)
- (string-match "XEmacs" emacs-version)))
-
-(defun ada-create-syntax-table ()
- "Create the syntax table for Ada mode."
- ;; There are two different syntax-tables. The standard one declares
- ;; `_' as a symbol constituent, in the second one, it is a word
- ;; constituent. For some search and replacing routines we
- ;; temporarily switch between the two.
- (setq ada-mode-syntax-table (make-syntax-table))
- (set-syntax-table ada-mode-syntax-table)
-
- ;; define string brackets (`%' is alternative string bracket, but
- ;; almost never used as such and throws font-lock and indentation
- ;; off the track.)
- (modify-syntax-entry ?% "$" ada-mode-syntax-table)
- (modify-syntax-entry ?\" "\"" ada-mode-syntax-table)
-
- (modify-syntax-entry ?\# "$" ada-mode-syntax-table)
-
- (modify-syntax-entry ?: "." ada-mode-syntax-table)
- (modify-syntax-entry ?\; "." ada-mode-syntax-table)
- (modify-syntax-entry ?& "." ada-mode-syntax-table)
- (modify-syntax-entry ?\| "." ada-mode-syntax-table)
- (modify-syntax-entry ?+ "." ada-mode-syntax-table)
- (modify-syntax-entry ?* "." ada-mode-syntax-table)
- (modify-syntax-entry ?/ "." ada-mode-syntax-table)
- (modify-syntax-entry ?= "." ada-mode-syntax-table)
- (modify-syntax-entry ?< "." ada-mode-syntax-table)
- (modify-syntax-entry ?> "." ada-mode-syntax-table)
- (modify-syntax-entry ?$ "." ada-mode-syntax-table)
- (modify-syntax-entry ?\[ "." ada-mode-syntax-table)
- (modify-syntax-entry ?\] "." ada-mode-syntax-table)
- (modify-syntax-entry ?\{ "." ada-mode-syntax-table)
- (modify-syntax-entry ?\} "." ada-mode-syntax-table)
- (modify-syntax-entry ?. "." ada-mode-syntax-table)
- (modify-syntax-entry ?\\ "." ada-mode-syntax-table)
- (modify-syntax-entry ?\' "." ada-mode-syntax-table)
-
- ;; a single hyphen is punctuation, but a double hyphen starts a comment
- (modify-syntax-entry ?- ". 12" ada-mode-syntax-table)
-
- ;; and \f and \n end a comment
- (modify-syntax-entry ?\f "> " ada-mode-syntax-table)
- (modify-syntax-entry ?\n "> " ada-mode-syntax-table)
-
- ;; define what belongs in Ada symbols
- (modify-syntax-entry ?_ "_" ada-mode-syntax-table)
-
- ;; define parentheses to match
- (modify-syntax-entry ?\( "()" ada-mode-syntax-table)
- (modify-syntax-entry ?\) ")(" ada-mode-syntax-table)
-
- (setq ada-mode-symbol-syntax-table (copy-syntax-table ada-mode-syntax-table))
- (modify-syntax-entry ?_ "w" ada-mode-symbol-syntax-table)
- )
-
-
-;;;###autoload
-(defun ada-mode ()
- "Ada mode is the major mode for editing Ada code.
-
-Bindings are as follows: (Note: 'LFD' is control-j.)
-
- Indent line '\\[ada-tab]'
- Indent line, insert newline and indent the new line. '\\[newline-and-indent]'
-
- Re-format the parameter-list point is in '\\[ada-format-paramlist]'
- Indent all lines in region '\\[ada-indent-region]'
- Call external pretty printer program '\\[ada-call-pretty-printer]'
-
- Adjust case of identifiers and keywords in region '\\[ada-adjust-case-region]'
- Adjust case of identifiers and keywords in buffer '\\[ada-adjust-case-buffer]'
-
- Call EXTERNAL pretty printer (if you have one) '\\[ada-call-pretty-printer]'
-
- Fill comment paragraph '\\[ada-fill-comment-paragraph]'
- Fill comment paragraph and justify each line '\\[ada-fill-comment-paragraph-justify]'
- Fill comment paragraph, justify and append postfix '\\[ada-fill-comment-paragraph-postfix]'
-
- Next func/proc/task '\\[ada-next-procedure]' Previous func/proc/task '\\[ada-previous-procedure]'
- Next package '\\[ada-next-package]' Previous package '\\[ada-previous-package]'
-
- Goto matching start of current 'end ...;' '\\[ada-move-to-start]'
- Goto end of current block '\\[ada-move-to-end]'
-
-Comments are handled using standard GNU Emacs conventions, including:
- Start a comment '\\[indent-for-comment]'
- Comment region '\\[comment-region]'
- Uncomment region '\\[ada-uncomment-region]'
- Continue comment on next line '\\[indent-new-comment-line]'
-
-If you use imenu.el:
- Display index-menu of functions & procedures '\\[imenu]'
-
-If you use find-file.el:
- Switch to other file (Body <-> Spec) '\\[ff-find-other-file]'
- or '\\[ff-mouse-find-other-file]
- Switch to other file in other window '\\[ada-ff-other-window]'
- or '\\[ff-mouse-find-other-file-other-window]
- If you use this function in a spec and no body is available, it gets created
- with body stubs.
-
-If you use ada-xref.el:
- Goto declaration: '\\[ada-point-and-xref]' on the identifier
- or '\\[ada-goto-declaration]' with point on the identifier
- Complete identifier: '\\[ada-complete-identifier]'
- Execute Gnatf: '\\[ada-gnatf-current]'"
-
- (interactive)
- (kill-all-local-variables)
-
- (make-local-variable 'require-final-newline)
- (setq require-final-newline t)
-
- (make-local-variable 'comment-start)
- (setq comment-start "-- ")
-
- ;; comment end must be set because it may hold a wrong value if
- ;; this buffer had been in another mode before. RE
- (make-local-variable 'comment-end)
- (setq comment-end "")
-
- (make-local-variable 'comment-start-skip) ;; used by autofill
- (setq comment-start-skip "--+[ \t]*")
-
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'ada-indent-current-function)
-
- (make-local-variable 'fill-column)
- (setq fill-column 75)
-
- (make-local-variable 'comment-column)
- (setq comment-column 40)
-
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments t)
-
- (make-local-variable 'case-fold-search)
- (setq case-fold-search t)
-
- (make-local-variable 'outline-regexp)
- (setq outline-regexp "[^\n\^M]")
- (make-local-variable 'outline-level)
- (setq outline-level 'ada-outline-level)
-
- (make-local-variable 'fill-paragraph-function)
- (setq fill-paragraph-function 'ada-fill-comment-paragraph)
- ;;(make-local-variable 'adaptive-fill-regexp)
-
- (make-local-variable 'imenu-generic-expression)
- (setq imenu-generic-expression ada-imenu-generic-expression)
- (setq imenu-case-fold-search t)
-
- (if (ada-xemacs) nil ; XEmacs uses properties
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults
- '((ada-font-lock-keywords
- ada-font-lock-keywords-1 ada-font-lock-keywords-2)
- nil t
- ((?\_ . "w")(?\. . "w"))
- beginning-of-line
- (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords)))
-
- ;; Set up support for find-file.el.
- (make-variable-buffer-local 'ff-other-file-alist)
- (make-variable-buffer-local 'ff-search-directories)
- (setq ff-other-file-alist 'ada-other-file-alist
- ff-search-directories 'ada-search-directories
- ff-pre-load-hooks 'ff-which-function-are-we-in
- ff-post-load-hooks 'ff-set-point-accordingly
- ff-file-created-hooks 'ada-make-body))
-
- (setq major-mode 'ada-mode)
- (setq mode-name "Ada")
-
- (use-local-map ada-mode-map)
-
- (if ada-mode-syntax-table
- (set-syntax-table ada-mode-syntax-table)
- (ada-create-syntax-table))
-
- (if ada-clean-buffer-before-saving
- (progn
- ;; remove all spaces at the end of lines in the whole buffer.
- (add-hook 'local-write-file-hooks 'ada-remove-trailing-spaces)
- ;; convert all tabs to the correct number of spaces.
- (add-hook 'local-write-file-hooks 'ada-untabify-buffer)))
-
-
- ;; add menu 'Ada' to the menu bar
- (ada-add-ada-menu)
-
- (run-hooks 'ada-mode-hook)
-
- ;; the following has to be done after running the ada-mode-hook
- ;; because users might want to set the values of these variable
- ;; inside the hook (MH)
-
- (cond ((eq ada-language-version 'ada83)
- (setq ada-keywords ada-83-keywords))
- ((eq ada-language-version 'ada95)
- (setq ada-keywords ada-95-keywords)))
-
- (if ada-auto-case
- (ada-activate-keys-for-case)))
-
-\f
-;;;--------------------------
-;;; Compile support
-;;;--------------------------
-
-(defun ada-check-syntax ()
- "Check syntax of the current buffer.
-Uses the function `compile' to execute `ada-compiler-syntax-check'."
- (interactive)
- (let ((old-compile-command compile-command))
- (setq compile-command (concat ada-compiler-syntax-check
- (if (eq ada-language-version 'ada83)
- "-gnat83 ")
- " " ada-compile-options " "
- (buffer-name)))
- (setq compile-command (read-from-minibuffer
- "enter command for syntax check: "
- compile-command))
- (compile compile-command)
- ;; restore old compile-command
- (setq compile-command old-compile-command)))
-
-(defun ada-make-local ()
- "Bring current Ada unit up-to-date.
-Uses the function `compile' to execute `ada-compile-make'."
- (interactive)
- (let ((old-compile-command compile-command))
- (setq compile-command (concat ada-compiler-make
- " " ada-make-options " "
- (buffer-name)))
- (setq compile-command (read-from-minibuffer
- "enter command for local make: "
- compile-command))
- (compile compile-command)
- ;; restore old compile-command
- (setq compile-command old-compile-command)))
-
-
-
-\f
-;;;--------------------------
-;;; Fill Comment Paragraph
-;;;--------------------------
-
-(defun ada-fill-comment-paragraph-justify ()
- "Fills current comment paragraph and justifies each line as well."
- (interactive)
- (ada-fill-comment-paragraph t))
-
-
-(defun ada-fill-comment-paragraph-postfix ()
- "Fills current comment paragraph and justifies each line as well.
-Prompts for a postfix to be appended to each line."
- (interactive)
- (ada-fill-comment-paragraph t t))
-
-
-(defun ada-fill-comment-paragraph (&optional justify postfix)
- "Fills 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 filled and justified line.
-If `ada-indent-comment-as-code' is non-nil, the paragraph is idented."
- (interactive "P")
- (let ((opos (point-marker))
- (begin nil)
- (end nil)
- (end-2 nil)
- (indent nil)
- (ada-fill-comment-old-postfix "")
- (fill-prefix nil))
-
- ;; check if inside comment
- (if (not (ada-in-comment-p))
- (error "not inside comment"))
-
- ;; prompt for postfix if wanted
- (if (and justify
- postfix)
- (setq ada-fill-comment-postfix
- (read-from-minibuffer "enter new postfix string: "
- ada-fill-comment-postfix)))
-
- ;; prompt for old postfix to remove if necessary
- (if (and justify
- postfix)
- (setq ada-fill-comment-old-postfix
- (read-from-minibuffer "enter already existing postfix string: "
- ada-fill-comment-postfix)))
-
- ;;
- ;; find limits of paragraph
- ;;
- (message "filling comment paragraph ...")
- (save-excursion
- (back-to-indentation)
- ;; find end of paragraph
- (while (and (looking-at "--.*$")
- (not (looking-at "--[ \t]*$")))
- (forward-line 1)
- (back-to-indentation))
- (beginning-of-line)
- (setq end (point-marker))
- (goto-char opos)
- ;; find begin of paragraph
- (back-to-indentation)
- (while (and (looking-at "--.*$")
- (not (looking-at "--[ \t]*$")))
- (forward-line -1)
- (back-to-indentation))
- (forward-line 1)
- ;; get indentation to calculate width for filling
- (ada-indent-current)
- (back-to-indentation)
- (setq indent (current-column))
- (setq begin (point-marker)))
-
- ;; delete old postfix if necessary
- (if (and justify
- postfix)
- (save-excursion
- (goto-char begin)
- (while (re-search-forward (concat ada-fill-comment-old-postfix
- "\n")
- end t)
- (replace-match "\n"))))
-
- ;; delete leading whitespace and uncomment
- (save-excursion
- (goto-char begin)
- (beginning-of-line)
- (while (re-search-forward "^[ \t]*--[ \t]*" end t)
- (replace-match "")))
-
- ;; calculate fill width
- (setq fill-column (- fill-column indent
- (length ada-fill-comment-prefix)
- (if postfix
- (length ada-fill-comment-postfix)
- 0)))
- ;; fill paragraph
- (fill-region begin (1- end) justify)
- (setq fill-column (+ fill-column indent
- (length ada-fill-comment-prefix)
- (if postfix
- (length ada-fill-comment-postfix)
- 0)))
- ;; find end of second last line
- (save-excursion
- (goto-char end)
- (forward-line -2)
- (end-of-line)
- (setq end-2 (point-marker)))
-
- ;; re-comment and re-indent region
- (save-excursion
- (goto-char begin)
- (indent-to indent)
- (insert ada-fill-comment-prefix)
- (while (re-search-forward "\n" (1- end-2) t)
- (replace-match (concat "\n" ada-fill-comment-prefix))
- (beginning-of-line)
- (indent-to indent)))
-
- ;; append postfix if wanted
- (if (and justify
- postfix
- ada-fill-comment-postfix)
- (progn
- ;; append postfix up to there
- (save-excursion
- (goto-char begin)
- (while (re-search-forward "\n" (1- end-2) t)
- (replace-match (concat ada-fill-comment-postfix "\n")))
-
- ;; fill last line and append postfix
- (end-of-line)
- (insert-char ?
- (- fill-column
- (current-column)
- (length ada-fill-comment-postfix)))
- (insert ada-fill-comment-postfix))))
-
- ;; delete the extra line that gets inserted somehow(??)
- (save-excursion
- (goto-char (1- end))
- (end-of-line)
- (delete-char 1))
-
- (message "filling comment paragraph ... done")
- (goto-char opos))
- t)
-
-\f
-;;;--------------------------------;;;
-;;; Call External Pretty Printer ;;;
-;;;--------------------------------;;;
-
-(defun ada-call-pretty-printer ()
- "Calls the external Pretty Printer.
-The name is specified in `ada-external-pretty-print-program'. Saves the
-current buffer in a directory specified by `ada-tmp-directory',
-starts the pretty printer as external process on that file and then
-reloads the beautified program in the buffer and cleans up
-`ada-tmp-directory'."
- (interactive)
- (let ((filename-with-path buffer-file-name)
- (curbuf (current-buffer))
- (orgpos (point))
- (mesgbuf nil) ;; for byte-compiling
- (file-path (file-name-directory buffer-file-name))
- (filename-without-path (file-name-nondirectory buffer-file-name))
- (tmp-file-with-directory
- (concat ada-tmp-directory
- (file-name-nondirectory buffer-file-name))))
- ;;
- ;; save buffer in temporary file
- ;;
- (message "saving current buffer to temporary file ...")
- (write-file tmp-file-with-directory)
- (auto-save-mode nil)
- (message "saving current buffer to temporary file ... done")
- ;;
- ;; call external pretty printer program
- ;;
-
- (message "running external pretty printer ...")
- ;; create a temporary buffer for messages of pretty printer
- (setq mesgbuf (get-buffer-create "Pretty Printer Messages"))
- ;; execute pretty printer on temporary file
- (call-process ada-external-pretty-print-program
- nil mesgbuf t
- tmp-file-with-directory)
- ;; display messages if there are some
- (if (buffer-modified-p mesgbuf)
- ;; show the message buffer
- (display-buffer mesgbuf t)
- ;; kill the message buffer
- (kill-buffer mesgbuf))
- (message "running external pretty printer ... done")
- ;;
- ;; kill current buffer and load pretty printer output
- ;; or restore old buffer
- ;;
- (if (y-or-n-p
- "Really replace current buffer with pretty printer output ? ")
- (progn
- (set-buffer-modified-p nil)
- (kill-buffer curbuf)
- (find-file tmp-file-with-directory))
- (message "old buffer contents restored"))
- ;;
- ;; delete temporary file and restore information of current buffer
- ;;
- (delete-file tmp-file-with-directory)
- (set-visited-file-name filename-with-path)
- (auto-save-mode t)
- (goto-char orgpos)))
-
-\f
-;;;---------------
-;;; auto-casing
-;;;---------------
-
-;; from Philippe Waroquiers <philippe@cfmu.eurocontrol.be>
-;; modified by RE and MH
-
-(defun ada-after-keyword-p ()
- ;; returns t if cursor is after a keyword.
- (save-excursion
- (forward-word -1)
- (and (save-excursion
- (or
- (= (point) (point-min))
- (backward-char 1))
- (not (looking-at "_"))) ; (MH)
- (looking-at (concat ada-keywords "[^_]")))))
-
-(defun ada-in-char-const-p ()
- ;; Returns t if point is inside a character constant.
- ;; We assume to be in a constant if the previous and the next character
- ;; are "'".
- (save-excursion
- (if (> (point) 1)
- (and
- (progn
- (forward-char 1)
- (looking-at "'"))
- (progn
- (forward-char -2)
- (looking-at "'")))
- nil)))
-
-
-(defun ada-adjust-case (&optional force-identifier)
- "Adjust the case of the word before the just typed character.
-Respect options `ada-case-keyword', `ada-case-identifier', and
-`ada-case-attribute'.
-If FORCE-IDENTIFIER is non-nil then also adjust keyword as identifier." ; (MH)
- (forward-char -1)
- (if (and (> (point) 1) (not (or (ada-in-string-p)
- (ada-in-comment-p)
- (ada-in-char-const-p))))
- (if (eq (char-syntax (char-after (1- (point)))) ?w)
- (if (save-excursion
- (forward-word -1)
- (or (= (point) (point-min))
- (backward-char 1))
- (looking-at "'"))
- (funcall ada-case-attribute -1)
- (if (and
- (not force-identifier) ; (MH)
- (ada-after-keyword-p))
- (funcall ada-case-keyword -1)
- (funcall ada-case-identifier -1)))))
- (forward-char 1))
-
-
-(defun ada-adjust-case-interactive (arg)
- (interactive "P")
- (let ((lastk last-command-char))
- (cond ((or (eq lastk ?\n)
- (eq lastk ?\r))
- ;; horrible kludge
- (insert " ")
- (ada-adjust-case)
- ;; horrible dekludge
- (delete-backward-char 1)
- ;; some special keys and their bindings
- (cond
- ((eq lastk ?\n)
- (funcall ada-lfd-binding))
- ((eq lastk ?\r)
- (funcall ada-ret-binding))))
- ((eq lastk ?\C-i) (ada-tab))
- ((self-insert-command (prefix-numeric-value arg))))
- ;; if there is a keyword in front of the underscore
- ;; then it should be part of an identifier (MH)
- (if (eq lastk ?_)
- (ada-adjust-case t)
- (ada-adjust-case))))
-
-
-(defun ada-activate-keys-for-case ()
- ;; save original keybindings to allow swapping ret/lfd
- ;; when casing is activated
- ;; the 'or ...' is there to be sure that the value will not
- ;; be changed again when Ada mode is called more than once (MH)
- (or ada-ret-binding
- (setq ada-ret-binding (key-binding "\C-M")))
- (or ada-lfd-binding
- (setq ada-lfd-binding (key-binding "\C-j")))
- ;; call case modifying function after certain keys.
- (mapcar (function (lambda(key) (define-key
- ada-mode-map
- (char-to-string key)
- 'ada-adjust-case-interactive)))
- '( ?` ?~ ?! ?@ ?# ?$ ?% ?^ ?& ?* ?( ?) ?- ?= ?+ ?[ ?{ ?] ?}
- ?_ ?\\ ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?? ?/ ?\n 32 ?\r )))
-;; deleted ?\t from above list
-
-;;
-;; added by MH
-;;
-(defun ada-loose-case-word (&optional arg)
- "Capitalizes the first letter and the letters following `_'.
-ARG is ignored, it's there to fit the standard casing functions' style."
- (let ((pos (point))
- (first t))
- (skip-chars-backward "a-zA-Z0-9_")
- (while (or first
- (search-forward "_" pos t))
- (and first
- (setq first nil))
- (insert-char (upcase (following-char)) 1)
- (delete-char 1))
- (goto-char pos)))
-
-
-;;
-;; added by MH
-;; modified by JSH to handle attributes
-;;
-(defun ada-adjust-case-region (from to)
- "Adjusts the case of all words in the region.
-Attention: This function might take very long for big regions !"
- (interactive "*r")
- (let ((begin nil)
- (end nil)
- (keywordp nil)
- (attribp nil))
- (unwind-protect
- (save-excursion
- (set-syntax-table ada-mode-symbol-syntax-table)
- (goto-char to)
- ;;
- ;; loop: look for all identifiers, keywords, and attributes
- ;;
- (while (re-search-backward
- "[^a-zA-Z0-9_]\\([a-zA-Z0-9_]+\\)[^a-zA-Z0-9_]"
- from
- t)
- ;;
- ;; print status message
- ;;
- (message "adjusting case ... %5d characters left" (- (point) from))
- (setq attribp (looking-at "'[a-zA-Z0-9_]+[^']"))
- (forward-char 1)
- (or
- ;; do nothing if it is a string or comment
- (ada-in-string-or-comment-p)
- (progn
- ;;
- ;; get the identifier or keyword or attribute
- ;;
- (setq begin (point))
- (setq keywordp (looking-at (concat ada-keywords "[^_]")))
- (skip-chars-forward "a-zA-Z0-9_")
- ;;
- ;; casing according to user-option
- ;;
- (if keywordp
- (funcall ada-case-keyword -1)
- (if attribp
- (funcall ada-case-attribute -1)
- (funcall ada-case-identifier -1)))
- (goto-char begin))))
- (message "adjusting case ... done"))
- (set-syntax-table ada-mode-syntax-table))))
-
-
-;;
-;; added by MH
-;;
-(defun ada-adjust-case-buffer ()
- "Adjusts the case of all words in the whole buffer.
-ATTENTION: This function might take very long for big buffers !"
- (interactive "*")
- (ada-adjust-case-region (point-min) (point-max)))
-
-\f
-;;;------------------------;;;
-;;; Format Parameter Lists ;;;
-;;;------------------------;;;
-
-(defun ada-format-paramlist ()
- "Reformats a parameter list.
-ATTENTION: 1) Comments inside the list are killed !
- 2) If the syntax is not correct (especially, if there are
- semicolons missing), it can get totally confused !
-In such a case, use `undo', correct the syntax and try again."
-
- (interactive)
- (let ((begin nil)
- (end nil)
- (delend nil)
- (paramlist nil))
- (unwind-protect
- (progn
- (set-syntax-table ada-mode-symbol-syntax-table)
-
- ;; check if really inside parameter list
- (or (ada-in-paramlist-p)
- (error "not in parameter list"))
- ;;
- ;; find start of current parameter-list
- ;;
- (ada-search-ignore-string-comment
- (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil)
- (ada-search-ignore-string-comment "(" nil nil t)
- (backward-char 1)
- (setq begin (point))
-
- ;;
- ;; find end of parameter-list
- ;;
- (forward-sexp 1)
- (setq delend (point))
- (delete-char -1)
-
- ;;
- ;; find end of last parameter-declaration
- ;;
- (ada-search-ignore-string-comment "[^ \t\n]" t nil t)
- (forward-char 1)
- (setq end (point))
-
- ;;
- ;; build a list of all elements of the parameter-list
- ;;
- (setq paramlist (ada-scan-paramlist (1+ begin) end))
-
- ;;
- ;; delete the original parameter-list
- ;;
- (delete-region begin (1- delend))
-
- ;;
- ;; insert the new parameter-list
- ;;
- (goto-char begin)
- (ada-insert-paramlist paramlist))
-
- ;;
- ;; restore syntax-table
- ;;
- (set-syntax-table ada-mode-syntax-table)
- )))
-
-
-(defun ada-scan-paramlist (begin end)
- ;; Scans a parameter-list between BEGIN and END and returns a list
- ;; of its contents.
- ;; The list has the following format:
- ;;
- ;; Name of Param in? out? access? Name of Type Default-Exp or nil
- ;;
- ;; ( ('Name_Param_1' t nil t Type_Param_1 ':= expression')
- ;; ('Name_Param_2' nil nil t Type_Param_2 nil) )
-
- (let ((paramlist (list))
- (param (list))
- (notend t)
- (apos nil)
- (epos nil)
- (semipos nil)
- (match-cons nil))
-
- (goto-char begin)
- ;;
- ;; loop until end of last parameter
- ;;
- (while notend
-
- ;;
- ;; find first character of parameter-declaration
- ;;
- (ada-goto-next-non-ws)
- (setq apos (point))
-
- ;;
- ;; find last character of parameter-declaration
- ;;
- (if (setq match-cons
- (ada-search-ignore-string-comment "[ \t\n]*;" nil end t))
- (progn
- (setq epos (car match-cons))
- (setq semipos (cdr match-cons)))
- (setq epos end))
-
- ;;
- ;; read name(s) of parameter(s)
- ;;
- (goto-char apos)
- (looking-at "\\([a-zA-Z0-9_, \t\n]*[a-zA-Z0-9_]\\)[ \t\n]*:[^=]")
-
- (setq param (list (buffer-substring (match-beginning 1)
- (match-end 1))))
- (ada-search-ignore-string-comment ":" nil epos t)
-
- ;;
- ;; look for 'in'
- ;;
- (setq apos (point))
- (setq param
- (append param
- (list
- (consp
- (ada-search-ignore-string-comment "\\<in\\>"
- nil
- epos
- t)))))
-
- ;;
- ;; look for 'out'
- ;;
- (goto-char apos)
- (setq param
- (append param
- (list
- (consp
- (ada-search-ignore-string-comment "\\<out\\>"
- nil
- epos
- t)))))
-
- ;;
- ;; look for 'access'
- ;;
- (goto-char apos)
- (setq param
- (append param
- (list
- (consp
- (ada-search-ignore-string-comment "\\<access\\>"
- nil
- epos
- t)))))
-
- ;;
- ;; skip 'in'/'out'/'access'
- ;;
- (goto-char apos)
- (ada-goto-next-non-ws)
- (while (looking-at "\\<\\(in\\|out\\|access\\)\\>")
- (forward-word 1)
- (ada-goto-next-non-ws))
-
- ;;
- ;; read type of parameter
- ;;
- (looking-at "\\<[a-zA-Z0-9_\\.\\']+\\>")
- (setq param
- (append param
- (list
- (buffer-substring (match-beginning 0)
- (match-end 0)))))
-
- ;;
- ;; read default-expression, if there is one
- ;;
- (goto-char (setq apos (match-end 0)))
- (setq param
- (append param
- (list
- (if (setq match-cons
- (ada-search-ignore-string-comment ":="
- nil
- epos
- t))
- (buffer-substring (car match-cons)
- epos)
- nil))))
- ;;
- ;; add this parameter-declaration to the list
- ;;
- (setq paramlist (append paramlist (list param)))
-
- ;;
- ;; check if it was the last parameter
- ;;
- (if (eq epos end)
- (setq notend nil)
- (goto-char semipos))
-
- ) ; end of loop
-
- (reverse paramlist)))
-
-
-(defun ada-insert-paramlist (paramlist)
- ;; Inserts a formatted PARAMLIST in the buffer.
- ;; See doc of `ada-scan-paramlist' for the format.
- (let ((i (length paramlist))
- (parlen 0)
- (typlen 0)
- (temp 0)
- (inp nil)
- (outp nil)
- (accessp nil)
- (column nil)
- (orgpoint 0)
- (firstcol nil))
-
- ;;
- ;; loop until last parameter
- ;;
- (while (not (zerop i))
- (setq i (1- i))
-
- ;;
- ;; get max length of parameter-name
- ;;
- (setq parlen
- (if (<= parlen (setq temp
- (length (nth 0 (nth i paramlist)))))
- temp
- parlen))
-
- ;;
- ;; get max length of type-name
- ;;
- (setq typlen
- (if (<= typlen (setq temp
- (length (nth 4 (nth i paramlist)))))
- temp
- typlen))
-
- ;;
- ;; is there any 'in' ?
- ;;
- (setq inp
- (or inp
- (nth 1 (nth i paramlist))))
-
- ;;
- ;; is there any 'out' ?
- ;;
- (setq outp
- (or outp
- (nth 2 (nth i paramlist))))
-
- ;;
- ;; is there any 'access' ?
- ;;
- (setq accessp
- (or accessp
- (nth 3 (nth i paramlist))))) ; end of loop
-
- ;;
- ;; does paramlist already start on a separate line ?
- ;;
- (if (save-excursion
- (re-search-backward "^.\\|[^ \t]" nil t)
- (looking-at "^."))
- ;; yes => re-indent it
- (ada-indent-current)
- ;;
- ;; no => insert newline and indent it
- ;;
- (progn
- (ada-indent-current)
- (newline)
- (delete-horizontal-space)
- (setq orgpoint (point))
- (setq column (save-excursion
- (funcall (ada-indent-function) orgpoint)))
- (indent-to column)
- ))
-
- (insert "(")
-
- (setq firstcol (current-column))
- (setq i (length paramlist))
-
- ;;
- ;; loop until last parameter
- ;;
- (while (not (zerop i))
- (setq i (1- i))
- (setq column firstcol)
-
- ;;
- ;; insert parameter-name, space and colon
- ;;
- (insert (nth 0 (nth i paramlist)))
- (indent-to (+ column parlen 1))
- (insert ": ")
- (setq column (current-column))
-
- ;;
- ;; insert 'in' or space
- ;;
- (if (nth 1 (nth i paramlist))
- (insert "in ")
- (if (and
- (or inp
- accessp)
- (not (nth 3 (nth i paramlist))))
- (insert " ")))
-
- ;;
- ;; insert 'out' or space
- ;;
- (if (nth 2 (nth i paramlist))
- (insert "out ")
- (if (and
- (or outp
- accessp)
- (not (nth 3 (nth i paramlist))))
- (insert " ")))
-
- ;;
- ;; insert 'access'
- ;;
- (if (nth 3 (nth i paramlist))
- (insert "access "))
-
- (setq column (current-column))
-
- ;;
- ;; insert type-name and, if necessary, space and default-expression
- ;;
- (insert (nth 4 (nth i paramlist)))
- (if (nth 5 (nth i paramlist))
- (progn
- (indent-to (+ column typlen 1))
- (insert (nth 5 (nth i paramlist)))))
-
- ;;
- ;; check if it was the last parameter
- ;;
- (if (not (zerop i))
- ;; no => insert ';' and newline and indent
- (progn
- (insert ";")
- (newline)
- (indent-to firstcol))
- ;; yes
- (insert ")"))
-
- ) ; end of loop
-
- ;;
- ;; if anything follows, except semicolon:
- ;; put it in a new line and indent it
- ;;
- (if (not (looking-at "[ \t]*[;\n]"))
- (ada-indent-newline-indent))
-
- ))
-
-\f
-;;;----------------------------;;;
-;;; Move To Matching Start/End ;;;
-;;;----------------------------;;;
-
-(defun ada-move-to-start ()
- "Moves point to the matching start of the current Ada structure."
- (interactive)
- (let ((pos (point)))
- (unwind-protect
- (progn
- (set-syntax-table ada-mode-symbol-syntax-table)
-
- (message "searching for block start ...")
- (save-excursion
- ;;
- ;; do nothing if in string or comment or not on 'end ...;'
- ;; or if an error occurs during processing
- ;;
- (or
- (ada-in-string-or-comment-p)
- (and (progn
- (or (looking-at "[ \t]*\\<end\\>")
- (backward-word 1))
- (or (looking-at "[ \t]*\\<end\\>")
- (backward-word 1))
- (or (looking-at "[ \t]*\\<end\\>")
- (error "not on end ...;")))
- (ada-goto-matching-start 1)
- (setq pos (point))
-
- ;;
- ;; on 'begin' => go on, according to user option
- ;;
- ada-move-to-declaration
- (looking-at "\\<begin\\>")
- (ada-goto-matching-decl-start)
- (setq pos (point))))
-
- ) ; end of save-excursion
-
- ;; now really move to the found position
- (goto-char pos)
- (message "searching for block start ... done"))
-
- ;;
- ;; restore syntax-table
- ;;
- (set-syntax-table ada-mode-syntax-table))))
-
-
-(defun ada-move-to-end ()
- "Moves point to the matching end of the current block around point.
-Moves to 'begin' if in a declarative part."
- (interactive)
- (let ((pos (point))
- (decstart nil)
- (packdecl nil))
- (unwind-protect
- (progn
- (set-syntax-table ada-mode-symbol-syntax-table)
-
- (message "searching for block end ...")
- (save-excursion
-
- (forward-char 1)
- (cond
- ;; directly on 'begin'
- ((save-excursion
- (ada-goto-previous-word)
- (looking-at "\\<begin\\>"))
- (ada-goto-matching-end 1))
- ;; on first line of defun declaration
- ((save-excursion
- (and (ada-goto-stmt-start)
- (looking-at "\\<function\\>\\|\\<procedure\\>" )))
- (ada-search-ignore-string-comment "\\<begin\\>"))
- ;; on first line of task declaration
- ((save-excursion
- (and (ada-goto-stmt-start)
- (looking-at "\\<task\\>" )
- (forward-word 1)
- (ada-search-ignore-string-comment "[^ \n\t]")
- (not (backward-char 1))
- (looking-at "\\<body\\>")))
- (ada-search-ignore-string-comment "\\<begin\\>"))
- ;; accept block start
- ((save-excursion
- (and (ada-goto-stmt-start)
- (looking-at "\\<accept\\>" )))
- (ada-goto-matching-end 0))
- ;; package start
- ((save-excursion
- (and (ada-goto-matching-decl-start t)
- (looking-at "\\<package\\>")))
- (ada-goto-matching-end 1))
- ;; inside a 'begin' ... 'end' block
- ((save-excursion
- (ada-goto-matching-decl-start t))
- (ada-search-ignore-string-comment "\\<begin\\>"))
- ;; (hopefully ;-) everything else
- (t
- (ada-goto-matching-end 1)))
- (setq pos (point))
-
- ) ; end of save-excursion
-
- ;; now really move to the found position
- (goto-char pos)
- (message "searching for block end ... done"))
-
- ;;
- ;; restore syntax-table
- ;;
- (set-syntax-table ada-mode-syntax-table))))
-
-\f
-;;;-----------------------------;;;
-;;; Functions For Indentation ;;;
-;;;-----------------------------;;;
-
-;; ---- main functions for indentation
-
-(defun ada-indent-region (beg end)
- "Indents the region using `ada-indent-current' on each line."
- (interactive "*r")
- (goto-char beg)
- (let ((block-done 0)
- (lines-remaining (count-lines beg end))
- (msg (format "indenting %4d lines %%4d lines remaining ..."
- (count-lines beg end)))
- (endmark (copy-marker end)))
- ;; catch errors while indenting
- (condition-case err
- (while (< (point) endmark)
- (if (> block-done 9)
- (progn (message msg lines-remaining)
- (setq block-done 0)))
- (if (looking-at "^$") nil
- (ada-indent-current))
- (forward-line 1)
- (setq block-done (1+ block-done))
- (setq lines-remaining (1- lines-remaining)))
- ;; show line number where the error occurred
- (error
- (error "line %d: %s" (1+ (count-lines (point-min) (point))) err) nil))
- (message "indenting ... done")))
-
-
-(defun ada-indent-newline-indent ()
- "Indents the current line, inserts a newline and then indents the new line."
- (interactive "*")
- (ada-indent-current)
- (newline)
- (ada-indent-current))
-
-
-(defun ada-indent-current ()
- "Indents current line as Ada code.
-This works by two steps:
- 1) It moves point to the end of the previous code line.
- Then it calls the function to calculate the indentation for the
- following line as if a newline would be inserted there.
- The calculated column # is saved and the old position of point
- is restored.
- 2) Then another function is called to calculate the indentation for
- the current line, based on the previously calculated column #."
-
- (interactive)
-
- (unwind-protect
- (progn
- (set-syntax-table ada-mode-symbol-syntax-table)
-
- (let ((line-end)
- (orgpoint (point-marker))
- (cur-indent)
- (prev-indent)
- (prevline t))
-
- ;;
- ;; first step
- ;;
- (save-excursion
- (if (ada-goto-prev-nonblank-line t)
- ;;
- ;; we are not in the first accessible line in the buffer
- ;;
- (progn
- ;;(end-of-line)
- ;;(forward-char 1)
- ;; we are already at the BOL
- (forward-line 1)
- (setq line-end (point))
- (setq prev-indent
- (save-excursion
- (funcall (ada-indent-function) line-end))))
- (progn ; first line of buffer -> set indent
- (beginning-of-line) ; to 0
- (delete-horizontal-space)
- (setq prevline nil))))
-
- (if prevline
- ;;
- ;; we are not in the first accessible line in the buffer
- ;;
- (progn
- ;;
- ;; second step
- ;;
- (back-to-indentation)
- (setq cur-indent (ada-get-current-indent prev-indent))
- ;; only reindent if indentation is different then the current
- (if (= (current-column) cur-indent)
- nil
- (delete-horizontal-space)
- (indent-to cur-indent))
- ;;
- ;; restore position of point
- ;;
- (goto-char orgpoint)
- (if (< (current-column) (current-indentation))
- (back-to-indentation))))))
-
- ;;
- ;; restore syntax-table
- ;;
- (set-syntax-table ada-mode-syntax-table)))
-
-
-(defun ada-get-current-indent (prev-indent)
- ;; Returns the column # to indent the current line to.
- ;; PREV-INDENT is the indentation resulting from the previous lines.
- (let ((column nil)
- (pos nil)
- (match-cons nil))
-
- (cond
- ;;
- ;; in open parenthesis, but not in parameter-list
- ;;
- ((and
- ada-indent-to-open-paren
- (not (ada-in-paramlist-p))
- (setq column (ada-in-open-paren-p)))
- ;; check if we have something like this (Table_Component_Type =>
- ;; Source_File_Record,)
- (save-excursion
- (if (and (ada-search-ignore-string-comment "[^ \t]" t nil)
- (looking-at "\n")
- (ada-search-ignore-string-comment "[^ \t\n]" t nil)
- (looking-at ">"))
- (setq column (+ ada-broken-indent column))))
- column)
-
- ;;
- ;; end
- ;;
- ((looking-at "\\<end\\>")
- (let ((label 0))
- (save-excursion
- (ada-goto-matching-start 1)
-
- ;;
- ;; found 'loop' => skip back to 'while' or 'for'
- ;; if 'loop' is not on a separate line
- ;;
- (if (and
- (looking-at "\\<loop\\>")
- (save-excursion
- (back-to-indentation)
- (not (looking-at "\\<loop\\>"))))
- (if (save-excursion
- (and
- (setq match-cons
- (ada-search-ignore-string-comment
- ada-loop-start-re t nil))
- (not (looking-at "\\<loop\\>"))))
- (progn
- (goto-char (car match-cons))
- (save-excursion
- (beginning-of-line)
- (if (looking-at ada-named-block-re)
- (setq label (- ada-label-indent)))))))
-
- (+ (current-indentation) label))))
- ;;
- ;; exception
- ;;
- ((looking-at "\\<exception\\>")
- (save-excursion
- (ada-goto-matching-start 1)
- (current-indentation)))
- ;;
- ;; when
- ;;
- ((looking-at "\\<when\\>")
- (save-excursion
- (ada-goto-matching-start 1)
- (+ (current-indentation) ada-when-indent)))
- ;;
- ;; else
- ;;
- ((looking-at "\\<else\\>")
- (if (save-excursion
- (ada-goto-previous-word)
- (looking-at "\\<or\\>"))
- prev-indent
- (save-excursion
- (ada-goto-matching-start 1 nil t)
- (current-indentation))))
- ;;
- ;; elsif
- ;;
- ((looking-at "\\<elsif\\>")
- (save-excursion
- (ada-goto-matching-start 1 nil t)
- (current-indentation)))
- ;;
- ;; then
- ;;
- ((looking-at "\\<then\\>")
- (if (save-excursion
- (ada-goto-previous-word)
- (looking-at "\\<and\\>"))
- prev-indent
- (save-excursion
- (ada-search-ignore-string-comment "\\<elsif\\>\\|\\<if\\>" t nil)
- (+ (current-indentation) ada-stmt-end-indent))))
- ;;
- ;; loop
- ;;
- ((looking-at "\\<loop\\>")
- (setq pos (point))
- (save-excursion
- (goto-char (match-end 0))
- (ada-goto-stmt-start)
- (if (looking-at "\\<loop\\>\\|\\<if\\>")
- prev-indent
- (progn
- (if (not (looking-at ada-loop-start-re))
- (ada-search-ignore-string-comment ada-loop-start-re
- nil pos))
- (if (looking-at "\\<loop\\>")
- prev-indent
- (+ (current-indentation) ada-stmt-end-indent))))))
- ;;
- ;; begin
- ;;
- ((looking-at "\\<begin\\>")
- (save-excursion
- (if (ada-goto-matching-decl-start t)
- (current-indentation)
- prev-indent)))
- ;;
- ;; is
- ;;
- ((looking-at "\\<is\\>")
- (if (and
- ada-indent-is-separate
- (save-excursion
- (goto-char (match-end 0))
- (ada-goto-next-non-ws (save-excursion
- (end-of-line)
- (point)))
- (looking-at "\\<abstract\\>\\|\\<separate\\>")))
- (save-excursion
- (ada-goto-stmt-start)
- (+ (current-indentation) ada-indent))
- (save-excursion
- (ada-goto-stmt-start)
- (+ (current-indentation) ada-stmt-end-indent))))
- ;;
- ;; record
- ;;
- ((looking-at "\\<record\\>")
- (save-excursion
- (ada-search-ignore-string-comment
- "\\<\\(type\\|use\\)\\>" t nil)
- (if (looking-at "\\<use\\>")
- (ada-search-ignore-string-comment "\\<for\\>" t nil))
- (+ (current-indentation) ada-indent-record-rel-type)))
- ;;
- ;; or as statement-start
- ;;
- ((ada-looking-at-semi-or)
- (save-excursion
- (ada-goto-matching-start 1)
- (current-indentation)))
- ;;
- ;; private as statement-start
- ;;
- ((ada-looking-at-semi-private)
- (save-excursion
- (ada-goto-matching-decl-start)
- (current-indentation)))
- ;;
- ;; new/abstract/separate
- ;;
- ((looking-at "\\<\\(new\\|abstract\\|separate\\)\\>")
- (- prev-indent ada-indent (- ada-broken-indent)))
- ;;
- ;; return
- ;;
- ((looking-at "\\<return\\>")
- (save-excursion
- (forward-sexp -1)
- (if (and (looking-at "(")
- (save-excursion
- (backward-sexp 2)
- (looking-at "\\<function\\>")))
- (1+ (current-column))
- prev-indent)))
- ;;
- ;; do
- ;;
- ((looking-at "\\<do\\>")
- (save-excursion
- (ada-goto-stmt-start)
- (+ (current-indentation) ada-stmt-end-indent)))
- ;;
- ;; package/function/procedure
- ;;
- ((and (looking-at "\\<\\(package\\|function\\|procedure\\)\\>")
- (save-excursion
- (forward-char 1)
- (ada-goto-stmt-start)
- (looking-at "\\<\\(package\\|function\\|procedure\\)\\>")))
- (save-excursion
- ;; look for 'generic'
- (if (and (ada-goto-matching-decl-start t)
- (looking-at "generic"))
- (current-column)
- prev-indent)))
- ;;
- ;; label
- ;;
- ((looking-at "\\<[a-zA-Z0-9_]+[ \t\n]*:[^=]")
- (if (ada-in-decl-p)
- prev-indent
- (+ prev-indent ada-label-indent)))
- ;;
- ;; identifier and other noindent-statements
- ;;
- ((looking-at "\\<[a-zA-Z0-9_]+[ \t\n]*")
- prev-indent)
- ;;
- ;; beginning of a parameter list
- ;;
- ((looking-at "(")
- prev-indent)
- ;;
- ;; end of a parameter list
- ;;
- ((looking-at ")")
- (save-excursion
- (forward-char 1)
- (backward-sexp 1)
- (current-column)))
- ;;
- ;; comment
- ;;
- ((looking-at "--")
- (if ada-indent-comment-as-code
- prev-indent
- (current-indentation)))
- ;;
- ;; unknown syntax - maybe this should signal an error ?
- ;;
- (t
- prev-indent))))
-
-
-(defun ada-indent-function (&optional nomove)
- ;; Returns the function to calculate the indentation for the current
- ;; line according to the previous statement, ignoring the contents
- ;; of the current line after point. Moves point to the beginning of
- ;; the current statement, if NOMOVE is nil.
-
- (let ((orgpoint (point))
- (func nil))
- ;;
- ;; inside a parameter-list
- ;;
- (if (ada-in-paramlist-p)
- (setq func 'ada-get-indent-paramlist)
- (progn
- ;;
- ;; move to beginning of current statement
- ;;
- (if (not nomove)
- (ada-goto-stmt-start))
- ;;
- ;; no beginning found => don't change indentation
- ;;
- (if (and
- (eq orgpoint (point))
- (not nomove))
- (setq func 'ada-get-indent-nochange)
-
- (cond
- ;;
- ((and
- ada-indent-to-open-paren
- (ada-in-open-paren-p))
- (setq func 'ada-get-indent-open-paren))
- ;;
- ((looking-at "\\<end\\>")
- (setq func 'ada-get-indent-end))
- ;;
- ((looking-at ada-loop-start-re)
- (setq func 'ada-get-indent-loop))
- ;;
- ((looking-at ada-subprog-start-re)
- (setq func 'ada-get-indent-subprog))
- ;;
- ((looking-at ada-block-start-re)
- (setq func 'ada-get-indent-block-start))
- ;;
- ((looking-at "\\<type\\>")
- (setq func 'ada-get-indent-type))
- ;;
- ((looking-at "\\<\\(els\\)?if\\>")
- (setq func 'ada-get-indent-if))
- ;;
- ((looking-at "\\<case\\>")
- (setq func 'ada-get-indent-case))
- ;;
- ((looking-at "\\<when\\>")
- (setq func 'ada-get-indent-when))
- ;;
- ((looking-at "--")
- (setq func 'ada-get-indent-comment))
- ;;
- ((looking-at "[a-zA-Z0-9_]+[ \t\n]*:[^=]")
- (setq func 'ada-get-indent-label))
- ;;
- ((looking-at "\\<separate\\>")
- (setq func 'ada-get-indent-nochange))
- (t
- (setq func 'ada-get-indent-noindent))))))
-
- func))
-
-
-;; ---- functions to return indentation for special cases
-
-(defun ada-get-indent-open-paren (orgpoint)
- ;; Returns the indentation (column #) for the new line after ORGPOINT.
- ;; Assumes point to be behind an open parenthesis not yet closed.
- (ada-in-open-paren-p))
-
-
-(defun ada-get-indent-nochange (orgpoint)
- ;; Returns the indentation (column #) of the current line.
- (save-excursion
- (forward-line -1)
- (current-indentation)))
-
-
-(defun ada-get-indent-paramlist (orgpoint)
- ;; Returns the indentation (column #) for the new line after ORGPOINT.
- ;; Assumes point to be inside a parameter-list.
- (save-excursion
- (ada-search-ignore-string-comment "[^ \t\n]" t nil t)
- (cond
- ;;
- ;; in front of the first parameter
- ;;
- ((looking-at "(")
- (goto-char (match-end 0))
- (current-column))
- ;;
- ;; in front of another parameter
- ;;
- ((looking-at ";")
- (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t)))
- (ada-goto-next-non-ws)
- (current-column))
- ;;
- ;; inside a parameter declaration
- ;;
- (t
- (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t)))
- (ada-goto-next-non-ws)
- (+ (current-column) ada-broken-indent)))))
-
-
-(defun ada-get-indent-end (orgpoint)
- ;; Returns the indentation (column #) for the new line after ORGPOINT.
- ;; Assumes point to be at the beginning of an end-statement.
- ;; Therefore it has to find the corresponding start. This can be a little
- ;; slow, if it has to search through big files with many nested blocks.
- ;; Signals an error if the corresponding block-start doesn't match.
- (let ((defun-name nil)
- (label 0)
- (indent nil))
- ;;
- ;; is the line already terminated by ';' ?
- ;;
- (if (save-excursion
- (ada-search-ignore-string-comment ";" nil orgpoint))
- ;;
- ;; yes, look what's following 'end'
- ;;
- (progn
- (forward-word 1)
- (ada-goto-next-non-ws)
- (cond
- ;;
- ;; loop/select/if/case/record/select
- ;;
- ((looking-at "\\<\\(loop\\|select\\|if\\|case\\|record\\)\\>")
- (save-excursion
- (ada-check-matching-start
- (buffer-substring (match-beginning 0)
- (match-end 0)))
- (if (looking-at "\\<\\(loop\\|record\\)\\>")
- (progn
- (forward-word 1)
- (ada-goto-stmt-start)))
- ;; a label ? => skip it
- (if (looking-at ada-named-block-re)
- (progn
- (setq label (- ada-label-indent))
- (goto-char (match-end 0))
- (ada-goto-next-non-ws)))
- ;; really looking-at the right thing ?
- (or (looking-at (concat "\\<\\("
- "loop\\|select\\|if\\|case\\|"
- "record\\|while\\|type\\)\\>"))
- (progn
- (ada-search-ignore-string-comment
- (concat "\\<\\("
- "loop\\|select\\|if\\|case\\|"
- "record\\|while\\|type\\)\\>")))
- (backward-word 1))
- (+ (current-indentation) label)))
- ;;
- ;; a named block end
- ;;
- ((looking-at ada-ident-re)
- (setq defun-name (buffer-substring (match-beginning 0)
- (match-end 0)))
- (save-excursion
- (ada-goto-matching-start 0)
- (ada-check-defun-name defun-name)
- (current-indentation)))
- ;;
- ;; a block-end without name
- ;;
- ((looking-at ";")
- (save-excursion
- (ada-goto-matching-start 0)
- (if (looking-at "\\<begin\\>")
- (progn
- (setq indent (current-column))
- (if (ada-goto-matching-decl-start t)
- (current-indentation)
- indent)))))
- ;;
- ;; anything else - should maybe signal an error ?
- ;;
- (t
- (+ (current-indentation) ada-broken-indent))))
-
- (+ (current-indentation) ada-broken-indent))))
-
-
-(defun ada-get-indent-case (orgpoint)
- ;; Returns the indentation (column #) for the new line after ORGPOINT.
- ;; Assumes point to be at the beginning of a case-statement.
- (let ((cur-indent (current-indentation))
- (match-cons nil)
- (opos (point)))
- (cond
- ;;
- ;; case..is..when..=>
- ;;
- ((save-excursion
- (setq match-cons (and
- ;; the `=>' must be after the keyword `is'.
- (ada-search-ignore-string-comment
- "\\<is\\>" nil orgpoint)
- (ada-search-ignore-string-comment
- "[ \t\n]+=>" nil orgpoint))))
- (save-excursion
- (goto-char (car match-cons))
- (if (not (ada-search-ignore-string-comment "\\<when\\>" t opos))
- (error "missing 'when' between 'case' and '=>'"))
- (+ (current-indentation) ada-indent)))
- ;;
- ;; case..is..when
- ;;
- ((save-excursion
- (setq match-cons (ada-search-ignore-string-comment
- "\\<when\\>" nil orgpoint)))
- (goto-char (cdr match-cons))
- (+ (current-indentation) ada-broken-indent))
- ;;
- ;; case..is
- ;;
- ((save-excursion
- (setq match-cons (ada-search-ignore-string-comment
- "\\<is\\>" nil orgpoint)))
- (+ (current-indentation) ada-when-indent))
- ;;
- ;; incomplete case
- ;;
- (t
- (+ (current-indentation) ada-broken-indent)))))
-
-
-(defun ada-get-indent-when (orgpoint)
- ;; Returns the indentation (column #) for the new line after ORGPOINT.
- ;; Assumes point to be at the beginning of an when-statement.
- (let ((cur-indent (current-indentation)))
- (if (ada-search-ignore-string-comment
- "[ \t\n]+=>" nil orgpoint)
- (+ cur-indent ada-indent)
- (+ cur-indent ada-broken-indent))))
-
-
-(defun ada-get-indent-if (orgpoint)
- ;; Returns the indentation (column #) for the new line after ORGPOINT.
- ;; Assumes point to be at the beginning of an if-statement.
- (let ((cur-indent (current-indentation))
- (match-cons nil))
- ;;
- ;; if..then ?
- ;;
- (if (ada-search-but-not
- "\\<then\\>" "\\<and\\>[ \t\n]+\\<then\\>" nil orgpoint)
-
- (progn
- ;;
- ;; 'then' first in separate line ?
- ;; => indent according to 'then'
- ;;
- (if (save-excursion
- (back-to-indentation)
- (looking-at "\\<then\\>"))
- (setq cur-indent (current-indentation)))
- (forward-word 1)
- ;;
- ;; something follows 'then' ?
- ;;
- (if (setq match-cons
- (ada-search-ignore-string-comment
- "[^ \t\n]" nil orgpoint))
- (progn
- (goto-char (car match-cons))
- (+ ada-indent
- (- cur-indent (current-indentation))
- (funcall (ada-indent-function t) orgpoint)))
-
- (+ cur-indent ada-indent)))
-
- (+ cur-indent ada-broken-indent))))
-
-
-(defun ada-get-indent-block-start (orgpoint)
- ;; Returns the indentation (column #) for the new line after
- ;; ORGPOINT. Assumes point to be at the beginning of a block start
- ;; keyword.
- (let ((cur-indent (current-indentation))
- (pos nil))
- (cond
- ((save-excursion
- (forward-word 1)
- (setq pos (car (ada-search-ignore-string-comment
- "[^ \t\n]" nil orgpoint))))
- (goto-char pos)
- (save-excursion
- (funcall (ada-indent-function t) orgpoint)))
- ;;
- ;; nothing follows the block-start
- ;;
- (t
- (+ (current-indentation) ada-indent)))))
-
-
-(defun ada-get-indent-subprog (orgpoint)
- ;; Returns the indentation (column #) for the new line after ORGPOINT.
- ;; Assumes point to be at the beginning of a subprog-/package-declaration.
- (let ((match-cons nil)
- (cur-indent (current-indentation))
- (foundis nil)
- (addind 0)
- (fstart (point)))
- ;;
- ;; is there an 'is' in front of point ?
- ;;
- (if (save-excursion
- (setq match-cons
- (ada-search-ignore-string-comment
- "\\<\\(is\\|do\\)\\>" nil orgpoint)))
- ;;
- ;; yes, then skip to its end
- ;;
- (progn
- (setq foundis t)
- (goto-char (cdr match-cons)))
- ;;
- ;; no, then goto next non-ws, if there is one in front of point
- ;;
- (progn
- (if (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint)
- (ada-goto-next-non-ws)
- (goto-char orgpoint))))
-
- (cond
- ;;
- ;; nothing follows 'is'
- ;;
- ((and
- foundis
- (save-excursion
- (not (ada-search-ignore-string-comment
- "[^ \t\n]" nil orgpoint t))))
- (+ cur-indent ada-indent))
- ;;
- ;; is abstract/separate/new ...
- ;;
- ((and
- foundis
- (save-excursion
- (setq match-cons
- (ada-search-ignore-string-comment
- "\\<\\(separate\\|new\\|abstract\\)\\>"
- nil orgpoint))))
- (goto-char (car match-cons))
- (ada-search-ignore-string-comment ada-subprog-start-re t)
- (ada-get-indent-noindent orgpoint))
- ;;
- ;; something follows 'is'
- ;;
- ((and
- foundis
- (save-excursion
- (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint))
- (ada-goto-next-non-ws)
- (funcall (ada-indent-function t) orgpoint)))
- ;;
- ;; no 'is' but ';'
- ;;
- ((save-excursion
- (ada-search-ignore-string-comment ";" nil orgpoint))
- cur-indent)
- ;;
- ;; no 'is' or ';'
- ;;
- (t
- (+ cur-indent ada-broken-indent)))))
-
-
-(defun ada-get-indent-noindent (orgpoint)
- ;; Returns the indentation (column #) for the new line after ORGPOINT.
- ;; Assumes point to be at the beginning of a 'noindent statement'.
- (let ((label 0))
- (save-excursion
- (beginning-of-line)
- (if (looking-at ada-named-block-re)
- (setq label (- ada-label-indent))))
- (if (save-excursion
- (ada-search-ignore-string-comment ";" nil orgpoint))
- (+ (current-indentation) label)
- (+ (current-indentation) ada-broken-indent label))))
-
-
-(defun ada-get-indent-label (orgpoint)
- ;; Returns the indentation (column #) for the new line after ORGPOINT.
- ;; Assumes point to be at the beginning of a label or variable declaration.
- ;; Checks the context to decide if it's a label or a variable declaration.
- ;; This check might be a bit slow.
- (let ((match-cons nil)
- (cur-indent (current-indentation)))
- (goto-char (cdr (ada-search-ignore-string-comment ":")))
- (cond
- ;;
- ;; loop label
- ;;
- ((save-excursion
- (setq match-cons (ada-search-ignore-string-comment
- ada-loop-start-re nil orgpoint)))
- (goto-char (car match-cons))
- (ada-get-indent-loop orgpoint))
- ;;
- ;; declare label
- ;;
- ((save-excursion
- (setq match-cons (ada-search-ignore-string-comment
- "\\<declare\\|begin\\>" nil orgpoint)))
- (save-excursion
- (goto-char (car match-cons))
- (+ (current-indentation) ada-indent)))
- ;;
- ;; complete statement following colon
- ;;
- ((save-excursion
- (ada-search-ignore-string-comment ";" nil orgpoint))
- (if (ada-in-decl-p)
- cur-indent ; variable-declaration
- (- cur-indent ada-label-indent))) ; label
- ;;
- ;; broken statement
- ;;
- ((save-excursion
- (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint))
- (if (ada-in-decl-p)
- (+ cur-indent ada-broken-indent)
- (+ cur-indent ada-broken-indent (- ada-label-indent))))
- ;;
- ;; nothing follows colon
- ;;
- (t
- (if (ada-in-decl-p)
- (+ cur-indent ada-broken-indent) ; variable-declaration
- (- cur-indent ada-label-indent)))))) ; label
-
-
-(defun ada-get-indent-loop (orgpoint)
- ;; Returns the indentation (column #) for the new line after ORGPOINT.
- ;; Assumes point to be at the beginning of a loop statement
- ;; or (unfortunately) also a for ... use statement.
- (let ((match-cons nil)
- (pos (point))
- (label (save-excursion
- (beginning-of-line)
- (if (looking-at ada-named-block-re)
- (- ada-label-indent)
- 0))))
-
- (cond
-
- ;;
- ;; statement complete
- ;;
- ((save-excursion
- (ada-search-ignore-string-comment ";" nil orgpoint))
- (+ (current-indentation) label))
- ;;
- ;; simple loop
- ;;
- ((looking-at "loop\\>")
- (+ (ada-get-indent-block-start orgpoint) label))
-
- ;;
- ;; 'for'- loop (or also a for ... use statement)
- ;;
- ((looking-at "for\\>")
- (cond
- ;;
- ;; for ... use
- ;;
- ((save-excursion
- (and
- (goto-char (match-end 0))
- (ada-search-ignore-string-comment "[^ /n/t]" nil orgpoint)
- (not (backward-char 1))
- (not (zerop (skip-chars-forward "_a-zA-Z0-9'")))
- (ada-search-ignore-string-comment "[^ /n/t]" nil orgpoint)
- (not (backward-char 1))
- (looking-at "\\<use\\>")
- ;;
- ;; check if there is a 'record' before point
- ;;
- (progn
- (setq match-cons (ada-search-ignore-string-comment
- "\\<record\\>" nil orgpoint))
- t)))
- (if match-cons
- (goto-char (car match-cons)))
- (+ (current-indentation) ada-indent))
- ;;
- ;; for..loop
- ;;
- ((save-excursion
- (setq match-cons (ada-search-ignore-string-comment
- "\\<loop\\>" nil orgpoint)))
- (goto-char (car match-cons))
- ;;
- ;; indent according to 'loop', if it's first in the line;
- ;; otherwise to 'for'
- ;;
- (if (not (save-excursion
- (back-to-indentation)
- (looking-at "\\<loop\\>")))
- (goto-char pos))
- (+ (current-indentation) ada-indent label))
- ;;
- ;; for-statement is broken
- ;;
- (t
- (+ (current-indentation) ada-broken-indent label))))
-
- ;;
- ;; 'while'-loop
- ;;
- ((looking-at "while\\>")
- ;;
- ;; while..loop ?
- ;;
- (if (save-excursion
- (setq match-cons (ada-search-ignore-string-comment
- "\\<loop\\>" nil orgpoint)))
-
- (progn
- (goto-char (car match-cons))
- ;;
- ;; indent according to 'loop', if it's first in the line;
- ;; otherwise to 'while'.
- ;;
- (if (not (save-excursion
- (back-to-indentation)
- (looking-at "\\<loop\\>")))
- (goto-char pos))
- (+ (current-indentation) ada-indent label))
-
- (+ (current-indentation) ada-broken-indent label))))))
-
-
-(defun ada-get-indent-type (orgpoint)
- ;; Returns the indentation (column #) for the new line after ORGPOINT.
- ;; Assumes point to be at the beginning of a type statement.
- (let ((match-dat nil))
- (cond
- ;;
- ;; complete record declaration
- ;;
- ((save-excursion
- (and
- (setq match-dat (ada-search-ignore-string-comment "\\<end\\>"
- nil
- orgpoint))
- (ada-goto-next-non-ws)
- (looking-at "\\<record\\>")
- (forward-word 1)
- (ada-goto-next-non-ws)
- (looking-at ";")))
- (goto-char (car match-dat))
- (current-indentation))
- ;;
- ;; record type
- ;;
- ((save-excursion
- (setq match-dat (ada-search-ignore-string-comment "\\<record\\>"
- nil
- orgpoint)))
- (goto-char (car match-dat))
- (+ (current-indentation) ada-indent))
- ;;
- ;; complete type declaration
- ;;
- ((save-excursion
- (ada-search-ignore-string-comment ";" nil orgpoint))
- (current-indentation))
- ;;
- ;; "type ... is", but not "type ... is ...", which is broken
- ;;
- ((save-excursion
- (and
- (ada-search-ignore-string-comment "\\<is\\>" nil orgpoint)
- (not (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint))))
- (+ (current-indentation) ada-indent))
- ;;
- ;; broken statement
- ;;
- (t
- (+ (current-indentation) ada-broken-indent)))))
-
-\f
-;;; ---- support-functions for indentation
-
-;;; ---- searching and matching
-
-(defun ada-goto-stmt-start (&optional limit)
- ;; Moves point to the beginning of the statement that point is in or
- ;; after. Returns the new position of point. Beginnings are found
- ;; by searching for 'ada-end-stmt-re' and then moving to the
- ;; following non-ws that is not a comment. LIMIT is actually not
- ;; used by the indentation functions.
- (let ((match-dat nil)
- (orgpoint (point)))
-
- (setq match-dat (ada-search-prev-end-stmt limit))
- (if match-dat
- ;;
- ;; found a previous end-statement => check if anything follows
- ;;
- (progn
- (if (not
- (save-excursion
- (goto-char (cdr match-dat))
- (ada-search-ignore-string-comment
- "[^ \t\n]" nil orgpoint)))
- ;;
- ;; nothing follows => it's the end-statement directly in
- ;; front of point => search again
- ;;
- (setq match-dat (ada-search-prev-end-stmt limit)))
- ;;
- ;; if found the correct end-statement => goto next non-ws
- ;;
- (if match-dat
- (goto-char (cdr match-dat)))
- (ada-goto-next-non-ws))
-
- ;;
- ;; no previous end-statement => we are at the beginning of the
- ;; accessible part of the buffer
- ;;
- (progn
- (goto-char (point-min))
- ;;
- ;; skip to the very first statement, if there is one
- ;;
- (if (setq match-dat
- (ada-search-ignore-string-comment
- "[^ \t\n]" nil orgpoint))
- (goto-char (car match-dat))
- (goto-char orgpoint))))
-
-
- (point)))
-
-
-(defun ada-search-prev-end-stmt (&optional limit)
- ;; Moves point to previous end-statement. Returns a cons cell whose
- ;; car is the beginning and whose cdr the end of the match.
- ;; End-statements are defined by 'ada-end-stmt-re'. Checks for
- ;; certain keywords if they follow 'end', which means they are no
- ;; end-statement there.
- (let ((match-dat nil)
- (pos nil)
- (found nil))
- ;;
- ;; search until found or beginning-of-buffer
- ;;
- (while
- (and
- (not found)
- (setq match-dat (ada-search-ignore-string-comment ada-end-stmt-re
- t
- limit)))
-
- (goto-char (car match-dat))
- (if (not (ada-in-open-paren-p))
- ;;
- ;; check if there is an 'end' in front of the match
- ;;
- (if (not (and
- (looking-at
- "\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>")
- (save-excursion
- (ada-goto-previous-word)
- (looking-at "\\<\\(end\\|or\\|and\\)\\>"))))
- (save-excursion
- (goto-char (cdr match-dat))
- (ada-goto-next-word)
- (if (not (looking-at "\\<\\(separate\\|new\\)\\>"))
- (setq found t)))
-
- (forward-word -1)))) ; end of loop
-
- (if found
- match-dat
- nil)))
-
-
-(defun ada-goto-next-non-ws (&optional limit)
- ;; Skips whitespaces, newlines and comments to next non-ws
- ;; character. Signals an error if there is no more such character
- ;; and limit is nil.
- (let ((match-cons nil))
- (setq match-cons (ada-search-ignore-string-comment
- "[^ \t\n]" nil limit t))
- (if match-cons
- (goto-char (car match-cons))
- (if (not limit)
- (error "no more non-ws")
- nil))))
-
-
-(defun ada-goto-stmt-end (&optional limit)
- ;; Moves point to the end of the statement that point is in or
- ;; before. Returns the new position of point or nil if not found.
- (if (ada-search-ignore-string-comment ada-end-stmt-re nil limit)
- (point)
- nil))
-
-
-(defun ada-goto-next-word (&optional backward)
- ;; Moves point to the beginning of the next word of Ada code.
- ;; If BACKWARD is non-nil, jump to the beginning of the previous word.
- ;; Returns the new position of point or nil if not found.
- (let ((match-cons nil)
- (orgpoint (point)))
- (if (not backward)
- (skip-chars-forward "_a-zA-Z0-9\\."))
- (if (setq match-cons
- (ada-search-ignore-string-comment "\\w" backward nil t))
- ;;
- ;; move to the beginning of the word found
- ;;
- (progn
- (goto-char (car match-cons))
- (skip-chars-backward "_a-zA-Z0-9")
- (point))
- ;;
- ;; if not found, restore old position of point
- ;;
- (progn
- (goto-char orgpoint)
- 'nil))))
-
-
-(defun ada-goto-previous-word ()
- ;; Moves point to the beginning of the previous word of Ada code.
- ;; Returns the new position of point or nil if not found.
- (ada-goto-next-word t))
-
-
-(defun ada-check-matching-start (keyword)
- ;; Signals an error if matching block start is not KEYWORD.
- ;; Moves point to the matching block start.
- (ada-goto-matching-start 0)
- (if (not (looking-at (concat "\\<" keyword "\\>")))
- (error "matching start is not '%s'" keyword)))
-
-
-(defun ada-check-defun-name (defun-name)
- ;; Checks if the name of the matching defun really is DEFUN-NAME.
- ;; Assumes point to be already positioned by 'ada-goto-matching-start'.
- ;; Moves point to the beginning of the declaration.
-
- ;;
- ;; named block without a `declare'
- ;;
- (if (save-excursion
- (ada-goto-previous-word)
- (looking-at (concat "\\<" defun-name "\\> *:")))
- t ; do nothing
- ;;
- ;; 'accept' or 'package' ?
- ;;
- (if (not (looking-at "\\<\\(accept\\|package\\|task\\|protected\\)\\>"))
- (ada-goto-matching-decl-start))
- ;;
- ;; 'begin' of 'procedure'/'function'/'task' or 'declare'
- ;;
- (save-excursion
- ;;
- ;; a named 'declare'-block ?
- ;;
- (if (looking-at "\\<declare\\>")
- (ada-goto-stmt-start)
- ;;
- ;; no, => 'procedure'/'function'/'task'/'protected'
- ;;
- (progn
- (forward-word 2)
- (backward-word 1)
- ;;
- ;; skip 'body' 'type'
- ;;
- (if (looking-at "\\<\\(body\\|type\\)\\>")
- (forward-word 1))
- (forward-sexp 1)
- (backward-sexp 1)))
- ;;
- ;; should be looking-at the correct name
- ;;
- (if (not (looking-at (concat "\\<" defun-name "\\>")))
- (error "matching defun has different name: %s"
- (buffer-substring (point)
- (progn (forward-sexp 1) (point))))))))
-
-
-(defun ada-goto-matching-decl-start (&optional noerror nogeneric)
- ;; Moves point to the matching declaration start of the current 'begin'.
- ;; If NOERROR is non-nil, it only returns nil if no match was found.
- (let ((nest-count 1)
- (pos nil)
- (first t)
- (flag nil))
- ;;
- ;; search backward for interesting keywords
- ;;
- (while (and
- (not (zerop nest-count))
- (ada-search-ignore-string-comment
- (concat "\\<\\("
- "is\\|separate\\|end\\|declare\\|new\\|begin\\|generic"
- "\\)\\>") t))
- ;;
- ;; calculate nest-depth
- ;;
- (cond
- ;;
- ((looking-at "end")
- (ada-goto-matching-start 1 noerror)
- (if (looking-at "begin")
- (setq nest-count (1+ nest-count))))
- ;;
- ((looking-at "declare\\|generic")
- (setq nest-count (1- nest-count))
- (setq first nil))
- ;;
- ((looking-at "is")
- ;; check if it is only a type definition, but not a protected
- ;; type definition, which should be handled like a procedure.
- (if (or (looking-at "is +<>")
- (save-excursion
- (ada-goto-previous-word)
- (skip-chars-backward "a-zA-Z0-9_.'")
- (if (save-excursion
- (backward-char 1)
- (looking-at ")"))
- (progn
- (forward-char 1)
- (backward-sexp 1)
- (skip-chars-backward "a-zA-Z0-9_.'")
- ))
- (ada-goto-previous-word)
- (and
- (looking-at "\\<type\\>")
- (save-match-data
- (ada-goto-previous-word)
- (not (looking-at "\\<protected\\>"))))
- )); end of `or'
- (goto-char (match-beginning 0))
- (progn
- (setq nest-count (1- nest-count))
- (setq first nil))))
-
- ;;
- ((looking-at "new")
- (if (save-excursion
- (ada-goto-previous-word)
- (looking-at "is"))
- (goto-char (match-beginning 0))))
- ;;
- ((and first
- (looking-at "begin"))
- (setq nest-count 0)
- (setq flag t))
- ;;
- (t
- (setq nest-count (1+ nest-count))
- (setq first nil)))
-
- ) ;; end of loop
-
- ;; check if declaration-start is really found
- (if (not
- (and
- (zerop nest-count)
- (not flag)
- (if (looking-at "is")
- (ada-search-ignore-string-comment ada-subprog-start-re t)
- (looking-at "declare\\|generic"))))
- (if noerror nil
- (error "no matching proc/func/task/declare/package/protected"))
- t)))
-
-
-(defun ada-goto-matching-start (&optional nest-level noerror gotothen)
- ;; Moves point to the beginning of a block-start. Which block
- ;; depends on the value of NEST-LEVEL, which defaults to zero. If
- ;; NOERROR is non-nil, it only returns nil if no matching start was
- ;; found. If GOTOTHEN is non-nil, point moves to the 'then'
- ;; following 'if'.
- (let ((nest-count (if nest-level nest-level 0))
- (found nil)
- (pos nil))
-
- ;;
- ;; search backward for interesting keywords
- ;;
- (while (and
- (not found)
- (ada-search-ignore-string-comment
- (concat "\\<\\("
- "end\\|loop\\|select\\|begin\\|case\\|do\\|"
- "if\\|task\\|package\\|record\\|protected\\)\\>")
- t))
-
- ;;
- ;; calculate nest-depth
- ;;
- (cond
- ;; found block end => increase nest depth
- ((looking-at "end")
- (setq nest-count (1+ nest-count)))
- ;; found loop/select/record/case/if => check if it starts or
- ;; ends a block
- ((looking-at "loop\\|select\\|record\\|case\\|if")
- (setq pos (point))
- (save-excursion
- ;;
- ;; check if keyword follows 'end'
- ;;
- (ada-goto-previous-word)
- (if (looking-at "\\<end\\> *[^;]")
- ;; it ends a block => increase nest depth
- (progn
- (setq nest-count (1+ nest-count))
- (setq pos (point)))
- ;; it starts a block => decrease nest depth
- (setq nest-count (1- nest-count))))
- (goto-char pos))
- ;; found package start => check if it really is a block
- ((looking-at "package")
- (save-excursion
- (ada-search-ignore-string-comment "\\<is\\>")
- (ada-goto-next-non-ws)
- ;; ignore it if it is only a declaration with 'new'
- (if (not (looking-at "\\<new\\>"))
- (setq nest-count (1- nest-count)))))
- ;; found task start => check if it has a body
- ((looking-at "task")
- (save-excursion
- (forward-word 1)
- (ada-goto-next-non-ws)
- ;; ignore it if it has no body
- (if (not (looking-at "\\<body\\>"))
- (setq nest-count (1- nest-count)))))
- ;; all the other block starts
- (t
- (setq nest-count (1- nest-count)))) ; end of 'cond'
-
- ;; match is found, if nest-depth is zero
- ;;
- (setq found (zerop nest-count))) ; end of loop
-
- (if found
- ;;
- ;; match found => is there anything else to do ?
- ;;
- (progn
- (cond
- ;;
- ;; found 'if' => skip to 'then', if it's on a separate line
- ;; and GOTOTHEN is non-nil
- ;;
- ((and
- gotothen
- (looking-at "if")
- (save-excursion
- (ada-search-ignore-string-comment "\\<then\\>" nil nil)
- (back-to-indentation)
- (looking-at "\\<then\\>")))
- (goto-char (match-beginning 0)))
- ;;
- ;; found 'do' => skip back to 'accept'
- ;;
- ((looking-at "do")
- (if (not (ada-search-ignore-string-comment "\\<accept\\>" t nil))
- (error "missing 'accept' in front of 'do'"))))
- (point))
-
- (if noerror
- nil
- (error "no matching start")))))
-
-
-(defun ada-goto-matching-end (&optional nest-level noerror)
- ;; Moves point to the end of a block. Which block depends on the
- ;; value of NEST-LEVEL, which defaults to zero. If NOERROR is
- ;; non-nil, it only returns nil if found no matching start.
- (let ((nest-count (if nest-level nest-level 0))
- (found nil))
-
- ;;
- ;; search forward for interesting keywords
- ;;
- (while (and
- (not found)
- (ada-search-ignore-string-comment
- (concat "\\<\\(end\\|loop\\|select\\|begin\\|case\\|"
- "if\\|task\\|package\\|record\\|do\\)\\>")))
-
- ;;
- ;; calculate nest-depth
- ;;
- (backward-word 1)
- (cond
- ;; found block end => decrease nest depth
- ((looking-at "\\<end\\>")
- (setq nest-count (1- nest-count))
- ;; skip the following keyword
- (if (progn
- (skip-chars-forward "end")
- (ada-goto-next-non-ws)
- (looking-at "\\<\\(loop\\|select\\|record\\|case\\|if\\)\\>"))
- (forward-word 1)))
- ;; found package start => check if it really starts a block
- ((looking-at "\\<package\\>")
- (ada-search-ignore-string-comment "\\<is\\>")
- (ada-goto-next-non-ws)
- ;; ignore and skip it if it is only a 'new' package
- (if (not (looking-at "\\<new\\>"))
- (setq nest-count (1+ nest-count))
- (skip-chars-forward "new")))
- ;; all the other block starts
- (t
- (setq nest-count (1+ nest-count))
- (forward-word 1))) ; end of 'cond'
-
- ;; match is found, if nest-depth is zero
- ;;
- (setq found (zerop nest-count))) ; end of loop
-
- (if (not found)
- (if noerror
- nil
- (error "no matching end"))
- t)))
-
-
-(defun ada-forward-sexp-ignore-comment ()
- ;; Skips one sexp forward, ignoring comments.
- (while (looking-at "[ \t\n]*--")
- (skip-chars-forward "[ \t\n]")
- (end-of-line))
- (forward-sexp 1))
-
-
-(defun ada-search-ignore-string-comment
- (search-re &optional backward limit paramlists)
- ;; Regexp-Search for SEARCH-RE, ignoring comments, strings and
- ;; parameter lists, if PARAMLISTS is nil. Returns a cons cell of
- ;; begin and end of match data or nil, if not found.
- (let ((found nil)
- (begin nil)
- (end nil)
- (pos nil)
- (search-func
- (if backward 're-search-backward
- 're-search-forward)))
-
- ;;
- ;; search until found or end-of-buffer
- ;;
- (while (and (not found)
- (funcall search-func search-re limit 1))
- (setq begin (match-beginning 0))
- (setq end (match-end 0))
-
- (cond
- ;;
- ;; found in comment => skip it
- ;;
- ((ada-in-comment-p)
- (if backward
- (progn
- (re-search-backward "--" nil 1)
- (goto-char (match-beginning 0)))
- (forward-line 1)
- ;; Used to have (beginning-of-line) here,
- ;; but that caused trouble at end of buffer with no newline.
- ))
- ;;
- ;; found in string => skip it
- ;;
- ((ada-in-string-p)
- (if backward
- (progn
- (re-search-backward "\"" nil 1) ; "\"\\|#" don't treat #
- (goto-char (match-beginning 0))))
- (re-search-forward "\"" nil 1))
- ;;
- ;; found character constant => ignore it
- ;;
- ((save-excursion
- (setq pos (- (point) (if backward 1 2)))
- (and (char-after pos)
- (= (char-after pos) ?')
- (= (char-after (+ pos 2)) ?')))
- ())
- ;;
- ;; found a parameter-list but should ignore it => skip it
- ;;
- ((and (not paramlists)
- (ada-in-paramlist-p))
- (if backward
- (ada-search-ignore-string-comment "(" t nil t)))
- ;;
- ;; directly in front of a comment => skip it, if searching forward
- ;;
- ((save-excursion
- (goto-char begin)
- (looking-at "--"))
- (if (not backward)
- (progn
- (forward-line 1)
- (beginning-of-line))))
- ;;
- ;; found what we were looking for
- ;;
- (t
- (setq found t)))) ; end of loop
-
- (if found
- (cons begin end)
- nil)))
-
-
-(defun ada-search-but-not (search-re not-search-re &optional backward limit)
- ;; Searches SEARCH-RE, ignoring parts of NOT-SEARCH-RE, strings,
- ;; comments and parameter-lists.
- (let ((begin nil)
- (end nil)
- (begin-not nil)
- (begin-end nil)
- (end-not nil)
- (ret-cons nil)
- (found nil))
-
- ;;
- ;; search until found or end-of-buffer
- ;;
- (while (and
- (not found)
- (save-excursion
- (setq ret-cons
- (ada-search-ignore-string-comment search-re
- backward limit))
- (if (consp ret-cons)
- (progn
- (setq begin (car ret-cons))
- (setq end (cdr ret-cons))
- t)
- nil)))
-
- (if (or
- ;;
- ;; if no NO-SEARCH-RE was found
- ;;
- (not
- (save-excursion
- (setq ret-cons
- (ada-search-ignore-string-comment not-search-re
- backward nil))
- (if (consp ret-cons)
- (progn
- (setq begin-not (car ret-cons))
- (setq end-not (cdr ret-cons))
- t)
- nil)))
- ;;
- ;; or this NO-SEARCH-RE is not a part of the SEARCH-RE
- ;; found before.
- ;;
- (or
- (<= end-not begin)
- (>= begin-not end)))
-
- (setq found t)
-
- ;;
- ;; not found the correct match => skip this match
- ;;
- (goto-char (if backward
- begin
- end)))) ; end of loop
-
- (if found
- (progn
- (goto-char begin)
- (cons begin end))
- nil)))
-
-
-(defun ada-goto-prev-nonblank-line ( &optional ignore-comment)
- ;; Moves point to the beginning of previous non-blank line,
- ;; ignoring comments if IGNORE-COMMENT is non-nil.
- ;; It returns t if a matching line was found.
- (let ((notfound t)
- (newpoint nil))
-
- (save-excursion
- ;;
- ;; backward one line, if there is one
- ;;
- (if (zerop (forward-line -1))
- ;;
- ;; there is some kind of previous line
- ;;
- (progn
- (beginning-of-line)
- (setq newpoint (point))
-
- ;;
- ;; search until found or beginning-of-buffer
- ;;
- (while (and (setq notfound
- (or (looking-at "[ \t]*$")
- (and (looking-at "[ \t]*--")
- ignore-comment)))
- (not (ada-in-limit-line-p)))
- (forward-line -1)
- ;;(beginning-of-line)
- (setq newpoint (point))) ; end of loop
-
- )) ; end of if
-
- ) ; end of save-excursion
-
- (if notfound nil
- (progn
- (goto-char newpoint)
- t))))
-
-
-(defun ada-goto-next-nonblank-line ( &optional ignore-comment)
- ;; Moves point to next non-blank line,
- ;; ignoring comments if IGNORE-COMMENT is non-nil.
- ;; It returns t if a matching line was found.
- (let ((notfound t)
- (newpoint nil))
-
- (save-excursion
- ;;
- ;; forward one line
- ;;
- (if (zerop (forward-line 1))
- ;;
- ;; there is some kind of previous line
- ;;
- (progn
- (beginning-of-line)
- (setq newpoint (point))
-
- ;;
- ;; search until found or end-of-buffer
- ;;
- (while (and (setq notfound
- (or (looking-at "[ \t]*$")
- (and (looking-at "[ \t]*--")
- ignore-comment)))
- (not (ada-in-limit-line-p)))
- (forward-line 1)
- (beginning-of-line)
- (setq newpoint (point))) ; end of loop
-
- )) ; end of if
-
- ) ; end of save-excursion
-
- (if notfound nil
- (progn
- (goto-char newpoint)
- t))))
-
-
-;; ---- boolean functions for indentation
-
-(defun ada-in-decl-p ()
- ;; Returns t if point is inside a declarative part.
- ;; Assumes point to be at the end of a statement.
- (or
- (ada-in-paramlist-p)
- (save-excursion
- (ada-goto-matching-decl-start t))))
-
-
-(defun ada-looking-at-semi-or ()
- ;; Returns t if looking-at an 'or' following a semicolon.
- (save-excursion
- (and (looking-at "\\<or\\>")
- (progn
- (forward-word 1)
- (ada-goto-stmt-start)
- (looking-at "\\<or\\>")))))
-
-
-(defun ada-looking-at-semi-private ()
- ;; Returns t if looking-at an 'private' following a semicolon.
- (save-excursion
- (and (looking-at "\\<private\\>")
- (progn
- (forward-word 1)
- (ada-goto-stmt-start)
- (looking-at "\\<private\\>")))))
-
-
-;;; make a faster??? ada-in-limit-line-p not using count-lines
-(defun ada-in-limit-line-p ()
- ;; return t if point is in first or last accessible line.
- (or (save-excursion (beginning-of-line) (= (point-min) (point)))
- (save-excursion (end-of-line) (= (point-max) (point)))))
-
-
-(defun ada-in-comment-p ()
- ;; Returns t if inside a comment.
- (nth 4 (parse-partial-sexp
- (save-excursion (beginning-of-line) (point))
- (point))))
-
-
-(defun ada-in-string-p ()
- ;; Returns t if point is inside a string
- ;; (Taken from pascal-mode.el, modified by MH).
- (save-excursion
- (and
- (nth 3 (parse-partial-sexp
- (save-excursion
- (beginning-of-line)
- (point)) (point)))
- ;; check if 'string quote' is only a character constant
- (progn
- (re-search-backward "\"" nil t) ; `#' is not taken as a string delimiter
- (not (= (char-after (1- (point))) ?'))))))
-
-
-(defun ada-in-string-or-comment-p ()
- ;; Returns t if point is inside a string, a comment, or a character constant.
- (let ((parse-result (parse-partial-sexp
- (save-excursion (beginning-of-line) (point)) (point))))
- (or ;; in-comment-p
- (nth 4 parse-result)
- ;; in-string-p
- (and
- (nth 3 parse-result)
- ;; check if 'string quote' is only a character constant
- (progn
- (re-search-backward "\"" nil t) ; `#' not regarded a string delimiter
- (not (= (char-after (1- (point))) ?'))))
- ;; in-char-const-p
- (ada-in-char-const-p))))
-
-
-(defun ada-in-paramlist-p ()
- ;; Returns t if point is inside a parameter-list
- ;; following 'function'/'procedure'/'package'.
- (save-excursion
- (and
- (re-search-backward "(\\|)" nil t)
- ;; inside parentheses ?
- (looking-at "(")
- (backward-word 2)
- ;; right keyword before parenthesis ?
- (looking-at (concat "\\<\\("
- "procedure\\|function\\|body\\|package\\|"
- "task\\|entry\\|accept\\)\\>"))
- (re-search-forward ")\\|:" nil t)
- ;; at least one ':' inside the parentheses ?
- (not (backward-char 1))
- (looking-at ":"))))
-
-
-;; not really a boolean function ...
-(defun ada-in-open-paren-p ()
- ;; If point is somewhere behind an open parenthesis not yet closed,
- ;; it returns the column # of the first non-ws behind this open
- ;; parenthesis, otherwise nil."
- (let ((start (if (<= (point) ada-search-paren-char-count-limit)
- (point-min)
- (save-excursion
- (goto-char (- (point) ada-search-paren-char-count-limit))
- (beginning-of-line)
- (point))))
- parse-result
- (col nil))
- (setq parse-result (parse-partial-sexp start (point)))
- (if (nth 1 parse-result)
- (save-excursion
- (goto-char (1+ (nth 1 parse-result)))
- (if (save-excursion
- (re-search-forward "[^ \t]" nil 1)
- (backward-char 1)
- (and
- (not (looking-at "\n"))
- (setq col (current-column))))
- col
- (current-column)))
- nil)))
-
-
-\f
-;;;----------------------;;;
-;;; Behaviour Of TAB Key ;;;
-;;;----------------------;;;
-
-(defun ada-tab ()
- "Do indenting or tabbing according to `ada-tab-policy'."
- (interactive)
- (cond ((eq ada-tab-policy 'indent-and-tab) (error "not implemented"))
- ;; ada-indent-and-tab
- ((eq ada-tab-policy 'indent-rigidly) (ada-tab-hard))
- ((eq ada-tab-policy 'indent-auto) (ada-indent-current))
- ((eq ada-tab-policy 'gei) (ada-tab-gei))
- ((eq ada-tab-policy 'indent-af) (af-indent-line)) ; GEB
- ((eq ada-tab-policy 'always-tab) (error "not implemented"))
- ))
-
-
-(defun ada-untab (arg)
- "Delete leading indenting according to `ada-tab-policy'."
- (interactive "P")
- (cond ((eq ada-tab-policy 'indent-rigidly) (ada-untab-hard))
- ((eq ada-tab-policy 'indent-af) (backward-delete-char-untabify ; GEB
- (prefix-numeric-value arg) ; GEB
- arg)) ; GEB
- ((eq ada-tab-policy 'indent-auto) (error "not implemented"))
- ((eq ada-tab-policy 'always-tab) (error "not implemented"))
- ))
-
-
-(defun ada-indent-current-function ()
- "Ada mode version of the indent-line-function."
- (interactive "*")
- (let ((starting-point (point-marker)))
- (ada-beginning-of-line)
- (ada-tab)
- (if (< (point) starting-point)
- (goto-char starting-point))
- (set-marker starting-point nil)
- ))
-
-
-(defun ada-tab-hard ()
- "Indent current line to next tab stop."
- (interactive)
- (save-excursion
- (beginning-of-line)
- (insert-char ? ada-indent))
- (if (save-excursion (= (point) (progn (beginning-of-line) (point))))
- (forward-char ada-indent)))
-
-
-(defun ada-untab-hard ()
- "indent current line to previous tab stop."
- (interactive)
- (let ((bol (save-excursion (progn (beginning-of-line) (point))))
- (eol (save-excursion (progn (end-of-line) (point)))))
- (indent-rigidly bol eol (- 0 ada-indent))))
-
-
-\f
-;;;---------------;;;
-;;; Miscellaneous ;;;
-;;;---------------;;;
-
-(defun ada-remove-trailing-spaces ()
- "remove trailing spaces in the whole buffer."
- (interactive)
- (save-match-data
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (while (re-search-forward "[ \t]+$" (point-max) t)
- (replace-match "" nil nil))))))
-
-
-(defun ada-untabify-buffer ()
-;; change all tabs to spaces
- (save-excursion
- (untabify (point-min) (point-max))
- nil))
-
-
-(defun ada-uncomment-region (beg end)
- "delete `comment-start' at the beginning of a line in the region."
- (interactive "r")
- (comment-region beg end -1))
-
-
-;; define a function to support find-file.el if loaded
-(defun ada-ff-other-window ()
- "Find other file in other window using `ff-find-other-file'."
- (interactive)
- (and (fboundp 'ff-find-other-file)
- (ff-find-other-file t)))
-
-;; inspired by Laurent.GUERBY@enst-bretagne.fr
-(defun ada-gnat-style ()
- "Clean up comments, `(' and `,' for GNAT style checking switch."
- (interactive)
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward "-- ?\\([^ -]\\)" nil t)
- (replace-match "-- \\1"))
- (goto-char (point-min))
- (while (re-search-forward "\\>(" nil t)
- (replace-match " ("))
- (goto-char (point-min))
- (while (re-search-forward ",\\<" nil t)
- (replace-match ", "))
- ))
-
-
-\f
-;;;-------------------------------;;;
-;;; Moving To Procedures/Packages ;;;
-;;;-------------------------------;;;
-
-(defun ada-next-procedure ()
- "Moves point to next procedure."
- (interactive)
- (end-of-line)
- (if (re-search-forward ada-procedure-start-regexp nil t)
- (goto-char (match-beginning 1))
- (error "No more functions/procedures/tasks")))
-
-(defun ada-previous-procedure ()
- "Moves point to previous procedure."
- (interactive)
- (beginning-of-line)
- (if (re-search-backward ada-procedure-start-regexp nil t)
- (goto-char (match-beginning 1))
- (error "No more functions/procedures/tasks")))
-
-(defun ada-next-package ()
- "Moves point to next package."
- (interactive)
- (end-of-line)
- (if (re-search-forward ada-package-start-regexp nil t)
- (goto-char (match-beginning 1))
- (error "No more packages")))
-
-(defun ada-previous-package ()
- "Moves point to previous package."
- (interactive)
- (beginning-of-line)
- (if (re-search-backward ada-package-start-regexp nil t)
- (goto-char (match-beginning 1))
- (error "No more packages")))
-
-\f
-;;;-----------------------
-;;; define keymap for Ada
-;;;-----------------------
-
-(if (not ada-mode-map)
- (progn
- (setq ada-mode-map (make-sparse-keymap))
-
- ;; Indentation and Formatting
- (define-key ada-mode-map "\C-j" 'ada-indent-newline-indent)
- (define-key ada-mode-map "\t" 'ada-tab)
- (define-key ada-mode-map "\C-c\C-l" 'ada-indent-region)
- (if (ada-xemacs)
- (define-key ada-mode-map '(shift tab) 'ada-untab)
- (define-key ada-mode-map [S-tab] 'ada-untab))
- (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist)
- (define-key ada-mode-map "\C-c\C-p" 'ada-call-pretty-printer)
-;;; We don't want to make meta-characters case-specific.
-;;; (define-key ada-mode-map "\M-Q" 'ada-fill-comment-paragraph-justify)
- (define-key ada-mode-map "\M-\C-q" 'ada-fill-comment-paragraph-postfix)
-
- ;; Movement
-;;; It isn't good to redefine these. What should be done instead? -- rms.
-;;; (define-key ada-mode-map "\M-e" 'ada-next-package)
-;;; (define-key ada-mode-map "\M-a" 'ada-previous-package)
- (define-key ada-mode-map "\M-\C-e" 'ada-next-procedure)
- (define-key ada-mode-map "\M-\C-a" 'ada-previous-procedure)
- (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start)
- (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end)
-
- ;; Compilation
- (define-key ada-mode-map "\C-c\C-c" 'compile)
- (define-key ada-mode-map "\C-c\C-v" 'ada-check-syntax)
- (define-key ada-mode-map "\C-c\C-m" 'ada-make-local)
-
- ;; Casing
- (define-key ada-mode-map "\C-c\C-r" 'ada-adjust-case-region)
- (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer)
-
- (define-key ada-mode-map "\177" 'backward-delete-char-untabify)
-
- ;; Use predefined function of emacs19 for comments (RE)
- (define-key ada-mode-map "\C-c;" 'comment-region)
- (define-key ada-mode-map "\C-c:" 'ada-uncomment-region)
-
- ;; Change basic functionality
-
- ;; `substitute-key-definition' is not defined equally in Emacs
- ;; and XEmacs, you cannot put in an optional 4th parameter in
- ;; XEmacs. I don't think it's necessary, so I leave it out for
- ;; Emacs as well. If you encounter any problems with the
- ;; following three functions, please tell me. RE
- (mapcar (function (lambda (pair)
- (substitute-key-definition (car pair) (cdr pair)
- ada-mode-map)))
- '((beginning-of-line . ada-beginning-of-line)
- (end-of-line . ada-end-of-line)
- (forward-to-indentation . ada-forward-to-indentation)
- ))
- ;; else Emacs
- ;;(mapcar (lambda (pair)
- ;; (substitute-key-definition (car pair) (cdr pair)
- ;; ada-mode-map global-map))
-
- ))
-
-\f
-;;;-------------------
-;;; define menu 'Ada'
-;;;-------------------
-
-(require 'easymenu)
-
-(defun ada-add-ada-menu ()
- "Adds the menu 'Ada' to the menu bar in Ada mode."
- (easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode."
- '("Ada"
- ["Next Package" ada-next-package t]
- ["Previous Package" ada-previous-package t]
- ["Next Procedure" ada-next-procedure t]
- ["Previous Procedure" ada-previous-procedure t]
- ["Goto Start" ada-move-to-start t]
- ["Goto End" ada-move-to-end t]
- ["------------------" nil nil]
- ["Indent Current Line (TAB)"
- ada-indent-current-function t]
- ["Indent Lines in Region" ada-indent-region t]
- ["Format Parameter List" ada-format-paramlist t]
- ["Pretty Print Buffer" ada-call-pretty-printer t]
- ["------------" nil nil]
- ["Fill Comment Paragraph"
- ada-fill-comment-paragraph t]
- ["Justify Comment Paragraph"
- ada-fill-comment-paragraph-justify t]
- ["Postfix Comment Paragraph"
- ada-fill-comment-paragraph-postfix t]
- ["------------" nil nil]
- ["Adjust Case Region" ada-adjust-case-region t]
- ["Adjust Case Buffer" ada-adjust-case-buffer t]
- ["----------" nil nil]
- ["Comment Region" comment-region t]
- ["Uncomment Region" ada-uncomment-region t]
- ["----------------" nil nil]
- ["Global Make" compile (fboundp 'compile)]
- ["Local Make" ada-make-local t]
- ["Check Syntax" ada-check-syntax t]
- ["Next Error" next-error (fboundp 'next-error)]
- ["---------------" nil nil]
- ["Index" imenu (fboundp 'imenu)]
- ["--------------" nil nil]
- ["Other File Other Window" ada-ff-other-window
- (fboundp 'ff-find-other-file)]
- ["Other File" ff-find-other-file
- (fboundp 'ff-find-other-file)]))
- (if (ada-xemacs) (progn
- (easy-menu-add ada-mode-menu)
- (setq mode-popup-menu (cons "Ada mode" ada-mode-menu)))))
-
-
-\f
-;;;-------------------------------
-;;; Define Some Support Functions
-;;;-------------------------------
-
-(defun ada-beginning-of-line (&optional arg)
- (interactive "P")
- (cond
- ((eq ada-tab-policy 'indent-af) (af-beginning-of-line arg))
- (t (beginning-of-line arg))
- ))
-
-(defun ada-end-of-line (&optional arg)
- (interactive "P")
- (cond
- ((eq ada-tab-policy 'indent-af) (af-end-of-line arg))
- (t (end-of-line arg))
- ))
-
-(defun ada-current-column ()
- (cond
- ((eq ada-tab-policy 'indent-af) (af-current-column))
- (t (current-column))
- ))
-
-(defun ada-forward-to-indentation (&optional arg)
- (interactive "P")
- (cond
- ((eq ada-tab-policy 'indent-af) (af-forward-to-indentation arg))
- (t (forward-to-indentation arg))
- ))
-
-;;;---------------------------------------------------
-;;; support for find-file.el
-;;;---------------------------------------------------
-
-
-;;;###autoload
-(defun ada-make-filename-from-adaname (adaname)
- "Determine the filename of a package/procedure from its own Ada name."
- ;; this is done simply by calling `gnatkr', when we work with GNAT. It
- ;; must be a more complex function in other compiler environments.
- (interactive "s")
- (let (krunch-buf)
- (setq krunch-buf (generate-new-buffer "*gkrunch*"))
- (save-excursion
- (set-buffer krunch-buf)
- ;; send adaname to external process `gnatkr'.
- (call-process "gnatkr" nil krunch-buf nil
- adaname ada-krunch-args)
- ;; fetch output of that process
- (setq adaname (buffer-substring
- (point-min)
- (progn
- (goto-char (point-min))
- (end-of-line)
- (point))))
- (kill-buffer krunch-buf)))
- (setq adaname adaname) ;; can I avoid this statement?
- )
-
-
-;;; functions for placing the cursor on the corresponding subprogram
-(defun ada-which-function-are-we-in ()
- "Determine whether we are on a function definition/declaration.
-If that is the case remember the name of that function."
-
- (setq ff-function-name nil)
-
- (save-excursion
- (if (re-search-backward ada-procedure-start-regexp nil t)
- (setq ff-function-name (buffer-substring (match-beginning 0)
- (match-end 0)))
- ; we didn't find a procedure start, perhaps there is a package
- (if (re-search-backward ada-package-start-regexp nil t)
- (setq ff-function-name (buffer-substring (match-beginning 0)
- (match-end 0)))
- ))))
-
-
-;;;---------------------------------------------------
-;;; support for font-lock
-;;;---------------------------------------------------
-
-;; Strings are a real pain in Ada because a single quote character is
-;; overloaded as a string quote and type/instance delimiter. By default, a
-;; single quote is given punctuation syntax in `ada-mode-syntax-table'.
-;; So, for Font Lock mode purposes, we mark single quotes as having string
-;; syntax when the gods that created Ada determine them to be. sm.
-
-(defconst ada-font-lock-syntactic-keywords
- ;; Mark single quotes as having string quote syntax in 'c' instances.
- '(("\\(\'\\).\\(\'\\)" (1 (7 . ?\')) (2 (7 . ?\')))))
-
-(defconst ada-font-lock-keywords-1
- (list
- ;;
- ;; handle "type T is access function return S;"
- ;;
- (list "\\<\\(function[ \t]+return\\)\\>" '(1 font-lock-keyword-face) )
- ;;
- ;; accept, entry, function, package (body), protected (body|type),
- ;; pragma, procedure, task (body) plus name.
- (list (concat
- "\\<\\("
- "accept\\|"
- "entry\\|"
- "function\\|"
- "package[ \t]+body\\|"
- "package\\|"
- "pragma\\|"
- "procedure\\|"
- "protected[ \t]+body\\|"
- "protected[ \t]+type\\|"
- "protected\\|"
-;; "p\\(\\(ackage\\|rotected\\)\\(\\|[ \t]+\\(body\\|type\\)\\)\
-;;\\|r\\(agma\\|ocedure\\)\\)\\|"
- "task[ \t]+body\\|"
- "task[ \t]+type\\|"
- "task"
-;; "task\\(\\|[ \t]+body\\)"
- "\\)\\>[ \t]*"
- "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
- '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t)))
- "Subdued level highlighting for Ada mode.")
-
-(defconst ada-font-lock-keywords-2
- (append ada-font-lock-keywords-1
- (list
- ;;
- ;; Main keywords, except those treated specially below.
- (concat "\\<\\("
-; ("abort" "abs" "abstract" "accept" "access" "aliased" "all"
-; "and" "array" "at" "begin" "case" "declare" "delay" "delta"
-; "digits" "do" "else" "elsif" "entry" "exception" "exit" "for"
-; "generic" "if" "in" "is" "limited" "loop" "mod" "not"
-; "null" "or" "others" "private" "protected"
-; "range" "record" "rem" "renames" "requeue" "return" "reverse"
-; "select" "separate" "tagged" "task" "terminate" "then" "until"
-; "while" "xor")
- "a\\(b\\(ort\\|s\\(\\|tract\\)\\)\\|cce\\(pt\\|ss\\)\\|"
- "l\\(iased\\|l\\)\\|nd\\|rray\\|t\\)\\|begin\\|case\\|"
- "d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|"
- "e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|for\\|"
- "generic\\|i[fns]\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ot\\|ull\\)\\|"
- "o\\(r\\|thers\\|ut\\)\\|pr\\(ivate\\|otected\\)\\|"
- "r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|"
- "se\\(lect\\|parate\\)\\|"
- "t\\(agged\\|erminate\\|hen\\)\\|until\\|" ; task removed
- "wh\\(ile\\|en\\)\\|xor" ; "when" added
- "\\)\\>")
- ;;
- ;; Anything following end and not already fontified is a body name.
- '("\\<\\(end\\)\\>\\([ \t]+\\)?\\([a-zA-Z0-9_\\.]+\\)?"
- (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t))
- ;;
- ;; Variable name plus optional keywords followed by a type name. Slow.
-; (list (concat "\\<\\(\\sw+\\)\\>[ \t]*:?[ \t]*"
-; "\\(access\\|constant\\|in\\|in[ \t]+out\\|out\\)?[ \t]*"
-; "\\(\\sw+\\)?")
-; '(1 font-lock-variable-name-face)
-; '(2 font-lock-keyword-face nil t) '(3 font-lock-type-face nil t))
- ;;
- ;; Optional keywords followed by a type name.
- (list (concat ; ":[ \t]*"
- "\\<\\(access\\|constant\\|in[ \t]+out\\|in\\|out\\)\\>"
- "[ \t]*"
- "\\(\\sw+\\)?")
- '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t))
- ;;
- ;; Keywords followed by a type or function name.
- (list (concat "\\<\\("
- "new\\|of\\|subtype\\|type"
- "\\)\\>[ \t]*\\(\\sw+\\)?[ \t]*\\((\\)?")
- '(1 font-lock-keyword-face)
- '(2 (if (match-beginning 4)
- font-lock-function-name-face
- font-lock-type-face) nil t))
- ;;
- ;; Keywords followed by a (comma separated list of) reference.
- (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)\\>" ; "when" removed
- ; "[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") ; RE
- "[ \t]*\\([a-zA-Z0-9_\\.\\|, ]+\\)\\W")
- '(1 font-lock-keyword-face) '(2 font-lock-constant-face nil t))
- ;;
- ;; Goto tags.
- '("<<\\(\\sw+\\)>>" 1 font-lock-constant-face)
- ))
- "Gaudy level highlighting for Ada mode.")
-
-(defvar ada-font-lock-keywords ada-font-lock-keywords-1
- "Default expressions to highlight in Ada mode.")
-
-
-;; set font-lock properties for XEmacs
-(if (ada-xemacs)
- (put 'ada-mode 'font-lock-defaults
- '(ada-font-lock-keywords
- nil t ((?\_ . "w")(?\. . "w")) beginning-of-line)))
-
-;;;
-;;; support for outline
-;;;
-
-;; used by outline-minor-mode
-(defun ada-outline-level ()
- ;; This so that `current-column' DTRT in otherwise-hidden text.
- (let (buffer-invisibility-spec)
- (save-excursion
- (skip-chars-forward "\t ")
- (current-column))))
-
-;;;
-;;; generate body
-;;;
-(defun ada-gen-comment-until-proc ()
- ;; comment until spec of a procedure or a function.
- (forward-line 1)
- (set-mark-command (point))
- (if (re-search-forward ada-procedure-start-regexp nil t)
- (progn (goto-char (match-beginning 1))
- (comment-region (mark) (point)))
- (error "No more functions/procedures")))
-
-
-(defun ada-gen-treat-proc (match)
- ;; make dummy body of a procedure/function specification.
- ;; MATCH is a cons cell containing the start and end location of the
- ;; last search for ada-procedure-start-regexp.
- (goto-char (car match))
- (let (proc-found func-found procname functype)
- (cond
- ((or (setq proc-found (looking-at "^[ \t]*procedure"))
- (setq func-found (looking-at "^[ \t]*function")))
- ;; treat it as a proc/func
- (forward-word 2)
- (forward-word -1)
- (setq procname (buffer-substring (point) (cdr match))) ; store proc name
-
- ;; goto end of procname
- (goto-char (cdr match))
-
- ;; skip over parameterlist
- (forward-sexp)
- ;; if function, skip over 'return' and result type.
- (if func-found
- (progn
- (forward-word 1)
- (skip-chars-forward " \t\n")
- (setq functype (buffer-substring (point)
- (progn
- (skip-chars-forward
- "a-zA-Z0-9_\.")
- (point))))))
- ;; look for next non WS
- (cond
- ((looking-at "[ \t]*;")
- (delete-region (match-beginning 0) (match-end 0)) ;; delete the ';'
- (ada-indent-newline-indent)
- (insert " is")
- (ada-indent-newline-indent)
- (if func-found
- (progn
- (insert "Result : ")
- (insert functype)
- (insert ";")
- (ada-indent-newline-indent)))
- (insert "begin -- ")
- (insert procname)
- (ada-indent-newline-indent)
- (insert "null;")
- (ada-indent-newline-indent)
- (if func-found
- (progn
- (insert "return Result;")
- (ada-indent-newline-indent)))
- (insert "end ")
- (insert procname)
- (insert ";")
- (ada-indent-newline-indent)
- )
- ;; else
- ((looking-at "[ \t\n]*is")
- ;; do nothing
- )
- ((looking-at "[ \t\n]*rename")
- ;; do nothing
- )
- (t
- (message "unknown syntax")))
- ))))
-
-
-(defun ada-make-body ()
- "Create an Ada package body in the current buffer.
-The potential old buffer contents is deleted first, then we copy the
-spec buffer in here and modify it to make it a body.
-
-This function typically is to be hooked into `ff-file-created-hooks'."
- (interactive)
- (delete-region (point-min) (point-max))
- (insert-buffer (car (cdr (buffer-list))))
- (ada-mode)
-
- (let (found)
- (if (setq found
- (ada-search-ignore-string-comment ada-package-start-regexp))
- (progn (goto-char (cdr found))
- (insert " body")
- ;; (forward-line -1)
- ;;(comment-region (point-min) (point))
- )
- (error "No package"))
-
- ;; (comment-until-proc)
- ;; does not work correctly
- ;; must be done by hand
-
- (while (setq found
- (ada-search-ignore-string-comment ada-procedure-start-regexp))
- (ada-gen-treat-proc found))))
-
-
-;;; provide ourself
-
-(provide 'ada-mode)
-
-;;; ada-mode.el ends here
+;;; ada-mode.el --- major-mode for editing Ada sources
+
+;; Copyright (C) 1994, 95, 97, 98, 99, 2000, 2001, 2002, 2003
+;; Free Software Foundation, Inc.
+
+;; Author: Rolf Ebert <ebert@inf.enst.fr>
+;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
+;; Emmanuel Briot <briot@gnat.com>
+;; Maintainer: Emmanuel Briot <briot@gnat.com>
+;; Ada Core Technologies's version: Revision: 1.188
+;; Keywords: languages ada
+
+;; 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 2, 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; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+;;; This mode is a major mode for editing Ada83 and Ada95 source code.
+;;; This is a major rewrite of the file packaged with Emacs-20. The
+;;; ada-mode is composed of four lisp files, ada-mode.el, ada-xref.el,
+;;; ada-prj.el and ada-stmt.el. Only this file (ada-mode.el) is
+;;; completely independent from the GNU Ada compiler Gnat, distributed
+;;; by Ada Core Technologies. All the other files rely heavily on
+;;; features provided only by Gnat.
+;;;
+;;; Note: this mode will not work with Emacs 19. If you are on a VMS
+;;; system, where the latest version of Emacs is 19.28, you will need
+;;; another file, called ada-vms.el, that provides some required
+;;; functions.
+
+;;; Usage:
+;;; Emacs should enter Ada mode automatically when you load an Ada file.
+;;; By default, the valid extensions for Ada files are .ads, .adb or .ada
+;;; If the ada-mode does not start automatically, then simply type the
+;;; following command :
+;;; M-x ada-mode
+;;;
+;;; By default, ada-mode is configured to take full advantage of the GNAT
+;;; compiler (the menus will include the cross-referencing features,...).
+;;; If you are using another compiler, you might want to set the following
+;;; variable in your .emacs (Note: do not set this in the ada-mode-hook, it
+;;; won't work) :
+;;; (setq ada-which-compiler 'generic)
+;;;
+;;; This mode requires find-file.el to be present on your system.
+
+;;; 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. It is currently available from the PAL
+;;; (wuarchive.wustl.edu:/languages/ada) as ada-mode-1.06a.tar.Z.
+;;;
+;;; 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 M. Heritsch and R. Ebert has been done.
+;;; 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. Perhaps you prefer sticking
+;;; to his version.
+;;;
+;;; A complete rewrite for Emacs-20 / Gnat-3.11 has been done by Ada Core
+;;; Technologies. Please send bugs to briot@gnat.com
+
+;;; 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 one day
+;;; 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)
+;;; stephen.leake@gsfc.nasa.gov (Stephen Leake)
+;;; robin-reply@reagans.org
+;;; and others for their valuable hints.
+
+;;; Code:
+;;; Note: Every function in this package is compiler-independent.
+;;; The names start with ada-
+;;; The variables that the user can edit can all be modified through
+;;; the customize mode. They are sorted in alphabetical order in this
+;;; file.
+
+;;; Supported packages.
+;;; This package supports a number of other Emacs modes. These other modes
+;;; should be loaded before the ada-mode, which will then setup some variables
+;;; to improve the support for Ada code.
+;;; Here is the list of these modes:
+;;; `which-function-mode': Display the name of the subprogram the cursor is
+;;; in in the mode line.
+;;; `outline-mode': Provides the capability to collapse or expand the code
+;;; for specific language constructs, for instance if you want to hide the
+;;; code corresponding to a subprogram
+;;; `align': This mode is now provided with Emacs 21, but can also be
+;;; installed manually for older versions of Emacs. It provides the
+;;; capability to automatically realign the selected region (for instance
+;;; all ':=', ':' and '--' will be aligned on top of each other.
+;;; `imenu': Provides a menu with the list of entities defined in the current
+;;; buffer, and an easy way to jump to any of them
+;;; `speedbar': Provides a separate file browser, and the capability for each
+;;; file to see the list of entities defined in it and to jump to them
+;;; easily
+;;; `abbrev-mode': Provides the capability to define abbreviations, which
+;;; are automatically expanded when you type them. See the Emacs manual.
+
+(eval-when-compile
+ (require 'ispell nil t)
+ (require 'find-file nil t)
+ (require 'align nil t)
+ (require 'which-func nil t)
+ (require 'compile nil t))
+
+;; this function is needed at compile time
+(eval-and-compile
+ (defun ada-check-emacs-version (major minor &optional is-xemacs)
+ "Returns t if Emacs's version is greater or equal to MAJOR.MINOR.
+If IS-XEMACS is non-nil, check for XEmacs instead of Emacs."
+ (let ((xemacs-running (or (string-match "Lucid" emacs-version)
+ (string-match "XEmacs" emacs-version))))
+ (and (or (and is-xemacs xemacs-running)
+ (not (or is-xemacs xemacs-running)))
+ (or (> emacs-major-version major)
+ (and (= emacs-major-version major)
+ (>= emacs-minor-version minor)))))))
+
+
+;; This call should not be made in the release that is done for the
+;; official Emacs, since it does nothing useful for the latest version
+;;(if (not (ada-check-emacs-version 21 1))
+;; (require 'ada-support))
+
+(defvar ada-mode-hook nil
+ "*List of functions to call when Ada mode is invoked.
+This hook is automatically executed after the `ada-mode' is
+fully loaded.
+This is a good place to add Ada environment specific bindings.")
+
+(defgroup ada nil
+ "Major mode for editing Ada source in Emacs."
+ :group 'languages)
+
+(defcustom ada-auto-case t
+ "*Non-nil means automatically change case of preceding word while typing.
+Casing is done according to `ada-case-keyword', `ada-case-identifier'
+and `ada-case-attribute'."
+ :type 'boolean :group 'ada)
+
+(defcustom ada-broken-decl-indent 0
+ "*Number of columns to indent a broken declaration.
+
+An example is :
+ declare
+ A,
+ >>>>>B : Integer; -- from ada-broken-decl-indent"
+ :type 'integer :group 'ada)
+
+(defcustom ada-broken-indent 2
+ "*Number of columns to indent the continuation of a broken line.
+
+An example is :
+ My_Var : My_Type := (Field1 =>
+ >>>>>>>>>Value); -- from ada-broken-indent"
+ :type 'integer :group 'ada)
+
+(defcustom ada-continuation-indent ada-broken-indent
+ "*Number of columns to indent the continuation of broken lines in
+parenthesis.
+
+An example is :
+ Func (Param1,
+ >>>>>Param2);"
+ :type 'integer :group 'ada)
+
+(defcustom ada-case-attribute 'ada-capitalize-word
+ "*Function to call to adjust the case of Ada attributes.
+It may be `downcase-word', `upcase-word', `ada-loose-case-word',
+`ada-capitalize-word' or `ada-no-auto-case'."
+ :type '(choice (const downcase-word)
+ (const upcase-word)
+ (const ada-capitalize-word)
+ (const ada-loose-case-word)
+ (const ada-no-auto-case))
+ :group 'ada)
+
+(defcustom ada-case-exception-file
+ (list (convert-standard-filename' "~/.emacs_case_exceptions"))
+ "*List of special casing exceptions dictionaries for identifiers.
+The first file is the one where new exceptions will be saved by Emacs
+when you call `ada-create-case-exception'.
+
+These files should contain one word per line, that gives the casing
+to be used for that word in Ada files. If the line starts with the
+character *, then the exception will be used for substrings 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. Each line can be terminated by
+a comment."
+ :type '(repeat (file))
+ :group 'ada)
+
+(defcustom ada-case-keyword 'downcase-word
+ "*Function to call to adjust the case of an Ada keywords.
+It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
+`ada-capitalize-word'."
+ :type '(choice (const downcase-word)
+ (const upcase-word)
+ (const ada-capitalize-word)
+ (const ada-loose-case-word)
+ (const ada-no-auto-case))
+ :group 'ada)
+
+(defcustom ada-case-identifier 'ada-loose-case-word
+ "*Function to call to adjust the case of an Ada identifier.
+It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
+`ada-capitalize-word'."
+ :type '(choice (const downcase-word)
+ (const upcase-word)
+ (const ada-capitalize-word)
+ (const ada-loose-case-word)
+ (const ada-no-auto-case))
+ :group 'ada)
+
+(defcustom ada-clean-buffer-before-saving t
+ "*Non-nil means remove trailing spaces and untabify the buffer before saving."
+ :type 'boolean :group 'ada)
+
+(defcustom ada-indent 3
+ "*Size of Ada indentation.
+
+An example is :
+procedure Foo is
+begin
+>>>>>>>>>>null; -- from ada-indent"
+ :type 'integer :group 'ada)
+
+(defcustom ada-indent-after-return t
+ "*Non-nil means automatically indent after RET or LFD."
+ :type 'boolean :group 'ada)
+
+(defcustom ada-indent-align-comments t
+ "*Non-nil means align comments on previous line comments, if any.
+If nil, indentation is calculated as usual.
+Note that indentation is calculated only if `ada-indent-comment-as-code' is t.
+
+For instance:
+ A := 1; -- A multi-line comment
+ -- aligned if ada-indent-align-comments is t"
+ :type 'boolean :group 'ada)
+
+(defcustom ada-indent-comment-as-code t
+ "*Non-nil means indent comment lines as code.
+nil means do not auto-indent comments."
+ :type 'boolean :group 'ada)
+
+(defcustom ada-indent-handle-comment-special nil
+ "*Non-nil if comment lines should be handled specially inside
+parenthesis.
+By default, if the line that contains the open parenthesis has some
+text following it, then the following lines will be indented in the
+same column as this text. This will not be true if the first line is
+a comment and `ada-indent-handle-comment-special' is t.
+
+type A is
+ ( Value_1, -- common behavior, when not a comment
+ Value_2);
+
+type A is
+ ( -- `ada-indent-handle-comment-special' is nil
+ Value_1,
+ Value_2);
+
+type A is
+ ( -- `ada-indent-handle-comment-special' is non-nil
+ Value_1,
+ Value_2);"
+ :type 'boolean :group 'ada)
+
+(defcustom ada-indent-is-separate t
+ "*Non-nil means indent 'is separate' or 'is abstract' if on a single line."
+ :type 'boolean :group 'ada)
+
+(defcustom ada-indent-record-rel-type 3
+ "*Indentation for 'record' relative to 'type' or 'use'.
+
+An example is:
+ type A is
+ >>>>>>>>>>>record -- from ada-indent-record-rel-type"
+ :type 'integer :group 'ada)
+
+(defcustom ada-indent-renames ada-broken-indent
+ "*Indentation for renames relative to the matching function statement.
+If ada-indent-return is null or negative, the indentation is done relative to
+the open parenthesis (if there is no parenthesis, ada-broken-indent is used).
+
+An example is:
+ function A (B : Integer)
+ return C; -- from ada-indent-return
+ >>>renames Foo; -- from ada-indent-renames"
+ :type 'integer :group 'ada)
+
+(defcustom ada-indent-return 0
+ "*Indentation for 'return' relative to the matching 'function' statement.
+If ada-indent-return is null or negative, the indentation is done relative to
+the open parenthesis (if there is no parenthesis, ada-broken-indent is used).
+
+An example is:
+ function A (B : Integer)
+ >>>>>return C; -- from ada-indent-return"
+ :type 'integer :group 'ada)
+
+(defcustom ada-indent-to-open-paren t
+ "*Non-nil means indent according to the innermost open parenthesis."
+ :type 'boolean :group 'ada)
+
+(defcustom ada-fill-comment-prefix "-- "
+ "*Text inserted in the first columns when filling a comment paragraph.
+Note: if you modify this variable, you will have to invoke `ada-mode'
+again to take account of the new value."
+ :type 'string :group 'ada)
+
+(defcustom ada-fill-comment-postfix " --"
+ "*Text inserted at the end of each line when filling a comment paragraph.
+with `ada-fill-comment-paragraph-postfix'."
+ :type 'string :group 'ada)
+
+(defcustom ada-label-indent -4
+ "*Number of columns to indent a label.
+
+An example is:
+procedure Foo is
+begin
+>>>>>>>>>>>>Label: -- from ada-label-indent
+
+This is also used for <<..>> labels"
+ :type 'integer :group 'ada)
+
+(defcustom ada-language-version 'ada95
+ "*Do we program in `ada83' or `ada95'?"
+ :type '(choice (const ada83) (const ada95)) :group 'ada)
+
+(defcustom ada-move-to-declaration nil
+ "*Non-nil means `ada-move-to-start' moves point to the subprogram declaration,
+not to 'begin'."
+ :type 'boolean :group 'ada)
+
+(defcustom ada-popup-key '[down-mouse-3]
+ "*Key used for binding the contextual menu.
+If nil, no contextual menu is available."
+ :type '(restricted-sexp :match-alternatives (stringp vectorp))
+ :group 'ada)
+
+(defcustom ada-search-directories
+ (append '(".")
+ (split-string (or (getenv "ADA_INCLUDE_PATH") "") ":")
+ '("/usr/adainclude" "/usr/local/adainclude"
+ "/opt/gnu/adainclude"))
+ "*List of directories to search for Ada files.
+See the description for the `ff-search-directories' variable. This variable
+is the initial value of this variable, and is copied and modified in
+`ada-search-directories-internal'."
+ :type '(repeat (choice :tag "Directory"
+ (const :tag "default" nil)
+ (directory :format "%v")))
+ :group 'ada)
+
+(defvar ada-search-directories-internal ada-search-directories
+ "Internal version of `ada-search-directories'.
+Its value is the concatenation of the search path as read in the project file
+and the standard runtime location, and the value of the user-defined
+ada-search-directories.")
+
+(defcustom ada-stmt-end-indent 0
+ "*Number of columns to indent the end of a statement on a separate line.
+
+An example is:
+ if A = B
+ >>>>>>>>>>>then -- from ada-stmt-end-indent"
+ :type 'integer :group 'ada)
+
+(defcustom ada-tab-policy 'indent-auto
+ "*Control the behavior of the TAB key.
+Must be one of :
+`indent-rigidly' : always adds ada-indent blanks at the beginning of the line.
+`indent-auto' : use indentation functions in this file.
+`always-tab' : do indent-relative."
+ :type '(choice (const indent-auto)
+ (const indent-rigidly)
+ (const always-tab))
+ :group 'ada)
+
+(defcustom ada-use-indent ada-broken-indent
+ "*Indentation for the lines in a 'use' statement.
+
+An example is:
+ use Ada.Text_IO,
+ >>>>>Ada.Numerics; -- from ada-use-indent"
+ :type 'integer :group 'ada)
+
+(defcustom ada-when-indent 3
+ "*Indentation for 'when' relative to 'exception' or 'case'.
+
+An example is:
+ case A is
+ >>>>>>>>when B => -- from ada-when-indent"
+ :type 'integer :group 'ada)
+
+(defcustom ada-with-indent ada-broken-indent
+ "*Indentation for the lines in a 'with' statement.
+
+An example is:
+ with Ada.Text_IO,
+ >>>>>Ada.Numerics; -- from ada-with-indent"
+ :type 'integer :group 'ada)
+
+(defcustom ada-which-compiler 'gnat
+ "*Name of the compiler to use.
+This will determine what features are made available through the ada-mode.
+The possible choices are :
+`gnat': Use Ada Core Technologies' Gnat compiler. Add some cross-referencing
+ features
+`generic': Use a generic compiler"
+ :type '(choice (const gnat)
+ (const generic))
+ :group 'ada)
+
+
+;;; ---- end of user configurable variables
+\f
+
+(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-mode-menu (make-sparse-keymap "Ada")
+ "Menu for ada-mode.")
+
+(defvar ada-mode-map (make-sparse-keymap)
+ "Local keymap used for Ada mode.")
+
+(defvar ada-mode-abbrev-table nil
+ "Local abbrev table for Ada mode.")
+
+(defvar ada-mode-syntax-table nil
+ "Syntax table to be used for editing Ada source code.")
+
+(defvar ada-mode-symbol-syntax-table nil
+ "Syntax table for Ada, where `_' is a word constituent.")
+
+(eval-when-compile
+ (defconst ada-83-string-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 keywords.
+This variable is used to define `ada-83-keywords' and `ada-95-keywords'"))
+
+(defvar ada-ret-binding nil
+ "Variable to save key binding of RET when casing is activated.")
+
+(defvar ada-case-exception '()
+ "Alist of words (entities) that have special casing.")
+
+(defvar ada-case-exception-substring '()
+ "Alist of substrings (entities) that have special casing.
+The substrings are detected for word constituant when the word
+is not itself in ada-case-exception, and only for substrings that
+either are at the beginning or end of the word, or start after '_'.")
+
+(defvar ada-lfd-binding nil
+ "Variable to save key binding of LFD when casing is activated.")
+
+(defvar ada-other-file-alist nil
+ "Variable used by find-file to find the name of the other package.
+See `ff-other-file-alist'.")
+
+(defvar ada-align-list
+ '(("[^:]\\(\\s-*\\):[^:]" 1 t)
+ ("[^=]\\(\\s-+\\)=[^=]" 1 t)
+ ("\\(\\s-*\\)use\\s-" 1)
+ ("\\(\\s-*\\)--" 1))
+ "Ada support for align.el <= 2.2
+This variable provides regular expressions on which to align different lines.
+See `align-mode-alist' for more information.")
+
+(defvar ada-align-modes
+ '((ada-declaration
+ (regexp . "[^:]\\(\\s-*\\):[^:]")
+ (valid . (lambda() (not (ada-in-comment-p))))
+ (modes . '(ada-mode)))
+ (ada-assignment
+ (regexp . "[^=]\\(\\s-+\\)=[^=]")
+ (valid . (lambda() (not (ada-in-comment-p))))
+ (modes . '(ada-mode)))
+ (ada-comment
+ (regexp . "\\(\\s-*\\)--")
+ (modes . '(ada-mode)))
+ (ada-use
+ (regexp . "\\(\\s-*\\)use\\s-")
+ (valid . (lambda() (not (ada-in-comment-p))))
+ (modes . '(ada-mode)))
+ )
+ "Ada support for align.el >= 2.8
+This variable defines several rules to use to align different lines.")
+
+(defconst ada-align-region-separate
+ (concat
+ "^\\s-*\\($\\|\\("
+ "begin\\|"
+ "declare\\|"
+ "else\\|"
+ "end\\|"
+ "exception\\|"
+ "for\\|"
+ "function\\|"
+ "generic\\|"
+ "if\\|"
+ "is\\|"
+ "procedure\\|"
+ "record\\|"
+ "return\\|"
+ "type\\|"
+ "when"
+ "\\)\\>\\)")
+ "see the variable `align-region-separate' for more information.")
+
+;;; ---- Below are the regexp used in this package for parsing
+
+(defconst ada-83-keywords
+ (eval-when-compile
+ (concat "\\<" (regexp-opt ada-83-string-keywords t) "\\>"))
+ "Regular expression for looking at Ada83 keywords.")
+
+(defconst ada-95-keywords
+ (eval-when-compile
+ (concat "\\<" (regexp-opt
+ (append
+ '("abstract" "aliased" "protected" "requeue"
+ "tagged" "until")
+ ada-83-string-keywords) t) "\\>"))
+ "Regular expression for looking at Ada95 keywords.")
+
+(defvar ada-keywords ada-95-keywords
+ "Regular expression for looking at Ada keywords.")
+
+(defconst ada-ident-re
+ "\\(\\sw\\|[_.]\\)+"
+ "Regexp matching Ada (qualified) identifiers.")
+
+;; "with" needs to be included in the regexp, so that we can insert new lines
+;; after the declaration of the parameter for a generic.
+(defvar ada-procedure-start-regexp
+ (concat
+ "^[ \t]*\\(with[ \t]+\\)?\\(procedure\\|function\\|task\\)[ \t\n]+"
+
+ ;; subprogram name: operator ("[+/=*]")
+ "\\("
+ "\\(\"[^\"]+\"\\)"
+
+ ;; subprogram name: name
+ "\\|"
+ "\\(\\(\\sw\\|[_.]\\)+\\)"
+ "\\)")
+ "Regexp used to find Ada procedures/functions.")
+
+(defvar ada-package-start-regexp
+ "^[ \t]*\\(package\\)"
+ "Regexp used to find Ada packages.")
+
+
+;;; ---- regexps for indentation functions
+
+(defvar ada-block-start-re
+ (eval-when-compile
+ (concat "\\<\\(" (regexp-opt '("begin" "declare" "else"
+ "exception" "generic" "loop" "or"
+ "private" "select" ))
+ "\\|\\(\\(limited\\|abstract\\|tagged\\)[ \t\n]+\\)*record\\)\\>"))
+ "Regexp for keywords starting Ada blocks.")
+
+(defvar ada-end-stmt-re
+ (eval-when-compile
+ (concat "\\("
+ ";" "\\|"
+ "=>[ \t]*$" "\\|"
+ "^[ \t]*separate[ \t]*(\\(\\sw\\|[_.]\\)+)" "\\|"
+ "\\<" (regexp-opt '("begin" "declare" "is" "do" "else" "generic"
+ "loop" "private" "record" "select"
+ "then abort" "then") t) "\\>" "\\|"
+ "^[ \t]*" (regexp-opt '("function" "package" "procedure")
+ t) "\\>\\(\\sw\\|[ \t_.]\\)+\\<is\\>" "\\|"
+ "^[ \t]*exception\\>"
+ "\\)") )
+ "Regexp of possible ends for a non-broken statement.
+A new statement starts after these.")
+
+(defvar ada-matching-start-re
+ (eval-when-compile
+ (concat "\\<"
+ (regexp-opt
+ '("end" "loop" "select" "begin" "case" "do"
+ "if" "task" "package" "record" "protected") t)
+ "\\>"))
+ "Regexp used in ada-goto-matching-start.")
+
+(defvar ada-matching-decl-start-re
+ (eval-when-compile
+ (concat "\\<"
+ (regexp-opt
+ '("is" "separate" "end" "declare" "if" "new" "begin" "generic" "when") t)
+ "\\>"))
+ "Regexp used in ada-goto-matching-decl-start.")
+
+(defvar ada-loop-start-re
+ "\\<\\(for\\|while\\|loop\\)\\>"
+ "Regexp for the start of a loop.")
+
+(defvar ada-subprog-start-re
+ (eval-when-compile
+ (concat "\\<" (regexp-opt '("accept" "entry" "function" "package" "procedure"
+ "protected" "task") t) "\\>"))
+ "Regexp for the start of a subprogram.")
+
+(defvar ada-named-block-re
+ "[ \t]*\\(\\sw\\|_\\)+[ \t]*:[^=]"
+ "Regexp of the name of a block or loop.")
+
+(defvar ada-contextual-menu-on-identifier nil
+ "Set to true when the right mouse button was clicked on an identifier.")
+
+(defvar ada-contextual-menu-last-point nil
+ "Position of point just before displaying the menu.
+This is a list (point buffer).
+Since `ada-popup-menu' moves the point where the user clicked, the region
+is modified. Therefore no command from the menu knows what the user selected
+before displaying the contextual menu.
+To get the original region, restore the point to this position before
+calling `region-end' and `region-beginning'.
+Modify this variable if you want to restore the point to another position.")
+
+(easy-menu-define ada-contextual-menu nil
+ "Menu to use when the user presses the right mouse button.
+The variable `ada-contextual-menu-on-identifier' will be set to t before
+displaying the menu if point was on an identifier."
+ '("Ada"
+ ["Goto Declaration/Body" ada-point-and-xref
+ :included ada-contextual-menu-on-identifier]
+ ["Goto Body" ada-point-and-xref-body
+ :included ada-contextual-menu-on-identifier]
+ ["Goto Previous Reference" ada-xref-goto-previous-reference]
+ ["List References" ada-find-references
+ :included ada-contextual-menu-on-identifier]
+ ["List Local References" ada-find-local-references
+ :included ada-contextual-menu-on-identifier]
+ ["-" nil nil]
+ ["Other File" ff-find-other-file]
+ ["Goto Parent Unit" ada-goto-parent]))
+
+\f
+;;------------------------------------------------------------------
+;; Support for imenu (see imenu.el)
+;;------------------------------------------------------------------
+
+(defconst ada-imenu-comment-re "\\([ \t]*--.*\\)?")
+
+(defconst ada-imenu-subprogram-menu-re
+ (concat "^[ \t]*\\(procedure\\|function\\)[ \t\n]+"
+ "\\(\\(\\sw\\|_\\)+\\)[ \t\n]*\\([ \t\n]\\|([^)]+)"
+ ada-imenu-comment-re
+ "\\)[ \t\n]*"
+ "\\(return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?is[ \t\n]"))
+
+(defvar ada-imenu-generic-expression
+ (list
+ (list nil ada-imenu-subprogram-menu-re 2)
+ (list "*Specs*"
+ (concat
+ "^[ \t]*\\(procedure\\|function\\)[ \t\n]+\\(\\(\\sw\\|_\\)+\\)"
+ "\\("
+ "\\(" ada-imenu-comment-re "[ \t\n]+\\|[ \t\n]*([^)]+)"
+ ada-imenu-comment-re "\\)";; parameter list or simple space
+ "\\([ \t\n]*return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?"
+ "\\)?;") 2)
+ '("*Tasks*" "^[ \t]*task[ \t]+\\(type[ \t]+\\)?\\(\\(body[ \t]+\\)?\\(\\sw\\|_\\)+\\)" 2)
+ '("*Type Defs*" "^[ \t]*\\(sub\\)?type[ \t]+\\(\\(\\sw\\|_\\)+\\)" 2)
+ '("*Protected*"
+ "^[ \t]*protected[ \t]+\\(type[ \t]+\\)?\\(\\(body[ \t]+\\)?\\(\\sw\\|_\\)+\\)" 2)
+ '("*Packages*" "^[ \t]*package[ \t]+\\(\\(body[ \t]+\\)?\\(\\sw\\|[_.]\\)+\\)" 1))
+ "Imenu generic expression for Ada mode.
+See `imenu-generic-expression'. This variable will create several submenus for
+each type of entity that can be found in an Ada file.")
+
+\f
+;;------------------------------------------------------------
+;; Support for compile.el
+;;------------------------------------------------------------
+
+(defun ada-compile-mouse-goto-error ()
+ "Mouse interface for ada-compile-goto-error."
+ (interactive)
+ (mouse-set-point last-input-event)
+ (ada-compile-goto-error (point))
+ )
+
+(defun ada-compile-goto-error (pos)
+ "Replaces `compile-goto-error' from compile.el.
+If POS is on a file and line location, go to this position. It adds to
+compile.el the capacity to go to a reference in an error message.
+For instance, on this line:
+ foo.adb:61:11: [...] in call to size declared at foo.ads:11
+both file locations can be clicked on and jumped to."
+ (interactive "d")
+ (goto-char pos)
+
+ (skip-chars-backward "-a-zA-Z0-9_:./\\")
+ (cond
+ ;; special case: looking at a filename:line not at the beginning of a line
+ ((and (not (bolp))
+ (looking-at
+ "\\([-_.a-zA-Z0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?"))
+ (let ((line (match-string 2))
+ file
+ (error-pos (point-marker))
+ source)
+ (save-excursion
+ (save-restriction
+ (widen)
+ ;; Use funcall so as to prevent byte-compiler warnings
+ ;; `ada-find-file' is not defined if ada-xref wasn't loaded. But
+ ;; if we can find it, we should use it instead of
+ ;; `compilation-find-file', since the latter doesn't know anything
+ ;; about source path.
+
+ (if (functionp 'ada-find-file)
+ (setq file (funcall (symbol-function 'ada-find-file)
+ (match-string 1)))
+ (setq file (funcall (symbol-function 'compilation-find-file)
+ (point-marker) (match-string 1)
+ "./")))
+ (set-buffer file)
+
+ (if (stringp line)
+ (goto-line (string-to-number line)))
+ (setq source (point-marker))))
+ (funcall (symbol-function 'compilation-goto-locus)
+ (cons source error-pos))
+ ))
+
+ ;; otherwise, default behavior
+ (t
+ (funcall (symbol-function 'compile-goto-error)))
+ )
+ (recenter))
+
+\f
+;;-------------------------------------------------------------------------
+;; Grammar related function
+;; The functions below work with the syntax class of the characters in an Ada
+;; buffer. Two syntax tables are created, depending on whether we want '_'
+;; to be considered as part of a word or not.
+;; Some characters may have multiple meanings depending on the context:
+;; - ' is either the beginning of a constant character or an attribute
+;; - # is either part of a based litteral or a gnatprep statement.
+;; - " starts a string, but not if inside a constant character.
+;; - ( and ) should be ignored if inside a constant character.
+;; Thus their syntax property is changed automatically, and we can still use
+;; the standard Emacs functions for sexp (see `ada-in-string-p')
+;;
+;; On Emacs, this is done through the `syntax-table' text property. The
+;; modification is done automatically each time the user as typed a new
+;; character. This is already done in `font-lock-mode' (in
+;; `font-lock-syntactic-keywords', so we take advantage of the existing
+;; mechanism. If font-lock-mode is not activated, we do it by hand in
+;; `ada-after-change-function', thanks to `ada-deactivate-properties' and
+;; `ada-initialize-properties'.
+;;
+;; on XEmacs, the `syntax-table' property does not exist and we have to use a
+;; slow advice to `parse-partial-sexp' to do the same thing.
+;; When executing parse-partial-sexp, we simply modify the strings before and
+;; after, so that the special constants '"', '(' and ')' do not interact
+;; with parse-partial-sexp.
+;; Note: this code is slow and needs to be rewritten as soon as something
+;; better is available on XEmacs.
+;;-------------------------------------------------------------------------
+
+(defun ada-create-syntax-table ()
+ "Create the two syntax tables use in the Ada mode.
+The standard table declares `_' as a symbol constituent, the second one
+declares it as a word constituent."
+ (interactive)
+ (setq ada-mode-syntax-table (make-syntax-table))
+ (set-syntax-table ada-mode-syntax-table)
+
+ ;; define string brackets (`%' is alternative string bracket, but
+ ;; almost never used as such and throws font-lock and indentation
+ ;; off the track.)
+ (modify-syntax-entry ?% "$" ada-mode-syntax-table)
+ (modify-syntax-entry ?\" "\"" ada-mode-syntax-table)
+
+ (modify-syntax-entry ?: "." ada-mode-syntax-table)
+ (modify-syntax-entry ?\; "." ada-mode-syntax-table)
+ (modify-syntax-entry ?& "." ada-mode-syntax-table)
+ (modify-syntax-entry ?\| "." ada-mode-syntax-table)
+ (modify-syntax-entry ?+ "." ada-mode-syntax-table)
+ (modify-syntax-entry ?* "." ada-mode-syntax-table)
+ (modify-syntax-entry ?/ "." ada-mode-syntax-table)
+ (modify-syntax-entry ?= "." ada-mode-syntax-table)
+ (modify-syntax-entry ?< "." ada-mode-syntax-table)
+ (modify-syntax-entry ?> "." ada-mode-syntax-table)
+ (modify-syntax-entry ?$ "." ada-mode-syntax-table)
+ (modify-syntax-entry ?\[ "." ada-mode-syntax-table)
+ (modify-syntax-entry ?\] "." ada-mode-syntax-table)
+ (modify-syntax-entry ?\{ "." ada-mode-syntax-table)
+ (modify-syntax-entry ?\} "." ada-mode-syntax-table)
+ (modify-syntax-entry ?. "." ada-mode-syntax-table)
+ (modify-syntax-entry ?\\ "." ada-mode-syntax-table)
+ (modify-syntax-entry ?\' "." ada-mode-syntax-table)
+
+ ;; a single hyphen is punctuation, but a double hyphen starts a comment
+ (modify-syntax-entry ?- ". 12" ada-mode-syntax-table)
+
+ ;; See the comment above on grammar related function for the special
+ ;; setup for '#'.
+ (if (featurep 'xemacs)
+ (modify-syntax-entry ?# "<" ada-mode-syntax-table)
+ (modify-syntax-entry ?# "$" ada-mode-syntax-table))
+
+ ;; and \f and \n end a comment
+ (modify-syntax-entry ?\f "> " ada-mode-syntax-table)
+ (modify-syntax-entry ?\n "> " ada-mode-syntax-table)
+
+ ;; define what belongs in Ada symbols
+ (modify-syntax-entry ?_ "_" ada-mode-syntax-table)
+
+ ;; define parentheses to match
+ (modify-syntax-entry ?\( "()" ada-mode-syntax-table)
+ (modify-syntax-entry ?\) ")(" ada-mode-syntax-table)
+
+ (setq ada-mode-symbol-syntax-table (copy-syntax-table ada-mode-syntax-table))
+ (modify-syntax-entry ?_ "w" ada-mode-symbol-syntax-table)
+ )
+
+;; Support of special characters in XEmacs (see the comments at the beginning
+;; of the section on Grammar related functions).
+
+(if (featurep 'xemacs)
+ (defadvice parse-partial-sexp (around parse-partial-sexp-protect-constants)
+ "Handles special character constants and gnatprep statements."
+ (let (change)
+ (if (< to from)
+ (let ((tmp from))
+ (setq from to to tmp)))
+ (save-excursion
+ (goto-char from)
+ (while (re-search-forward "'\\([(\")#]\\)'" to t)
+ (setq change (cons (list (match-beginning 1)
+ 1
+ (match-string 1))
+ change))
+ (replace-match "'A'"))
+ (goto-char from)
+ (while (re-search-forward "\\(#[0-9a-fA-F]*#\\)" to t)
+ (setq change (cons (list (match-beginning 1)
+ (length (match-string 1))
+ (match-string 1))
+ change))
+ (replace-match (make-string (length (match-string 1)) ?@))))
+ ad-do-it
+ (save-excursion
+ (while change
+ (goto-char (caar change))
+ (delete-char (cadar change))
+ (insert (caddar change))
+ (setq change (cdr change)))))))
+
+(defun ada-deactivate-properties ()
+ "Deactivate ada-mode's properties handling.
+This would be a duplicate of font-lock if both are used at the same time."
+ (remove-hook 'after-change-functions 'ada-after-change-function t))
+
+(defun ada-initialize-properties ()
+ "Initialize some special text properties in the whole buffer.
+In particular, character constants are said to be strings, #...# are treated
+as numbers instead of gnatprep comments."
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (re-search-forward "'.'" nil t)
+ (add-text-properties (match-beginning 0) (match-end 0)
+ '(syntax-table ("'" . ?\"))))
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]*#" nil t)
+ (add-text-properties (match-beginning 0) (match-end 0)
+ '(syntax-table (11 . 10))))
+ (set-buffer-modified-p nil)
+
+ ;; Setting this only if font-lock is not set won't work
+ ;; if the user activates or deactivates font-lock-mode,
+ ;; but will make things faster most of the time
+ (add-hook 'after-change-functions 'ada-after-change-function nil t)
+ )))
+
+(defun ada-after-change-function (beg end old-len)
+ "Called when the region between BEG and END was changed in the buffer.
+OLD-LEN indicates what the length of the replaced text was."
+ (let ((inhibit-point-motion-hooks t)
+ (eol (point)))
+ (save-excursion
+ (save-match-data
+ (beginning-of-line)
+ (remove-text-properties (point) eol '(syntax-table nil))
+ (while (re-search-forward "'.'" eol t)
+ (add-text-properties (match-beginning 0) (match-end 0)
+ '(syntax-table ("'" . ?\"))))
+ (beginning-of-line)
+ (if (looking-at "^[ \t]*#")
+ (add-text-properties (match-beginning 0) (match-end 0)
+ '(syntax-table (11 . 10))))))))
+
+;;------------------------------------------------------------------
+;; Testing the grammatical context
+;;------------------------------------------------------------------
+
+(defsubst ada-in-comment-p (&optional parse-result)
+ "Returns t if inside a comment."
+ (nth 4 (or parse-result
+ (parse-partial-sexp
+ (line-beginning-position) (point)))))
+
+(defsubst ada-in-string-p (&optional parse-result)
+ "Returns t if point is inside a string.
+If parse-result is non-nil, use is instead of calling parse-partial-sexp."
+ (nth 3 (or parse-result
+ (parse-partial-sexp
+ (line-beginning-position) (point)))))
+
+(defsubst ada-in-string-or-comment-p (&optional parse-result)
+ "Returns t if inside a comment or string."
+ (setq parse-result (or parse-result
+ (parse-partial-sexp
+ (line-beginning-position) (point))))
+ (or (ada-in-string-p parse-result) (ada-in-comment-p parse-result)))
+
+
+;;------------------------------------------------------------------
+;; Contextual menus
+;; The Ada-mode comes with contextual menus, bound by default to the right
+;; mouse button.
+;; Add items to this menu by modifying `ada-contextual-menu'. Note that the
+;; variable `ada-contextual-menu-on-identifier' is set automatically to t
+;; if the mouse button was pressed on an identifier.
+;;------------------------------------------------------------------
+
+(defun ada-call-from-contextual-menu (function)
+ "Execute FUNCTION when called from the contextual menu.
+It forces Emacs to change the cursor position."
+ (interactive)
+ (funcall function)
+ (setq ada-contextual-menu-last-point
+ (list (point) (current-buffer))))
+
+(defun ada-popup-menu (position)
+ "Pops up a contextual menu, depending on where the user clicked.
+POSITION is the location the mouse was clicked on.
+Sets `ada-contextual-menu-last-point' to the current position before
+displaying the menu. When a function from the menu is called, the point is
+where the mouse button was clicked."
+ (interactive "e")
+
+ ;; declare this as a local variable, so that the function called
+ ;; in the contextual menu does not hide the region in
+ ;; transient-mark-mode.
+ (let ((deactivate-mark nil))
+ (setq ada-contextual-menu-last-point
+ (list (point) (current-buffer)))
+ (mouse-set-point last-input-event)
+
+ (setq ada-contextual-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)))
+ ))
+ (if (fboundp 'popup-menu)
+ (funcall (symbol-function 'popup-menu) ada-contextual-menu)
+ (let (choice)
+ (setq choice (x-popup-menu position ada-contextual-menu))
+ (if choice
+ (funcall (lookup-key ada-contextual-menu (vector (car choice)))))))
+
+ (set-buffer (cadr ada-contextual-menu-last-point))
+ (goto-char (car ada-contextual-menu-last-point))
+ ))
+
+
+;;------------------------------------------------------------------
+;; Misc functions
+;;------------------------------------------------------------------
+
+;;;###autoload
+(defun ada-add-extensions (spec body)
+ "Define SPEC and BODY as being valid extensions for Ada files.
+Going from body to spec with `ff-find-other-file' used these
+extensions.
+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)
+
+ ;; Support for speedbar (Specifies that we want to see these files in
+ ;; speedbar)
+ (if (fboundp 'speedbar-add-supported-extension)
+ (progn
+ (funcall (symbol-function 'speedbar-add-supported-extension)
+ spec)
+ (funcall (symbol-function 'speedbar-add-supported-extension)
+ body)))
+ )
+
+
+;;;###autoload
+(defun ada-mode ()
+ "Ada mode is the major mode for editing Ada code.
+This version was built on $Date: 2003/05/04 19:52:34 $.
+
+Bindings are as follows: (Note: 'LFD' is control-j.)
+\\{ada-mode-map}
+
+ Indent line '\\[ada-tab]'
+ Indent line, insert newline and indent the new line. '\\[newline-and-indent]'
+
+ Re-format the parameter-list point is in '\\[ada-format-paramlist]'
+ Indent all lines in region '\\[ada-indent-region]'
+
+ Adjust case of identifiers and keywords in region '\\[ada-adjust-case-region]'
+ Adjust case of identifiers and keywords in buffer '\\[ada-adjust-case-buffer]'
+
+ Fill comment paragraph, justify and append postfix '\\[fill-paragraph]'
+
+ Next func/proc/task '\\[ada-next-procedure]' Previous func/proc/task '\\[ada-previous-procedure]'
+ Next package '\\[ada-next-package]' Previous package '\\[ada-previous-package]'
+
+ Goto matching start of current 'end ...;' '\\[ada-move-to-start]'
+ Goto end of current block '\\[ada-move-to-end]'
+
+Comments are handled using standard GNU Emacs conventions, including:
+ Start a comment '\\[indent-for-comment]'
+ Comment region '\\[comment-region]'
+ Uncomment region '\\[ada-uncomment-region]'
+ Continue comment on next line '\\[indent-new-comment-line]'
+
+If you use imenu.el:
+ Display index-menu of functions & procedures '\\[imenu]'
+
+If you use find-file.el:
+ Switch to other file (Body <-> Spec) '\\[ff-find-other-file]'
+ or '\\[ff-mouse-find-other-file]
+ Switch to other file in other window '\\[ada-ff-other-window]'
+ or '\\[ff-mouse-find-other-file-other-window]
+ If you use this function in a spec and no body is available, it gets created with body stubs.
+
+If you use ada-xref.el:
+ Goto declaration: '\\[ada-point-and-xref]' on the identifier
+ or '\\[ada-goto-declaration]' with point on the identifier
+ Complete identifier: '\\[ada-complete-identifier]'."
+
+ (interactive)
+ (kill-all-local-variables)
+
+ (set (make-local-variable 'require-final-newline) t)
+
+ ;; Set the paragraph delimiters so that one can select a whole block
+ ;; simply with M-h
+ (set (make-local-variable 'paragraph-start) "[ \t\n\f]*$")
+ (set (make-local-variable 'paragraph-separate) "[ \t\n\f]*$")
+
+ ;; comment end must be set because it may hold a wrong value if
+ ;; this buffer had been in another mode before. RE
+ (set (make-local-variable 'comment-end) "")
+
+ ;; used by autofill and indent-new-comment-line
+ (set (make-local-variable 'comment-start-skip) "---*[ \t]*")
+
+ ;; used by autofill to break a comment line and continue it on another line.
+ ;; The reason we need this one is that the default behavior does not work
+ ;; correctly with the definition of paragraph-start above when the comment
+ ;; is right after a multi-line subprogram declaration (the comments are
+ ;; aligned under the latest parameter, not under the declaration start).
+ (set (make-local-variable 'comment-line-break-function)
+ (lambda (&optional soft) (let ((fill-prefix nil))
+ (indent-new-comment-line soft))))
+
+ (set (make-local-variable 'indent-line-function)
+ 'ada-indent-current-function)
+
+ (set (make-local-variable 'comment-column) 40)
+
+ ;; Emacs 20.3 defines a comment-padding to insert spaces between
+ ;; the comment and the text. We do not want any, this is already
+ ;; included in comment-start
+ (unless (featurep 'xemacs)
+ (progn
+ (if (ada-check-emacs-version 20 3)
+ (progn
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (set (make-local-variable 'comment-padding) 0)))
+ (set (make-local-variable 'parse-sexp-lookup-properties) t)
+ ))
+
+ (set 'case-fold-search t)
+ (if (boundp 'imenu-case-fold-search)
+ (set 'imenu-case-fold-search t))
+
+ (set (make-local-variable 'fill-paragraph-function)
+ 'ada-fill-comment-paragraph)
+
+ (set (make-local-variable 'imenu-generic-expression)
+ ada-imenu-generic-expression)
+
+ ;; Support for compile.el
+ ;; We just substitute our own functions to go to the error.
+ (add-hook 'compilation-mode-hook
+ (lambda()
+ (set (make-local-variable 'compile-auto-highlight) 40)
+ ;; FIXME: This has global impact! -stef
+ (define-key compilation-minor-mode-map [mouse-2]
+ 'ada-compile-mouse-goto-error)
+ (define-key compilation-minor-mode-map "\C-c\C-c"
+ 'ada-compile-goto-error)
+ (define-key compilation-minor-mode-map "\C-m"
+ 'ada-compile-goto-error)))
+
+ ;; font-lock support :
+ ;; We need to set some properties for XEmacs, and define some variables
+ ;; for Emacs
+
+ (if (featurep 'xemacs)
+ ;; XEmacs
+ (put 'ada-mode 'font-lock-defaults
+ '(ada-font-lock-keywords
+ nil t ((?\_ . "w") (?# . ".")) beginning-of-line))
+ ;; Emacs
+ (set (make-local-variable 'font-lock-defaults)
+ '(ada-font-lock-keywords
+ nil t
+ ((?\_ . "w") (?# . "."))
+ beginning-of-line
+ (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords)))
+ )
+
+ ;; Set up support for find-file.el.
+ (set (make-local-variable 'ff-other-file-alist)
+ 'ada-other-file-alist)
+ (set (make-local-variable 'ff-search-directories)
+ 'ada-search-directories-internal)
+ (setq ff-post-load-hook 'ada-set-point-accordingly
+ ff-file-created-hook 'ada-make-body)
+ (add-hook 'ff-pre-load-hook 'ada-which-function-are-we-in)
+
+ ;; Some special constructs for find-file.el
+ ;; We do not need to add the construction for 'with', which is in the
+ ;; standard find-file.el
+ (make-local-variable 'ff-special-constructs)
+
+ ;; Go to the parent package :
+ (add-to-list 'ff-special-constructs
+ (cons (eval-when-compile
+ (concat "^\\(private[ \t]\\)?[ \t]*package[ \t]+"
+ "\\(body[ \t]+\\)?"
+ "\\(\\(\\sw\\|[_.]\\)+\\)\\.\\(\\sw\\|_\\)+[ \t\n]+is"))
+ (lambda ()
+ (if (fboundp 'ff-get-file)
+ (if (boundp 'fname)
+ (set 'fname (ff-get-file
+ ada-search-directories-internal
+ (ada-make-filename-from-adaname
+ (match-string 3))
+ ada-spec-suffixes)))))))
+ ;; Another special construct for find-file.el : when in a separate clause,
+ ;; go to the correct package.
+ (add-to-list 'ff-special-constructs
+ (cons "^separate[ \t\n]*(\\(\\(\\sw\\|[_.]\\)+\\))"
+ (lambda ()
+ (if (fboundp 'ff-get-file)
+ (if (boundp 'fname)
+ (setq fname (ff-get-file
+ ada-search-directories-internal
+ (ada-make-filename-from-adaname
+ (match-string 1))
+ ada-spec-suffixes)))))))
+
+ ;; Another special construct, that redefines the one in find-file.el. The
+ ;; old one can handle only one possible type of extension for Ada files
+ ;; remove from the list the standard "with..." that is put by find-file.el,
+ ;; since it uses the old ada-spec-suffix variable
+ ;; This one needs to replace the standard one defined in find-file.el (with
+ ;; Emacs <= 20.4), since that one uses the old variable ada-spec-suffix
+ (let ((old-construct
+ (assoc "^with[ \t]+\\([a-zA-Z0-9_\\.]+\\)" ff-special-constructs))
+ (new-cdr
+ (lambda ()
+ (if (fboundp 'ff-get-file)
+ (if (boundp 'fname)
+ (set 'fname (ff-get-file
+ ada-search-directories-internal
+ (ada-make-filename-from-adaname
+ (match-string 1))
+ ada-spec-suffixes)))))))
+ (if old-construct
+ (setcdr old-construct new-cdr)
+ (add-to-list 'ff-special-constructs
+ (cons "^with[ \t]+\\([a-zA-Z0-9_\\.]+\\)"
+ new-cdr))))
+
+ ;; Support for outline-minor-mode
+ (set (make-local-variable 'outline-regexp)
+ "\\([ \t]*\\(procedure\\|function\\|package\\|if\\|while\\|for\\|declare\\|case\\|end\\|begin\\|loop\\)\\|--\\)")
+ (set (make-local-variable 'outline-level) 'ada-outline-level)
+
+ ;; Support for imenu : We want a sorted index
+ (setq imenu-sort-function 'imenu--sort-by-name)
+
+ ;; Support for ispell : Check only comments
+ (set (make-local-variable 'ispell-check-comments) 'exclusive)
+
+ ;; Support for align.el <= 2.2, if present
+ ;; align.el is distributed with Emacs 21, but not with earlier versions.
+ (if (boundp 'align-mode-alist)
+ (add-to-list 'align-mode-alist '(ada-mode . ada-align-list)))
+
+ ;; Support for align.el >= 2.8, if present
+ (if (boundp 'align-dq-string-modes)
+ (progn
+ (add-to-list 'align-dq-string-modes 'ada-mode)
+ (add-to-list 'align-open-comment-modes 'ada-mode)
+ (set (make-variable-buffer-local 'align-region-separate)
+ ada-align-region-separate)
+
+ ;; 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 ada-align-modes nil)
+
+ (add-to-list 'ada-align-modes
+ '(ada-declaration-assign
+ (regexp . "[^:]\\(\\s-*\\):[^:]")
+ (valid . (lambda() (not (ada-in-comment-p))))
+ (repeat . t)
+ (modes . '(ada-mode))))
+ (add-to-list 'ada-align-modes
+ '(ada-associate
+ (regexp . "[^=]\\(\\s-*\\)=>")
+ (valid . (lambda() (not (ada-in-comment-p))))
+ (modes . '(ada-mode))))
+ (add-to-list 'ada-align-modes
+ '(ada-comment
+ (regexp . "\\(\\s-*\\)--")
+ (modes . '(ada-mode))))
+ (add-to-list 'ada-align-modes
+ '(ada-use
+ (regexp . "\\(\\s-*\\)\\<use\\s-")
+ (valid . (lambda() (not (ada-in-comment-p))))
+ (modes . '(ada-mode))))
+ (add-to-list 'ada-align-modes
+ '(ada-at
+ (regexp . "\\(\\s-+\\)at\\>")
+ (modes . '(ada-mode))))
+
+
+ (setq align-mode-rules-list ada-align-modes)
+ ))
+
+ ;; Set up the contextual menu
+ (if ada-popup-key
+ (define-key ada-mode-map ada-popup-key 'ada-popup-menu))
+
+ ;; Support for Abbreviations (the user still need to "M-x abbrev-mode"
+ (define-abbrev-table 'ada-mode-abbrev-table ())
+ (setq local-abbrev-table ada-mode-abbrev-table)
+
+ ;; Support for which-function mode
+ ;; which-function-mode does not work with nested subprograms, since it is
+ ;; based only on the regexps generated by imenu, and thus can only detect the
+ ;; beginning of subprograms, not the end.
+ ;; Fix is: redefine a new function ada-which-function, and call it when the
+ ;; major-mode is ada-mode.
+
+ (unless (featurep 'xemacs)
+ ;; This function do not require that we load which-func now.
+ ;; This can be done by the user if he decides to use which-func-mode
+
+ (defadvice which-function (around ada-which-function activate)
+ "In Ada buffers, should work with overloaded subprograms, and does not
+use imenu."
+ (if (equal major-mode 'ada-mode)
+ (set 'ad-return-value (ada-which-function))
+ ad-do-it))
+
+ ;; So that we can activate which-func-modes for Ada mode
+ (if (and (boundp 'which-func-modes)
+ (listp which-func-modes))
+ (add-to-list 'which-func-modes 'ada-mode))
+ )
+
+ ;; Support for indent-new-comment-line (Especially for XEmacs)
+ (setq comment-multi-line nil)
+
+ (setq major-mode 'ada-mode
+ mode-name "Ada")
+
+ (use-local-map ada-mode-map)
+
+ (easy-menu-add ada-mode-menu ada-mode-map)
+
+ (set-syntax-table ada-mode-syntax-table)
+
+ (if ada-clean-buffer-before-saving
+ (progn
+ ;; remove all spaces at the end of lines in the whole buffer.
+ (add-hook 'local-write-file-hooks 'delete-trailing-whitespace)
+ ;; convert all tabs to the correct number of spaces.
+ (add-hook 'local-write-file-hooks
+ (lambda () (untabify (point-min) (point-max))))))
+
+ (run-hooks 'ada-mode-hook)
+
+ ;; To be run after the hook, in case the user modified
+ ;; ada-fill-comment-prefix
+ (make-local-variable 'comment-start)
+ (if ada-fill-comment-prefix
+ (set 'comment-start ada-fill-comment-prefix)
+ (set 'comment-start "-- "))
+
+ ;; Run this after the hook to give the users a chance to activate
+ ;; font-lock-mode
+
+ (unless (featurep 'xemacs)
+ (progn
+ (ada-initialize-properties)
+ (add-hook 'font-lock-mode-hook 'ada-deactivate-properties nil t)))
+
+ ;; the following has to be done after running the ada-mode-hook
+ ;; because users might want to set the values of these variable
+ ;; inside the hook (MH)
+
+ (cond ((eq ada-language-version 'ada83)
+ (setq ada-keywords ada-83-keywords))
+ ((eq ada-language-version 'ada95)
+ (setq ada-keywords ada-95-keywords)))
+
+ (if ada-auto-case
+ (ada-activate-keys-for-case)))
+
+
+;; transient-mark-mode and mark-active are not defined in XEmacs
+(defun ada-region-selected ()
+ "t if a region has been selected by the user and is still active."
+ (or (and (featurep 'xemacs) (funcall (symbol-function 'region-active-p)))
+ (and (not (featurep 'xemacs))
+ (symbol-value 'transient-mark-mode)
+ (symbol-value 'mark-active))))
+
+\f
+;;-----------------------------------------------------------------
+;; auto-casing
+;; Since Ada is case-insensitive, the Ada-mode provides an extensive set of
+;; functions to auto-case identifiers, keywords, ...
+;; The basic rules for autocasing are defined through the variables
+;; `ada-case-attribute', `ada-case-keyword' and `ada-case-identifier'. These
+;; are references to the functions that will do the actual casing.
+;;
+;; However, in most cases, the user will want to define some exceptions to
+;; these casing rules. This is done through a list of files, that contain
+;; one word per line. These files are stored in `ada-case-exception-file'.
+;; For backward compatibility, this variable can also be a string.
+;;-----------------------------------------------------------------
+
+(defun ada-save-exceptions-to-file (file-name)
+ "Save the exception lists `ada-case-exception' and
+`ada-case-exception-substring' to the file FILE-NAME."
+
+ ;; Save the list in the file
+ (find-file (expand-file-name file-name))
+ (erase-buffer)
+ (mapcar (lambda (x) (insert (car x) "\n"))
+ (sort (copy-sequence ada-case-exception)
+ (lambda(a b) (string< (car a) (car b)))))
+ (mapcar (lambda (x) (insert "*" (car x) "\n"))
+ (sort (copy-sequence ada-case-exception-substring)
+ (lambda(a b) (string< (car a) (car b)))))
+ (save-buffer)
+ (kill-buffer nil)
+ )
+
+(defun ada-create-case-exception (&optional word)
+ "Defines WORD as an exception for the casing system.
+If WORD is not given, then the current word in the buffer is used instead.
+The new words is added to the first file in `ada-case-exception-file'.
+The standard casing rules will no longer apply to this word."
+ (interactive)
+ (let ((previous-syntax-table (syntax-table))
+ file-name
+ )
+
+ (cond ((stringp ada-case-exception-file)
+ (setq file-name ada-case-exception-file))
+ ((listp ada-case-exception-file)
+ (setq file-name (car ada-case-exception-file)))
+ (t
+ (error (concat "No exception file specified. "
+ "See variable ada-case-exception-file."))))
+
+ (set-syntax-table ada-mode-symbol-syntax-table)
+ (unless word
+ (save-excursion
+ (skip-syntax-backward "w")
+ (setq word (buffer-substring-no-properties
+ (point) (save-excursion (forward-word 1) (point))))))
+ (set-syntax-table previous-syntax-table)
+
+ ;; Reread the exceptions file, in case it was modified by some other,
+ (ada-case-read-exceptions-from-file file-name)
+
+ ;; If the word is already in the list, even with a different casing
+ ;; we simply want to replace it.
+ (if (and (not (equal ada-case-exception '()))
+ (assoc-ignore-case word ada-case-exception))
+ (setcar (assoc-ignore-case word ada-case-exception) word)
+ (add-to-list 'ada-case-exception (cons word t))
+ )
+
+ (ada-save-exceptions-to-file file-name)
+ ))
+
+(defun ada-create-case-exception-substring (&optional word)
+ "Defines the substring WORD as an exception for the casing system.
+If WORD is not given, then the current word in the buffer is used instead,
+or the selected region if any is active.
+The new words is added to the first file in `ada-case-exception-file'.
+When auto-casing a word, this substring will be special-cased, unless the
+word itself has a special casing."
+ (interactive)
+ (let ((file-name
+ (cond ((stringp ada-case-exception-file)
+ ada-case-exception-file)
+ ((listp ada-case-exception-file)
+ (car ada-case-exception-file))
+ (t
+ (error (concat "No exception file specified. "
+ "See variable ada-case-exception-file."))))))
+
+ ;; Find the substring to define as an exception. Order is: the parameter,
+ ;; if any, or the selected region, or the word under the cursor
+ (cond
+ (word nil)
+
+ ((ada-region-selected)
+ (setq word (buffer-substring-no-properties
+ (region-beginning) (region-end))))
+
+ (t
+ (let ((underscore-syntax (char-syntax ?_)))
+ (unwind-protect
+ (progn
+ (modify-syntax-entry ?_ "." (syntax-table))
+ (save-excursion
+ (skip-syntax-backward "w")
+ (set 'word (buffer-substring-no-properties
+ (point)
+ (save-excursion (forward-word 1) (point))))))
+ (modify-syntax-entry ?_ (make-string 1 underscore-syntax)
+ (syntax-table))))))
+
+ ;; Reread the exceptions file, in case it was modified by some other,
+ (ada-case-read-exceptions-from-file file-name)
+
+ ;; If the word is already in the list, even with a different casing
+ ;; we simply want to replace it.
+ (if (and (not (equal ada-case-exception-substring '()))
+ (assoc-ignore-case word ada-case-exception-substring))
+ (setcar (assoc-ignore-case word ada-case-exception-substring) word)
+ (add-to-list 'ada-case-exception-substring (cons word t))
+ )
+
+ (ada-save-exceptions-to-file file-name)
+
+ (message (concat "Defining " word " as a casing exception"))))
+
+(defun ada-case-read-exceptions-from-file (file-name)
+ "Read the content of the casing exception file FILE-NAME."
+ (if (file-readable-p (expand-file-name file-name))
+ (let ((buffer (current-buffer)))
+ (find-file (expand-file-name file-name))
+ (set-syntax-table ada-mode-symbol-syntax-table)
+ (widen)
+ (goto-char (point-min))
+ (while (not (eobp))
+
+ ;; If the item is already in the list, even with an other casing,
+ ;; do not add it again. This way, the user can easily decide which
+ ;; priority should be applied to each casing exception
+ (let ((word (buffer-substring-no-properties
+ (point) (save-excursion (forward-word 1) (point)))))
+
+ ;; Handling a substring ?
+ (if (char-equal (string-to-char word) ?*)
+ (progn
+ (setq word (substring word 1))
+ (unless (assoc-ignore-case word ada-case-exception-substring)
+ (add-to-list 'ada-case-exception-substring (cons word t))))
+ (unless (assoc-ignore-case word ada-case-exception)
+ (add-to-list 'ada-case-exception (cons word t)))))
+
+ (forward-line 1))
+ (kill-buffer nil)
+ (set-buffer buffer)))
+ )
+
+(defun ada-case-read-exceptions ()
+ "Read all the casing exception files from `ada-case-exception-file'."
+ (interactive)
+
+ ;; Reinitialize the casing exception list
+ (setq ada-case-exception '()
+ ada-case-exception-substring '())
+
+ (cond ((stringp ada-case-exception-file)
+ (ada-case-read-exceptions-from-file ada-case-exception-file))
+
+ ((listp ada-case-exception-file)
+ (mapcar 'ada-case-read-exceptions-from-file
+ ada-case-exception-file))))
+
+(defun ada-adjust-case-substring ()
+ "Adjust case of substrings in the previous word."
+ (interactive)
+ (let ((substrings ada-case-exception-substring)
+ (max (point))
+ (case-fold-search t)
+ (underscore-syntax (char-syntax ?_))
+ re)
+
+ (save-excursion
+ (forward-word -1)
+
+ (unwind-protect
+ (progn
+ (modify-syntax-entry ?_ "." (syntax-table))
+
+ (while substrings
+ (setq re (concat "\\b" (regexp-quote (caar substrings)) "\\b"))
+
+ (save-excursion
+ (while (re-search-forward re max t)
+ (replace-match (caar substrings) t)))
+ (setq substrings (cdr substrings))
+ )
+ )
+ (modify-syntax-entry ?_ (make-string 1 underscore-syntax) (syntax-table)))
+ )))
+
+(defun ada-adjust-case-identifier ()
+ "Adjust case of the previous identifier.
+The auto-casing is done according to the value of `ada-case-identifier' and
+the exceptions defined in `ada-case-exception-file'."
+ (interactive)
+ (if (or (equal ada-case-exception '())
+ (equal (char-after) ?_))
+ (progn
+ (funcall ada-case-identifier -1)
+ (ada-adjust-case-substring))
+
+ (progn
+ (let ((end (point))
+ (start (save-excursion (skip-syntax-backward "w")
+ (point)))
+ match)
+ ;; If we have an exception, replace the word by the correct casing
+ (if (setq match (assoc-ignore-case (buffer-substring start end)
+ ada-case-exception))
+
+ (progn
+ (delete-region start end)
+ (insert (car match)))
+
+ ;; Else simply re-case the word
+ (funcall ada-case-identifier -1)
+ (ada-adjust-case-substring))))))
+
+(defun ada-after-keyword-p ()
+ "Returns t if cursor is after a keyword that is not an attribute."
+ (save-excursion
+ (forward-word -1)
+ (and (not (and (char-before)
+ (or (= (char-before) ?_)
+ (= (char-before) ?'))));; unless we have a _ or '
+ (looking-at (concat ada-keywords "[^_]")))))
+
+(defun ada-adjust-case (&optional force-identifier)
+ "Adjust the case of the word before the just typed character.
+If FORCE-IDENTIFIER is non-nil then also adjust keyword as identifier."
+ (if (not (bobp))
+ (progn
+ (forward-char -1)
+ (if (and (not (bobp))
+ ;; or if at the end of a character constant
+ (not (and (eq (following-char) ?')
+ (eq (char-before (1- (point))) ?')))
+ ;; or if the previous character was not part of a word
+ (eq (char-syntax (char-before)) ?w)
+ ;; if in a string or a comment
+ (not (ada-in-string-or-comment-p))
+ )
+ (if (save-excursion
+ (forward-word -1)
+ (or (= (point) (point-min))
+ (backward-char 1))
+ (= (following-char) ?'))
+ (funcall ada-case-attribute -1)
+ (if (and
+ (not force-identifier) ; (MH)
+ (ada-after-keyword-p))
+ (funcall ada-case-keyword -1)
+ (ada-adjust-case-identifier))))
+ (forward-char 1)
+ ))
+ )
+
+(defun ada-adjust-case-interactive (arg)
+ "Adjust the case of the previous word, and process the character just typed.
+ARG is the prefix the user entered with \C-u."
+ (interactive "P")
+
+ (if ada-auto-case
+ (let ((lastk last-command-char)
+ (previous-syntax-table (syntax-table)))
+
+ (unwind-protect
+ (progn
+ (set-syntax-table ada-mode-symbol-syntax-table)
+ (cond ((or (eq lastk ?\n)
+ (eq lastk ?\r))
+ ;; horrible kludge
+ (insert " ")
+ (ada-adjust-case)
+ ;; horrible dekludge
+ (delete-backward-char 1)
+ ;; some special keys and their bindings
+ (cond
+ ((eq lastk ?\n)
+ (funcall ada-lfd-binding))
+ ((eq lastk ?\r)
+ (funcall ada-ret-binding))))
+ ((eq lastk ?\C-i) (ada-tab))
+ ;; Else just insert the character
+ ((self-insert-command (prefix-numeric-value arg))))
+ ;; if there is a keyword in front of the underscore
+ ;; then it should be part of an identifier (MH)
+ (if (eq lastk ?_)
+ (ada-adjust-case t)
+ (ada-adjust-case))
+ )
+ ;; Restore the syntax table
+ (set-syntax-table previous-syntax-table))
+ )
+
+ ;; Else, no auto-casing
+ (cond
+ ((eq last-command-char ?\n)
+ (funcall ada-lfd-binding))
+ ((eq last-command-char ?\r)
+ (funcall ada-ret-binding))
+ (t
+ (self-insert-command (prefix-numeric-value arg))))
+ ))
+
+(defun ada-activate-keys-for-case ()
+ "Modifies the key bindings for all the keys that should readjust the casing."
+ (interactive)
+ ;; Save original key-bindings to allow swapping ret/lfd
+ ;; when casing is activated.
+ ;; The 'or ...' is there to be sure that the value will not
+ ;; be changed again when Ada mode is called more than once
+ (or ada-ret-binding (setq ada-ret-binding (key-binding "\C-M")))
+ (or ada-lfd-binding (setq ada-lfd-binding (key-binding "\C-j")))
+
+ ;; Call case modifying function after certain keys.
+ (mapcar (function (lambda(key) (define-key
+ ada-mode-map
+ (char-to-string key)
+ 'ada-adjust-case-interactive)))
+ '( ?` ?_ ?# ?% ?& ?* ?( ?) ?- ?= ?+
+ ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?/ ?\n 32 ?\r )))
+
+(defun ada-loose-case-word (&optional arg)
+ "Upcase first letter and letters following `_' in the following word.
+No other letter is modified.
+ARG is ignored, and is there for compatibility with `capitalize-word' only."
+ (interactive)
+ (save-excursion
+ (let ((end (save-excursion (skip-syntax-forward "w") (point)))
+ (first t))
+ (skip-syntax-backward "w")
+ (while (and (or first (search-forward "_" end t))
+ (< (point) end))
+ (and first
+ (setq first nil))
+ (insert-char (upcase (following-char)) 1)
+ (delete-char 1)))))
+
+(defun ada-no-auto-case (&optional arg)
+ "Does nothing.
+This function can be used for the auto-casing variables in the ada-mode, to
+adapt to unusal auto-casing schemes. Since it does nothing, you can for
+instance use it for `ada-case-identifier' if you don't want any special
+auto-casing for identifiers, whereas keywords have to be lower-cased.
+See also `ada-auto-case' to disable auto casing altogether."
+ )
+
+(defun ada-capitalize-word (&optional arg)
+ "Upcase first letter and letters following '_', lower case other letters.
+ARG is ignored, and is there for compatibility with `capitalize-word' only."
+ (interactive)
+ (let ((end (save-excursion (skip-syntax-forward "w") (point)))
+ (begin (save-excursion (skip-syntax-backward "w") (point))))
+ (modify-syntax-entry ?_ "_")
+ (capitalize-region begin end)
+ (modify-syntax-entry ?_ "w")))
+
+(defun ada-adjust-case-region (from to)
+ "Adjusts the case of all words in the region between FROM and TO.
+Attention: This function might take very long for big regions !"
+ (interactive "*r")
+ (let ((begin nil)
+ (end nil)
+ (keywordp nil)
+ (attribp nil)
+ (previous-syntax-table (syntax-table)))
+ (message "Adjusting case ...")
+ (unwind-protect
+ (save-excursion
+ (set-syntax-table ada-mode-symbol-syntax-table)
+ (goto-char to)
+ ;;
+ ;; loop: look for all identifiers, keywords, and attributes
+ ;;
+ (while (re-search-backward "\\<\\(\\sw+\\)\\>" from t)
+ (setq end (match-end 1))
+ (setq attribp
+ (and (> (point) from)
+ (save-excursion
+ (forward-char -1)
+ (setq attribp (looking-at "'.[^']")))))
+ (or
+ ;; do nothing if it is a string or comment
+ (ada-in-string-or-comment-p)
+ (progn
+ ;;
+ ;; get the identifier or keyword or attribute
+ ;;
+ (setq begin (point))
+ (setq keywordp (looking-at ada-keywords))
+ (goto-char end)
+ ;;
+ ;; casing according to user-option
+ ;;
+ (if attribp
+ (funcall ada-case-attribute -1)
+ (if keywordp
+ (funcall ada-case-keyword -1)
+ (ada-adjust-case-identifier)))
+ (goto-char begin))))
+ (message "Adjusting case ... Done"))
+ (set-syntax-table previous-syntax-table))))
+
+(defun ada-adjust-case-buffer ()
+ "Adjusts the case of all words in the whole buffer.
+ATTENTION: This function might take very long for big buffers !"
+ (interactive "*")
+ (ada-adjust-case-region (point-min) (point-max)))
+
+\f
+;;--------------------------------------------------------------
+;; Format Parameter Lists
+;; Some special algorithms are provided to indent the parameter lists in
+;; subprogram declarations. This is done in two steps:
+;; - First parses the parameter list. The returned list has the following
+;; format:
+;; ( (<Param_Name> in? out? access? <Type_Name> <Default_Expression>)
+;; ... )
+;; This is done in `ada-scan-paramlist'.
+;; - Delete and recreate the parameter list in function
+;; `ada-insert-paramlist'.
+;; Both steps are called from `ada-format-paramlist'.
+;; Note: Comments inside the parameter list are lost.
+;; The syntax has to be correct, or the reformating will fail.
+;;--------------------------------------------------------------
+
+(defun ada-format-paramlist ()
+ "Reformats the parameter list point is in."
+ (interactive)
+ (let ((begin nil)
+ (end nil)
+ (delend nil)
+ (paramlist nil)
+ (previous-syntax-table (syntax-table)))
+ (unwind-protect
+ (progn
+ (set-syntax-table ada-mode-symbol-syntax-table)
+
+ ;; check if really inside parameter list
+ (or (ada-in-paramlist-p)
+ (error "not in parameter list"))
+
+ ;; find start of current parameter-list
+ (ada-search-ignore-string-comment
+ (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil)
+ (down-list 1)
+ (backward-char 1)
+ (setq begin (point))
+
+ ;; find end of parameter-list
+ (forward-sexp 1)
+ (setq delend (point))
+ (delete-char -1)
+ (insert "\n")
+
+ ;; find end of last parameter-declaration
+ (forward-comment -1000)
+ (setq end (point))
+
+ ;; build a list of all elements of the parameter-list
+ (setq paramlist (ada-scan-paramlist (1+ begin) end))
+
+ ;; delete the original parameter-list
+ (delete-region begin delend)
+
+ ;; insert the new parameter-list
+ (goto-char begin)
+ (ada-insert-paramlist paramlist))
+
+ ;; restore syntax-table
+ (set-syntax-table previous-syntax-table)
+ )))
+
+(defun ada-scan-paramlist (begin end)
+ "Scan the parameter list found in between BEGIN and END.
+Returns the equivalent internal parameter list."
+ (let ((paramlist (list))
+ (param (list))
+ (notend t)
+ (apos nil)
+ (epos nil)
+ (semipos nil)
+ (match-cons nil))
+
+ (goto-char begin)
+
+ ;; loop until end of last parameter
+ (while notend
+
+ ;; find first character of parameter-declaration
+ (ada-goto-next-non-ws)
+ (setq apos (point))
+
+ ;; find last character of parameter-declaration
+ (if (setq match-cons
+ (ada-search-ignore-string-comment "[ \t\n]*;" nil end t))
+ (progn
+ (setq epos (car match-cons))
+ (setq semipos (cdr match-cons)))
+ (setq epos end))
+
+ ;; read name(s) of parameter(s)
+ (goto-char apos)
+ (looking-at "\\(\\(\\sw\\|[_, \t\n]\\)*\\(\\sw\\|_\\)\\)[ \t\n]*:[^=]")
+
+ (setq param (list (match-string 1)))
+ (ada-search-ignore-string-comment ":" nil epos t 'search-forward)
+
+ ;; look for 'in'
+ (setq apos (point))
+ (setq param
+ (append param
+ (list
+ (consp
+ (ada-search-ignore-string-comment
+ "in" nil epos t 'word-search-forward)))))
+
+ ;; look for 'out'
+ (goto-char apos)
+ (setq param
+ (append param
+ (list
+ (consp
+ (ada-search-ignore-string-comment
+ "out" nil epos t 'word-search-forward)))))
+
+ ;; look for 'access'
+ (goto-char apos)
+ (setq param
+ (append param
+ (list
+ (consp
+ (ada-search-ignore-string-comment
+ "access" nil epos t 'word-search-forward)))))
+
+ ;; skip 'in'/'out'/'access'
+ (goto-char apos)
+ (ada-goto-next-non-ws)
+ (while (looking-at "\\<\\(in\\|out\\|access\\)\\>")
+ (forward-word 1)
+ (ada-goto-next-non-ws))
+
+ ;; read type of parameter
+ ;; We accept spaces in the name, since some software like Rose
+ ;; generates something like: "A : B 'Class"
+ (looking-at "\\<\\(\\sw\\|[_.' \t]\\)+\\>")
+ (setq param
+ (append param
+ (list (match-string 0))))
+
+ ;; read default-expression, if there is one
+ (goto-char (setq apos (match-end 0)))
+ (setq param
+ (append param
+ (list
+ (if (setq match-cons
+ (ada-search-ignore-string-comment
+ ":=" nil epos t 'search-forward))
+ (buffer-substring (car match-cons) epos)
+ nil))))
+
+ ;; add this parameter-declaration to the list
+ (setq paramlist (append paramlist (list param)))
+
+ ;; check if it was the last parameter
+ (if (eq epos end)
+ (setq notend nil)
+ (goto-char semipos))
+ )
+ (reverse paramlist)))
+
+(defun ada-insert-paramlist (paramlist)
+ "Inserts a formatted PARAMLIST in the buffer."
+ (let ((i (length paramlist))
+ (parlen 0)
+ (typlen 0)
+ (inp nil)
+ (outp nil)
+ (accessp nil)
+ (column nil)
+ (firstcol nil))
+
+ ;; loop until last parameter
+ (while (not (zerop i))
+ (setq i (1- i))
+
+ ;; get max length of parameter-name
+ (setq parlen (max parlen (length (nth 0 (nth i paramlist)))))
+
+ ;; get max length of type-name
+ (setq typlen (max typlen (length (nth 4 (nth i paramlist)))))
+
+ ;; is there any 'in' ?
+ (setq inp (or inp (nth 1 (nth i paramlist))))
+
+ ;; is there any 'out' ?
+ (setq outp (or outp (nth 2 (nth i paramlist))))
+
+ ;; is there any 'access' ?
+ (setq accessp (or accessp (nth 3 (nth i paramlist))))
+ )
+
+ ;; does paramlist already start on a separate line ?
+ (if (save-excursion
+ (re-search-backward "^.\\|[^ \t]" nil t)
+ (looking-at "^."))
+ ;; yes => re-indent it
+ (progn
+ (ada-indent-current)
+ (save-excursion
+ (if (looking-at "\\(is\\|return\\)")
+ (replace-match " \\1"))))
+
+ ;; no => insert it where we are after removing any whitespace
+ (fixup-whitespace)
+ (save-excursion
+ (cond
+ ((looking-at "[ \t]*\\(\n\\|;\\)")
+ (replace-match "\\1"))
+ ((looking-at "[ \t]*\\(is\\|return\\)")
+ (replace-match " \\1"))))
+ (insert " "))
+
+ (insert "(")
+ (ada-indent-current)
+
+ (setq firstcol (current-column))
+ (setq i (length paramlist))
+
+ ;; loop until last parameter
+ (while (not (zerop i))
+ (setq i (1- i))
+ (setq column firstcol)
+
+ ;; insert parameter-name, space and colon
+ (insert (nth 0 (nth i paramlist)))
+ (indent-to (+ column parlen 1))
+ (insert ": ")
+ (setq column (current-column))
+
+ ;; insert 'in' or space
+ (if (nth 1 (nth i paramlist))
+ (insert "in ")
+ (if (and
+ (or inp
+ accessp)
+ (not (nth 3 (nth i paramlist))))
+ (insert " ")))
+
+ ;; insert 'out' or space
+ (if (nth 2 (nth i paramlist))
+ (insert "out ")
+ (if (and
+ (or outp
+ accessp)
+ (not (nth 3 (nth i paramlist))))
+ (insert " ")))
+
+ ;; insert 'access'
+ (if (nth 3 (nth i paramlist))
+ (insert "access "))
+
+ (setq column (current-column))
+
+ ;; insert type-name and, if necessary, space and default-expression
+ (insert (nth 4 (nth i paramlist)))
+ (if (nth 5 (nth i paramlist))
+ (progn
+ (indent-to (+ column typlen 1))
+ (insert (nth 5 (nth i paramlist)))))
+
+ ;; check if it was the last parameter
+ (if (zerop i)
+ (insert ")")
+ ;; no => insert ';' and newline and indent
+ (insert ";")
+ (newline)
+ (indent-to firstcol))
+ )
+
+ ;; if anything follows, except semicolon, newline, is or return
+ ;; put it in a new line and indent it
+ (unless (looking-at "[ \t]*\\(;\\|\n\\|is\\|return\\)")
+ (ada-indent-newline-indent))
+ ))
+
+
+\f
+;;;----------------------------------------------------------------
+;; Indentation Engine
+;; All indentations are indicated as a two-element string:
+;; - position of reference in the buffer
+;; - offset to indent from this position (can also be a symbol or a list
+;; that are evaluated)
+;; Thus the total indentation for a line is the column number of the reference
+;; position plus whatever value the evaluation of the second element provides.
+;; This mechanism is used so that the ada-mode can "explain" how the
+;; indentation was calculated, by showing which variables were used.
+;;
+;; The indentation itself is done in only one pass: first we try to guess in
+;; what context we are by looking at the following keyword or punctuation
+;; sign. If nothing remarkable is found, just try to guess the indentation
+;; based on previous lines.
+;;
+;; The relevant functions for indentation are:
+;; - `ada-indent-region': Re-indent a region of text
+;; - `ada-justified-indent-current': Re-indent the current line and shows the
+;; calculation that were done
+;; - `ada-indent-current': Re-indent the current line
+;; - `ada-get-current-indent': Calculate the indentation for the current line,
+;; based on the context (see above).
+;; - `ada-get-indent-*': Calculate the indentation in a specific context.
+;; For efficiency, these functions do not check they are in the correct
+;; context.
+;;;----------------------------------------------------------------
+
+(defun ada-indent-region (beg end)
+ "Indent the region between BEG end END."
+ (interactive "*r")
+ (goto-char beg)
+ (let ((block-done 0)
+ (lines-remaining (count-lines beg end))
+ (msg (format "%%4d out of %4d lines remaining ..."
+ (count-lines beg end)))
+ (endmark (copy-marker end)))
+ ;; catch errors while indenting
+ (while (< (point) endmark)
+ (if (> block-done 39)
+ (progn
+ (setq lines-remaining (- lines-remaining block-done)
+ block-done 0)
+ (message msg lines-remaining)))
+ (if (= (char-after) ?\n) nil
+ (ada-indent-current))
+ (forward-line 1)
+ (setq block-done (1+ block-done)))
+ (message "indenting ... done")))
+
+(defun ada-indent-newline-indent ()
+ "Indents the current line, inserts a newline and then indents the new line."
+ (interactive "*")
+ (ada-indent-current)
+ (newline)
+ (ada-indent-current))
+
+(defun ada-indent-newline-indent-conditional ()
+ "Insert a newline and indent it.
+The original line is indented first if `ada-indent-after-return' is non-nil.
+This function is intended to be bound to the \C-m and \C-j keys."
+ (interactive "*")
+ (if ada-indent-after-return (ada-indent-current))
+ (newline)
+ (ada-indent-current))
+
+(defun ada-justified-indent-current ()
+ "Indent the current line and explains how the calculation was done."
+ (interactive)
+
+ (let ((cur-indent (ada-indent-current)))
+
+ (let ((line (save-excursion
+ (goto-char (car cur-indent))
+ (count-lines 1 (point)))))
+
+ (if (equal (cdr cur-indent) '(0))
+ (message (concat "same indentation as line " (number-to-string line)))
+ (message (mapconcat (lambda(x)
+ (cond
+ ((symbolp x)
+ (symbol-name x))
+ ((numberp x)
+ (number-to-string x))
+ ((listp x)
+ (concat "- " (symbol-name (cadr x))))
+ ))
+ (cdr cur-indent)
+ " + "))))
+ (save-excursion
+ (goto-char (car cur-indent))
+ (sit-for 1))))
+
+(defun ada-batch-reformat ()
+ "Re-indent and re-case all the files found on the command line.
+This function should be used from the Unix/Windows command line, with a
+command like:
+ emacs -batch -l ada-mode -f ada-batch-reformat file1 file2 ..."
+
+ (while command-line-args-left
+ (let ((source (car command-line-args-left)))
+ (message (concat "formating " source))
+ (find-file source)
+ (ada-indent-region (point-min) (point-max))
+ (ada-adjust-case-buffer)
+ (write-file source))
+ (setq command-line-args-left (cdr command-line-args-left)))
+ (message "Done")
+ (kill-emacs 0))
+
+(defsubst ada-goto-previous-word ()
+ "Moves point to the beginning of the previous word of Ada code.
+Returns the new position of point or nil if not found."
+ (ada-goto-next-word t))
+
+(defun ada-indent-current ()
+ "Indent current line as Ada code.
+Returns the calculation that was done, including the reference point and the
+offset."
+ (interactive)
+ (let ((previous-syntax-table (syntax-table))
+ (orgpoint (point-marker))
+ cur-indent tmp-indent
+ prev-indent)
+
+ (unwind-protect
+ (progn
+ (set-syntax-table ada-mode-symbol-syntax-table)
+
+ ;; This need to be done here so that the advice is not always
+ ;; activated (this might interact badly with other modes)
+ (if (featurep 'xemacs)
+ (ad-activate 'parse-partial-sexp t))
+
+ (save-excursion
+ (setq cur-indent
+
+ ;; Not First line in the buffer ?
+ (if (save-excursion (zerop (forward-line -1)))
+ (progn
+ (back-to-indentation)
+ (ada-get-current-indent))
+
+ ;; first line in the buffer
+ (list (point-min) 0))))
+
+ ;; Evaluate the list to get the column to indent to
+ ;; prev-indent contains the column to indent to
+ (if cur-indent
+ (setq prev-indent (save-excursion (goto-char (car cur-indent))
+ (current-column))
+ tmp-indent (cdr cur-indent))
+ (setq prev-indent 0 tmp-indent '()))
+
+ (while (not (null tmp-indent))
+ (cond
+ ((numberp (car tmp-indent))
+ (setq prev-indent (+ prev-indent (car tmp-indent))))
+ (t
+ (setq prev-indent (+ prev-indent (eval (car tmp-indent)))))
+ )
+ (setq tmp-indent (cdr tmp-indent)))
+
+ ;; only re-indent if indentation is different then the current
+ (if (= (save-excursion (back-to-indentation) (current-column)) prev-indent)
+ nil
+ (beginning-of-line)
+ (delete-horizontal-space)
+ (indent-to prev-indent))
+ ;;
+ ;; restore position of point
+ ;;
+ (goto-char orgpoint)
+ (if (< (current-column) (current-indentation))
+ (back-to-indentation)))
+
+ ;; restore syntax-table
+ (set-syntax-table previous-syntax-table)
+ (if (featurep 'xemacs)
+ (ad-deactivate 'parse-partial-sexp))
+ )
+
+ cur-indent
+ ))
+
+(defun ada-get-current-indent ()
+ "Return the indentation to use for the current line."
+ (let (column
+ pos
+ match-cons
+ result
+ (orgpoint (save-excursion
+ (beginning-of-line)
+ (forward-comment -10000)
+ (forward-line 1)
+ (point))))
+
+ (setq result
+ (cond
+
+ ;;-----------------------------
+ ;; in open parenthesis, but not in parameter-list
+ ;;-----------------------------
+
+ ((and ada-indent-to-open-paren
+ (not (ada-in-paramlist-p))
+ (setq column (ada-in-open-paren-p)))
+
+ ;; check if we have something like this (Table_Component_Type =>
+ ;; Source_File_Record)
+ (save-excursion
+
+ ;; Align the closing parenthesis on the opening one
+ (if (= (following-char) ?\))
+ (save-excursion
+ (goto-char column)
+ (skip-chars-backward " \t")
+ (list (1- (point)) 0))
+
+ (if (and (skip-chars-backward " \t")
+ (= (char-before) ?\n)
+ (not (forward-comment -10000))
+ (= (char-before) ?>))
+ ;; ??? Could use a different variable
+ (list column 'ada-broken-indent)
+
+ ;; We want all continuation lines to be indented the same
+ ;; (ada-broken-line from the opening parenthesis. However, in
+ ;; parameter list, each new parameter should be indented at the
+ ;; column as the opening parenthesis.
+
+ ;; A special case to handle nested boolean expressions, as in
+ ;; ((B
+ ;; and then C) -- indented by ada-broken-indent
+ ;; or else D) -- indenting this line.
+ ;; ??? This is really a hack, we should have a proper way to go to
+ ;; ??? the beginning of the statement
+
+ (if (= (char-before) ?\))
+ (backward-sexp))
+
+ (if (memq (char-before) '(?, ?\; ?\( ?\)))
+ (list column 0)
+ (list column 'ada-continuation-indent)
+ )))))
+
+ ;;---------------------------
+ ;; at end of buffer
+ ;;---------------------------
+
+ ((not (char-after))
+ (ada-indent-on-previous-lines nil orgpoint orgpoint))
+
+ ;;---------------------------
+ ;; starting with e
+ ;;---------------------------
+
+ ((= (downcase (char-after)) ?e)
+ (cond
+
+ ;; ------- end ------
+
+ ((looking-at "end\\>")
+ (let ((label 0)
+ limit)
+ (save-excursion
+ (ada-goto-matching-start 1)
+
+ ;;
+ ;; found 'loop' => skip back to 'while' or 'for'
+ ;; if 'loop' is not on a separate line
+ ;; Stop the search for 'while' and 'for' when a ';' is encountered.
+ ;;
+ (if (save-excursion
+ (beginning-of-line)
+ (looking-at ".+\\<loop\\>"))
+ (progn
+ (save-excursion
+ (setq limit (car (ada-search-ignore-string-comment ";" t))))
+ (if (save-excursion
+ (and
+ (setq match-cons
+ (ada-search-ignore-string-comment ada-loop-start-re t limit))
+ (not (looking-at "\\<loop\\>"))))
+ (progn
+ (goto-char (car match-cons))
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at ada-named-block-re)
+ (setq label (- ada-label-indent))))))))
+
+ ;; found 'record' =>
+ ;; if the keyword is found at the beginning of a line (or just
+ ;; after limited, we indent on it, otherwise we indent on the
+ ;; beginning of the type declaration)
+ ;; type A is (B : Integer;
+ ;; C : Integer) is record
+ ;; end record; -- This is badly indented otherwise
+ (if (looking-at "record")
+ (if (save-excursion
+ (beginning-of-line)
+ (looking-at "^[ \t]*\\(record\\|limited record\\)"))
+ (list (save-excursion (back-to-indentation) (point)) 0)
+ (list (save-excursion
+ (car (ada-search-ignore-string-comment "\\<type\\>" t)))
+ 0))
+
+ ;; Else keep the same indentation as the beginning statement
+ (list (+ (save-excursion (back-to-indentation) (point)) label) 0)))))
+
+ ;; ------ exception ----
+
+ ((looking-at "exception\\>")
+ (save-excursion
+ (ada-goto-matching-start 1)
+ (list (save-excursion (back-to-indentation) (point)) 0)))
+
+ ;; else
+
+ ((looking-at "else\\>")
+ (if (save-excursion (ada-goto-previous-word)
+ (looking-at "\\<or\\>"))
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)
+ (save-excursion
+ (ada-goto-matching-start 1 nil t)
+ (list (progn (back-to-indentation) (point)) 0))))
+
+ ;; elsif
+
+ ((looking-at "elsif\\>")
+ (save-excursion
+ (ada-goto-matching-start 1 nil t)
+ (list (progn (back-to-indentation) (point)) 0)))
+
+ ))
+
+ ;;---------------------------
+ ;; starting with w (when)
+ ;;---------------------------
+
+ ((and (= (downcase (char-after)) ?w)
+ (looking-at "when\\>"))
+ (save-excursion
+ (ada-goto-matching-start 1)
+ (list (save-excursion (back-to-indentation) (point))
+ 'ada-when-indent)))
+
+ ;;---------------------------
+ ;; starting with t (then)
+ ;;---------------------------
+
+ ((and (= (downcase (char-after)) ?t)
+ (looking-at "then\\>"))
+ (if (save-excursion (ada-goto-previous-word)
+ (looking-at "and\\>"))
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)
+ (save-excursion
+ ;; Select has been added for the statement: "select ... then abort"
+ (ada-search-ignore-string-comment
+ "\\<\\(elsif\\|if\\|select\\)\\>" t nil)
+ (list (progn (back-to-indentation) (point))
+ 'ada-stmt-end-indent))))
+
+ ;;---------------------------
+ ;; starting with l (loop)
+ ;;---------------------------
+
+ ((and (= (downcase (char-after)) ?l)
+ (looking-at "loop\\>"))
+ (setq pos (point))
+ (save-excursion
+ (goto-char (match-end 0))
+ (ada-goto-stmt-start)
+ (if (looking-at "\\<\\(loop\\|if\\)\\>")
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)
+ (unless (looking-at ada-loop-start-re)
+ (ada-search-ignore-string-comment ada-loop-start-re
+ nil pos))
+ (if (looking-at "\\<loop\\>")
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)
+ (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent)))))
+
+ ;;----------------------------
+ ;; starting with l (limited) or r (record)
+ ;;----------------------------
+
+ ((or (and (= (downcase (char-after)) ?l)
+ (looking-at "limited\\>"))
+ (and (= (downcase (char-after)) ?r)
+ (looking-at "record\\>")))
+
+ (save-excursion
+ (ada-search-ignore-string-comment
+ "\\<\\(type\\|use\\)\\>" t nil)
+ (if (looking-at "\\<use\\>")
+ (ada-search-ignore-string-comment "for" t nil nil
+ 'word-search-backward))
+ (list (progn (back-to-indentation) (point))
+ 'ada-indent-record-rel-type)))
+
+ ;;---------------------------
+ ;; starting with b (begin)
+ ;;---------------------------
+
+ ((and (= (downcase (char-after)) ?b)
+ (looking-at "begin\\>"))
+ (save-excursion
+ (if (ada-goto-matching-decl-start t)
+ (list (progn (back-to-indentation) (point)) 0)
+ (ada-indent-on-previous-lines nil orgpoint orgpoint))))
+
+ ;;---------------------------
+ ;; starting with i (is)
+ ;;---------------------------
+
+ ((and (= (downcase (char-after)) ?i)
+ (looking-at "is\\>"))
+
+ (if (and ada-indent-is-separate
+ (save-excursion
+ (goto-char (match-end 0))
+ (ada-goto-next-non-ws (save-excursion (end-of-line)
+ (point)))
+ (looking-at "\\<abstract\\>\\|\\<separate\\>")))
+ (save-excursion
+ (ada-goto-stmt-start)
+ (list (progn (back-to-indentation) (point)) 'ada-indent))
+ (save-excursion
+ (ada-goto-stmt-start)
+ (if (looking-at "\\<package\\|procedure\\|function\\>")
+ (list (progn (back-to-indentation) (point)) 0)
+ (list (progn (back-to-indentation) (point)) 'ada-indent)))))
+
+ ;;---------------------------
+ ;; starting with r (return, renames)
+ ;;---------------------------
+
+ ((and (= (downcase (char-after)) ?r)
+ (looking-at "re\\(turn\\|names\\)\\>"))
+
+ (save-excursion
+ (let ((var 'ada-indent-return))
+ ;; If looking at a renames, skip the 'return' statement too
+ (if (looking-at "renames")
+ (let (pos)
+ (save-excursion
+ (set 'pos (ada-search-ignore-string-comment ";\\|return\\>" t)))
+ (if (and pos
+ (= (downcase (char-after (car pos))) ?r))
+ (goto-char (car pos)))
+ (set 'var 'ada-indent-renames)))
+
+ (forward-comment -1000)
+ (if (= (char-before) ?\))
+ (forward-sexp -1)
+ (forward-word -1))
+
+ ;; If there is a parameter list, and we have a function declaration
+ ;; or a access to subprogram declaration
+ (let ((num-back 1))
+ (if (and (= (following-char) ?\()
+ (save-excursion
+ (or (progn
+ (backward-word 1)
+ (looking-at "\\(function\\|procedure\\)\\>"))
+ (progn
+ (backward-word 1)
+ (set 'num-back 2)
+ (looking-at "\\(function\\|procedure\\)\\>")))))
+
+ ;; The indentation depends of the value of ada-indent-return
+ (if (<= (eval var) 0)
+ (list (point) (list '- var))
+ (list (progn (backward-word num-back) (point))
+ var))
+
+ ;; Else there is no parameter list, but we have a function
+ ;; Only do something special if the user want to indent
+ ;; relative to the "function" keyword
+ (if (and (> (eval var) 0)
+ (save-excursion (forward-word -1)
+ (looking-at "function\\>")))
+ (list (progn (forward-word -1) (point)) var)
+
+ ;; Else...
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)))))))
+
+ ;;--------------------------------
+ ;; starting with 'o' or 'p'
+ ;; 'or' as statement-start
+ ;; 'private' as statement-start
+ ;;--------------------------------
+
+ ((and (or (= (downcase (char-after)) ?o)
+ (= (downcase (char-after)) ?p))
+ (or (ada-looking-at-semi-or)
+ (ada-looking-at-semi-private)))
+ (save-excursion
+ ;; ??? Wasn't this done already in ada-looking-at-semi-or ?
+ (ada-goto-matching-start 1)
+ (list (progn (back-to-indentation) (point)) 0)))
+
+ ;;--------------------------------
+ ;; starting with 'd' (do)
+ ;;--------------------------------
+
+ ((and (= (downcase (char-after)) ?d)
+ (looking-at "do\\>"))
+ (save-excursion
+ (ada-goto-stmt-start)
+ (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent)))
+
+ ;;--------------------------------
+ ;; starting with '-' (comment)
+ ;;--------------------------------
+
+ ((= (char-after) ?-)
+ (if ada-indent-comment-as-code
+
+ ;; Indent comments on previous line comments if required
+ ;; We must use a search-forward (even if the code is more complex),
+ ;; since we want to find the beginning of the comment.
+ (let (pos)
+
+ (if (and ada-indent-align-comments
+ (save-excursion
+ (forward-line -1)
+ (beginning-of-line)
+ (while (and (not pos)
+ (search-forward "--"
+ (save-excursion
+ (end-of-line) (point))
+ t))
+ (unless (ada-in-string-p)
+ (setq pos (point))))
+ pos))
+ (list (- pos 2) 0)
+
+ ;; Else always on previous line
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)))
+
+ ;; Else same indentation as the previous line
+ (list (save-excursion (back-to-indentation) (point)) 0)))
+
+ ;;--------------------------------
+ ;; starting with '#' (preprocessor line)
+ ;;--------------------------------
+
+ ((and (= (char-after) ?#)
+ (equal ada-which-compiler 'gnat)
+ (looking-at "#[ \t]*\\(if\\|els\\(e\\|if\\)\\|end[ \t]*if\\)"))
+ (list (save-excursion (beginning-of-line) (point)) 0))
+
+ ;;--------------------------------
+ ;; starting with ')' (end of a parameter list)
+ ;;--------------------------------
+
+ ((and (not (eobp)) (= (char-after) ?\)))
+ (save-excursion
+ (forward-char 1)
+ (backward-sexp 1)
+ (list (point) 0)))
+
+ ;;---------------------------------
+ ;; new/abstract/separate
+ ;;---------------------------------
+
+ ((looking-at "\\(new\\|abstract\\|separate\\)\\>")
+ (ada-indent-on-previous-lines nil orgpoint orgpoint))
+
+ ;;---------------------------------
+ ;; package/function/procedure
+ ;;---------------------------------
+
+ ((and (or (= (downcase (char-after)) ?p) (= (downcase (char-after)) ?f))
+ (looking-at "\\<\\(package\\|function\\|procedure\\)\\>"))
+ (save-excursion
+ ;; Go up until we find either a generic section, or the end of the
+ ;; previous subprogram/package
+ (let (found)
+ (while (and (not found)
+ (ada-search-ignore-string-comment
+ "\\<\\(generic\\|end\\|begin\\|package\\|procedure\\|function\\)\\>" t))
+
+ ;; avoid "with procedure"... in generic parts
+ (save-excursion
+ (forward-word -1)
+ (setq found (not (looking-at "with"))))))
+
+ (if (looking-at "generic")
+ (list (progn (back-to-indentation) (point)) 0)
+ (ada-indent-on-previous-lines nil orgpoint orgpoint))))
+
+ ;;---------------------------------
+ ;; label
+ ;;---------------------------------
+
+ ((looking-at "\\(\\sw\\|_\\)+[ \t\n]*:[^=]")
+ (if (ada-in-decl-p)
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)
+ (append (ada-indent-on-previous-lines nil orgpoint orgpoint)
+ '(ada-label-indent))))
+
+ ))
+
+ ;;---------------------------------
+ ;; Other syntaxes
+ ;;---------------------------------
+ (or result (ada-indent-on-previous-lines nil orgpoint orgpoint))))
+
+(defun ada-indent-on-previous-lines (&optional nomove orgpoint initial-pos)
+ "Calculate the indentation for the new line after ORGPOINT.
+The result list is based on the previous lines in the buffer.
+If NOMOVE is nil, moves point to the beginning of the current statement.
+if INITIAL-POS is non-nil, moves point to INITIAL-POS before calculation."
+ (if initial-pos
+ (goto-char initial-pos))
+ (let ((oldpoint (point)))
+
+ ;; Is inside a parameter-list ?
+ (if (ada-in-paramlist-p)
+ (ada-get-indent-paramlist)
+
+ ;; move to beginning of current statement
+ (unless nomove
+ (ada-goto-stmt-start))
+
+ ;; no beginning found => don't change indentation
+ (if (and (eq oldpoint (point))
+ (not nomove))
+ (ada-get-indent-nochange)
+
+ (cond
+ ;;
+ ((and
+ ada-indent-to-open-paren
+ (ada-in-open-paren-p))
+ (ada-get-indent-open-paren))
+ ;;
+ ((looking-at "end\\>")
+ (ada-get-indent-end orgpoint))
+ ;;
+ ((looking-at ada-loop-start-re)
+ (ada-get-indent-loop orgpoint))
+ ;;
+ ((looking-at ada-subprog-start-re)
+ (ada-get-indent-subprog orgpoint))
+ ;;
+ ((looking-at ada-block-start-re)
+ (ada-get-indent-block-start orgpoint))
+ ;;
+ ((looking-at "\\(sub\\)?type\\>")
+ (ada-get-indent-type orgpoint))
+ ;;
+ ;; "then" has to be included in the case of "select...then abort"
+ ;; statements, since (goto-stmt-start) at the beginning of
+ ;; the current function would leave the cursor on that position
+ ((looking-at "\\(\\(els\\)?if\\>\\)\\|then abort\\\>")
+ (ada-get-indent-if orgpoint))
+ ;;
+ ((looking-at "case\\>")
+ (ada-get-indent-case orgpoint))
+ ;;
+ ((looking-at "when\\>")
+ (ada-get-indent-when orgpoint))
+ ;;
+ ((looking-at "\\(\\sw\\|_\\)+[ \t\n]*:[^=]")
+ (ada-get-indent-label orgpoint))
+ ;;
+ ((looking-at "separate\\>")
+ (ada-get-indent-nochange))
+
+ ;; A label
+ ((looking-at "<<")
+ (list (+ (save-excursion (back-to-indentation) (point))
+ (- ada-label-indent))))
+
+ ;;
+ ((looking-at "with\\>\\|use\\>")
+ ;; Are we still in that statement, or are we in fact looking at
+ ;; the previous one ?
+ (if (save-excursion (search-forward ";" oldpoint t))
+ (list (progn (back-to-indentation) (point)) 0)
+ (list (point) (if (looking-at "with")
+ 'ada-with-indent
+ 'ada-use-indent))))
+ ;;
+ (t
+ (ada-get-indent-noindent orgpoint)))))
+ ))
+
+(defun ada-get-indent-open-paren ()
+ "Calculates the indentation when point is behind an unclosed parenthesis."
+ (list (ada-in-open-paren-p) 0))
+
+(defun ada-get-indent-nochange ()
+ "Return the current indentation of the previous line."
+ (save-excursion
+ (forward-line -1)
+ (back-to-indentation)
+ (list (point) 0)))
+
+(defun ada-get-indent-paramlist ()
+ "Calculates the indentation when point is inside a parameter list."
+ (save-excursion
+ (ada-search-ignore-string-comment "[^ \t\n]" t nil t)
+ (cond
+ ;; in front of the first parameter
+ ((= (char-after) ?\()
+ (goto-char (match-end 0))
+ (list (point) 0))
+
+ ;; in front of another parameter
+ ((= (char-after) ?\;)
+ (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t)))
+ (ada-goto-next-non-ws)
+ (list (point) 0))
+
+ ;; After an affectation (default parameter value in subprogram
+ ;; declaration)
+ ((and (= (following-char) ?=) (= (preceding-char) ?:))
+ (back-to-indentation)
+ (list (point) 'ada-broken-indent))
+
+ ;; inside a parameter declaration
+ (t
+ (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t)))
+ (ada-goto-next-non-ws)
+ (list (point) 0)))))
+
+(defun ada-get-indent-end (orgpoint)
+ "Calculates the indentation when point is just before an end_statement.
+ORGPOINT is the limit position used in the calculation."
+ (let ((defun-name nil)
+ (indent nil))
+
+ ;; is the line already terminated by ';' ?
+ (if (save-excursion
+ (ada-search-ignore-string-comment ";" nil orgpoint nil
+ 'search-forward))
+
+ ;; yes, look what's following 'end'
+ (progn
+ (forward-word 1)
+ (ada-goto-next-non-ws)
+ (cond
+ ((looking-at "\\<\\(loop\\|select\\|if\\|case\\)\\>")
+ (save-excursion (ada-check-matching-start (match-string 0)))
+ (list (save-excursion (back-to-indentation) (point)) 0))
+
+ ;;
+ ;; loop/select/if/case/record/select
+ ;;
+ ((looking-at "\\<record\\>")
+ (save-excursion
+ (ada-check-matching-start (match-string 0))
+ ;; we are now looking at the matching "record" statement
+ (forward-word 1)
+ (ada-goto-stmt-start)
+ ;; now on the matching type declaration, or use clause
+ (unless (looking-at "\\(for\\|type\\)\\>")
+ (ada-search-ignore-string-comment "\\<type\\>" t))
+ (list (progn (back-to-indentation) (point)) 0)))
+ ;;
+ ;; a named block end
+ ;;
+ ((looking-at ada-ident-re)
+ (setq defun-name (match-string 0))
+ (save-excursion
+ (ada-goto-matching-start 0)
+ (ada-check-defun-name defun-name))
+ (list (progn (back-to-indentation) (point)) 0))
+ ;;
+ ;; a block-end without name
+ ;;
+ ((= (char-after) ?\;)
+ (save-excursion
+ (ada-goto-matching-start 0)
+ (if (looking-at "\\<begin\\>")
+ (progn
+ (setq indent (list (point) 0))
+ (if (ada-goto-matching-decl-start t)
+ (list (progn (back-to-indentation) (point)) 0)
+ indent))
+ (list (progn (back-to-indentation) (point)) 0)
+ )))
+ ;;
+ ;; anything else - should maybe signal an error ?
+ ;;
+ (t
+ (list (save-excursion (back-to-indentation) (point))
+ 'ada-broken-indent))))
+
+ (list (save-excursion (back-to-indentation) (point))
+ 'ada-broken-indent))))
+
+(defun ada-get-indent-case (orgpoint)
+ "Calculates the indentation when point is just before a case statement.
+ORGPOINT is the limit position used in the calculation."
+ (let ((match-cons nil)
+ (opos (point)))
+ (cond
+ ;;
+ ;; case..is..when..=>
+ ;;
+ ((save-excursion
+ (setq match-cons (and
+ ;; the `=>' must be after the keyword `is'.
+ (ada-search-ignore-string-comment
+ "is" nil orgpoint nil 'word-search-forward)
+ (ada-search-ignore-string-comment
+ "[ \t\n]+=>" nil orgpoint))))
+ (save-excursion
+ (goto-char (car match-cons))
+ (unless (ada-search-ignore-string-comment "when" t opos)
+ (error "missing 'when' between 'case' and '=>'"))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-indent)))
+ ;;
+ ;; case..is..when
+ ;;
+ ((save-excursion
+ (setq match-cons (ada-search-ignore-string-comment
+ "when" nil orgpoint nil 'word-search-forward)))
+ (goto-char (cdr match-cons))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent))
+ ;;
+ ;; case..is
+ ;;
+ ((save-excursion
+ (setq match-cons (ada-search-ignore-string-comment
+ "is" nil orgpoint nil 'word-search-forward)))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-when-indent))
+ ;;
+ ;; incomplete case
+ ;;
+ (t
+ (list (save-excursion (back-to-indentation) (point))
+ 'ada-broken-indent)))))
+
+(defun ada-get-indent-when (orgpoint)
+ "Calculates the indentation when point is just before a when statement.
+ORGPOINT is the limit position used in the calculation."
+ (let ((cur-indent (save-excursion (back-to-indentation) (point))))
+ (if (ada-search-ignore-string-comment "[ \t\n]*=>" nil orgpoint)
+ (list cur-indent 'ada-indent)
+ (list cur-indent 'ada-broken-indent))))
+
+(defun ada-get-indent-if (orgpoint)
+ "Calculates the indentation when point is just before an if statement.
+ORGPOINT is the limit position used in the calculation."
+ (let ((cur-indent (save-excursion (back-to-indentation) (point)))
+ (match-cons nil))
+ ;;
+ ;; Move to the correct then (ignore all "and then")
+ ;;
+ (while (and (setq match-cons (ada-search-ignore-string-comment
+ "\\<\\(then\\|and[ \t]*then\\)\\>"
+ nil orgpoint))
+ (= (downcase (char-after (car match-cons))) ?a)))
+ ;; If "then" was found (we are looking at it)
+ (if match-cons
+ (progn
+ ;;
+ ;; 'then' first in separate line ?
+ ;; => indent according to 'then',
+ ;; => else indent according to 'if'
+ ;;
+ (if (save-excursion
+ (back-to-indentation)
+ (looking-at "\\<then\\>"))
+ (setq cur-indent (save-excursion (back-to-indentation) (point))))
+ ;; skip 'then'
+ (forward-word 1)
+ (list cur-indent 'ada-indent))
+
+ (list cur-indent 'ada-broken-indent))))
+
+(defun ada-get-indent-block-start (orgpoint)
+ "Calculates the indentation when point is at the start of a block.
+ORGPOINT is the limit position used in the calculation."
+ (let ((pos nil))
+ (cond
+ ((save-excursion
+ (forward-word 1)
+ (setq pos (ada-goto-next-non-ws orgpoint)))
+ (goto-char pos)
+ (save-excursion
+ (ada-indent-on-previous-lines t orgpoint)))
+
+ ;; Special case for record types, for instance for:
+ ;; type A is (B : Integer;
+ ;; C : Integer) is record
+ ;; null; -- This is badly indented otherwise
+ ((looking-at "record")
+
+ ;; If record is at the beginning of the line, indent from there
+ (if (save-excursion
+ (beginning-of-line)
+ (looking-at "^[ \t]*\\(record\\|limited record\\)"))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-indent)
+
+ ;; else indent relative to the type command
+ (list (save-excursion
+ (car (ada-search-ignore-string-comment "\\<type\\>" t)))
+ 'ada-indent)))
+
+ ;; nothing follows the block-start
+ (t
+ (list (save-excursion (back-to-indentation) (point)) 'ada-indent)))))
+
+(defun ada-get-indent-subprog (orgpoint)
+ "Calculates the indentation when point is just before a subprogram.
+ORGPOINT is the limit position used in the calculation."
+ (let ((match-cons nil)
+ (cur-indent (save-excursion (back-to-indentation) (point)))
+ (foundis nil))
+ ;;
+ ;; is there an 'is' in front of point ?
+ ;;
+ (if (save-excursion
+ (setq match-cons
+ (ada-search-ignore-string-comment
+ "\\<\\(is\\|do\\)\\>" nil orgpoint)))
+ ;;
+ ;; yes, then skip to its end
+ ;;
+ (progn
+ (setq foundis t)
+ (goto-char (cdr match-cons)))
+ ;;
+ ;; no, then goto next non-ws, if there is one in front of point
+ ;;
+ (progn
+ (unless (ada-goto-next-non-ws orgpoint)
+ (goto-char orgpoint))))
+
+ (cond
+ ;;
+ ;; nothing follows 'is'
+ ;;
+ ((and
+ foundis
+ (save-excursion
+ (not (ada-search-ignore-string-comment
+ "[^ \t\n]" nil orgpoint t))))
+ (list cur-indent 'ada-indent))
+ ;;
+ ;; is abstract/separate/new ...
+ ;;
+ ((and
+ foundis
+ (save-excursion
+ (setq match-cons
+ (ada-search-ignore-string-comment
+ "\\<\\(separate\\|new\\|abstract\\)\\>"
+ nil orgpoint))))
+ (goto-char (car match-cons))
+ (ada-search-ignore-string-comment ada-subprog-start-re t)
+ (ada-get-indent-noindent orgpoint))
+ ;;
+ ;; something follows 'is'
+ ;;
+ ((and
+ foundis
+ (save-excursion (setq match-cons (ada-goto-next-non-ws orgpoint)))
+ (goto-char match-cons)
+ (ada-indent-on-previous-lines t orgpoint)))
+ ;;
+ ;; no 'is' but ';'
+ ;;
+ ((save-excursion
+ (ada-search-ignore-string-comment ";" nil orgpoint nil 'search-forward))
+ (list cur-indent 0))
+ ;;
+ ;; no 'is' or ';'
+ ;;
+ (t
+ (list cur-indent 'ada-broken-indent)))))
+
+(defun ada-get-indent-noindent (orgpoint)
+ "Calculates the indentation when point is just before a 'noindent stmt'.
+ORGPOINT is the limit position used in the calculation."
+ (let ((label 0))
+ (save-excursion
+ (beginning-of-line)
+
+ (cond
+
+ ;; This one is called when indenting a line preceded by a multi-line
+ ;; subprogram declaration (in that case, we are at this point inside
+ ;; the parameter declaration list)
+ ((ada-in-paramlist-p)
+ (ada-previous-procedure)
+ (list (save-excursion (back-to-indentation) (point)) 0))
+
+ ;; This one is called when indenting the second line of a multi-line
+ ;; declaration section, in a declare block or a record declaration
+ ((looking-at "[ \t]*\\(\\sw\\|_\\)*[ \t]*,[ \t]*$")
+ (list (save-excursion (back-to-indentation) (point))
+ 'ada-broken-decl-indent))
+
+ ;; This one is called in every over case when indenting a line at the
+ ;; top level
+ (t
+ (if (looking-at ada-named-block-re)
+ (setq label (- ada-label-indent))
+
+ (let (p)
+
+ ;; "with private" or "null record" cases
+ (if (or (save-excursion
+ (and (ada-search-ignore-string-comment "\\<private\\>" nil orgpoint)
+ (setq p (point))
+ (save-excursion (forward-char -7);; skip back "private"
+ (ada-goto-previous-word)
+ (looking-at "with"))))
+ (save-excursion
+ (and (ada-search-ignore-string-comment "\\<record\\>" nil orgpoint)
+ (setq p (point))
+ (save-excursion (forward-char -6);; skip back "record"
+ (ada-goto-previous-word)
+ (looking-at "null")))))
+ (progn
+ (goto-char p)
+ (re-search-backward "\\<\\(type\\|subtype\\)\\>" nil t)
+ (list (save-excursion (back-to-indentation) (point)) 0)))))
+ (if (save-excursion
+ (ada-search-ignore-string-comment ";" nil orgpoint nil
+ 'search-forward))
+ (list (+ (save-excursion (back-to-indentation) (point)) label) 0)
+ (list (+ (save-excursion (back-to-indentation) (point)) label)
+ 'ada-broken-indent)))))))
+
+(defun ada-get-indent-label (orgpoint)
+ "Calculates the indentation when before a label or variable declaration.
+ORGPOINT is the limit position used in the calculation."
+ (let ((match-cons nil)
+ (cur-indent (save-excursion (back-to-indentation) (point))))
+ (ada-search-ignore-string-comment ":" nil)
+ (cond
+ ;; loop label
+ ((save-excursion
+ (setq match-cons (ada-search-ignore-string-comment
+ ada-loop-start-re nil orgpoint)))
+ (goto-char (car match-cons))
+ (ada-get-indent-loop orgpoint))
+
+ ;; declare label
+ ((save-excursion
+ (setq match-cons (ada-search-ignore-string-comment
+ "\\<declare\\|begin\\>" nil orgpoint)))
+ (goto-char (car match-cons))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-indent))
+
+ ;; variable declaration
+ ((ada-in-decl-p)
+ (if (save-excursion
+ (ada-search-ignore-string-comment ";" nil orgpoint))
+ (list cur-indent 0)
+ (list cur-indent 'ada-broken-indent)))
+
+ ;; nothing follows colon
+ (t
+ (list cur-indent '(- ada-label-indent))))))
+
+(defun ada-get-indent-loop (orgpoint)
+ "Calculates the indentation when just before a loop or a for ... use.
+ORGPOINT is the limit position used in the calculation."
+ (let ((match-cons nil)
+ (pos (point))
+
+ ;; If looking at a named block, skip the label
+ (label (save-excursion
+ (beginning-of-line)
+ (if (looking-at ada-named-block-re)
+ (- ada-label-indent)
+ 0))))
+
+ (cond
+
+ ;;
+ ;; statement complete
+ ;;
+ ((save-excursion
+ (ada-search-ignore-string-comment ";" nil orgpoint nil
+ 'search-forward))
+ (list (+ (save-excursion (back-to-indentation) (point)) label) 0))
+ ;;
+ ;; simple loop
+ ;;
+ ((looking-at "loop\\>")
+ (setq pos (ada-get-indent-block-start orgpoint))
+ (if (equal label 0)
+ pos
+ (list (+ (car pos) label) (cdr pos))))
+
+ ;;
+ ;; 'for'- loop (or also a for ... use statement)
+ ;;
+ ((looking-at "for\\>")
+ (cond
+ ;;
+ ;; for ... use
+ ;;
+ ((save-excursion
+ (and
+ (goto-char (match-end 0))
+ (ada-goto-next-non-ws orgpoint)
+ (forward-word 1)
+ (if (= (char-after) ?') (forward-word 1) t)
+ (ada-goto-next-non-ws orgpoint)
+ (looking-at "\\<use\\>")
+ ;;
+ ;; check if there is a 'record' before point
+ ;;
+ (progn
+ (setq match-cons (ada-search-ignore-string-comment
+ "record" nil orgpoint nil 'word-search-forward))
+ t)))
+ (if match-cons
+ (progn
+ (goto-char (car match-cons))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-indent))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent))
+ )
+
+ ;;
+ ;; for..loop
+ ;;
+ ((save-excursion
+ (setq match-cons (ada-search-ignore-string-comment
+ "loop" nil orgpoint nil 'word-search-forward)))
+ (goto-char (car match-cons))
+ ;;
+ ;; indent according to 'loop', if it's first in the line;
+ ;; otherwise to 'for'
+ ;;
+ (unless (save-excursion
+ (back-to-indentation)
+ (looking-at "\\<loop\\>"))
+ (goto-char pos))
+ (list (+ (save-excursion (back-to-indentation) (point)) label)
+ 'ada-indent))
+ ;;
+ ;; for-statement is broken
+ ;;
+ (t
+ (list (+ (save-excursion (back-to-indentation) (point)) label)
+ 'ada-broken-indent))))
+
+ ;;
+ ;; 'while'-loop
+ ;;
+ ((looking-at "while\\>")
+ ;;
+ ;; while..loop ?
+ ;;
+ (if (save-excursion
+ (setq match-cons (ada-search-ignore-string-comment
+ "loop" nil orgpoint nil 'word-search-forward)))
+
+ (progn
+ (goto-char (car match-cons))
+ ;;
+ ;; indent according to 'loop', if it's first in the line;
+ ;; otherwise to 'while'.
+ ;;
+ (unless (save-excursion
+ (back-to-indentation)
+ (looking-at "\\<loop\\>"))
+ (goto-char pos))
+ (list (+ (save-excursion (back-to-indentation) (point)) label)
+ 'ada-indent))
+
+ (list (+ (save-excursion (back-to-indentation) (point)) label)
+ 'ada-broken-indent))))))
+
+(defun ada-get-indent-type (orgpoint)
+ "Calculates the indentation when before a type statement.
+ORGPOINT is the limit position used in the calculation."
+ (let ((match-dat nil))
+ (cond
+ ;;
+ ;; complete record declaration
+ ;;
+ ((save-excursion
+ (and
+ (setq match-dat (ada-search-ignore-string-comment
+ "end" nil orgpoint nil 'word-search-forward))
+ (ada-goto-next-non-ws)
+ (looking-at "\\<record\\>")
+ (forward-word 1)
+ (ada-goto-next-non-ws)
+ (= (char-after) ?\;)))
+ (goto-char (car match-dat))
+ (list (save-excursion (back-to-indentation) (point)) 0))
+ ;;
+ ;; record type
+ ;;
+ ((save-excursion
+ (setq match-dat (ada-search-ignore-string-comment
+ "record" nil orgpoint nil 'word-search-forward)))
+ (goto-char (car match-dat))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-indent))
+ ;;
+ ;; complete type declaration
+ ;;
+ ((save-excursion
+ (ada-search-ignore-string-comment ";" nil orgpoint nil
+ 'search-forward))
+ (list (save-excursion (back-to-indentation) (point)) 0))
+ ;;
+ ;; "type ... is", but not "type ... is ...", which is broken
+ ;;
+ ((save-excursion
+ (and
+ (ada-search-ignore-string-comment "is" nil orgpoint nil
+ 'word-search-forward)
+ (not (ada-goto-next-non-ws orgpoint))))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent))
+ ;;
+ ;; broken statement
+ ;;
+ (t
+ (list (save-excursion (back-to-indentation) (point))
+ 'ada-broken-indent)))))
+
+\f
+;; -----------------------------------------------------------
+;; -- searching and matching
+;; -----------------------------------------------------------
+
+(defun ada-goto-stmt-start ()
+ "Moves point to the beginning of the statement that point is in or after.
+Returns the new position of point.
+As a special case, if we are looking at a closing parenthesis, skip to the
+open parenthesis."
+ (let ((match-dat nil)
+ (orgpoint (point)))
+
+ (setq match-dat (ada-search-prev-end-stmt))
+ (if match-dat
+
+ ;;
+ ;; found a previous end-statement => check if anything follows
+ ;;
+ (unless (looking-at "declare")
+ (progn
+ (unless (save-excursion
+ (goto-char (cdr match-dat))
+ (ada-goto-next-non-ws orgpoint))
+ ;;
+ ;; nothing follows => it's the end-statement directly in
+ ;; front of point => search again
+ ;;
+ (setq match-dat (ada-search-prev-end-stmt)))
+ ;;
+ ;; if found the correct end-statement => goto next non-ws
+ ;;
+ (if match-dat
+ (goto-char (cdr match-dat)))
+ (ada-goto-next-non-ws)
+ ))
+
+ ;;
+ ;; no previous end-statement => we are at the beginning of the
+ ;; accessible part of the buffer
+ ;;
+ (progn
+ (goto-char (point-min))
+ ;;
+ ;; skip to the very first statement, if there is one
+ ;;
+ (unless (ada-goto-next-non-ws orgpoint)
+ (goto-char orgpoint))))
+ (point)))
+
+
+(defun ada-search-prev-end-stmt ()
+ "Moves point to previous end-statement.
+Returns a cons cell whose car is the beginning and whose cdr the end of the
+match."
+ (let ((match-dat nil)
+ (found nil))
+
+ ;; search until found or beginning-of-buffer
+ (while
+ (and
+ (not found)
+ (setq match-dat (ada-search-ignore-string-comment
+ ada-end-stmt-re t)))
+
+ (goto-char (car match-dat))
+ (unless (ada-in-open-paren-p)
+ (cond
+
+ ((and (looking-at
+ "\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>")
+ (save-excursion
+ (ada-goto-previous-word)
+ (looking-at "\\<\\(end\\|or\\|and\\)\\>[ \t]*[^;]")))
+ (forward-word -1))
+
+ ((looking-at "is")
+ (setq found
+ (and (save-excursion (ada-goto-previous-word)
+ (ada-goto-previous-word)
+ (not (looking-at "subtype")))
+
+ (save-excursion (goto-char (cdr match-dat))
+ (ada-goto-next-non-ws)
+ ;; words that can go after an 'is'
+ (not (looking-at
+ (eval-when-compile
+ (concat "\\<"
+ (regexp-opt
+ '("separate" "access" "array"
+ "abstract" "new") t)
+ "\\>\\|("))))))))
+
+ (t
+ (setq found t))
+ )))
+
+ (if found
+ match-dat
+ nil)))
+
+
+(defun ada-goto-next-non-ws (&optional limit)
+ "Skips white spaces, newlines and comments to next non-ws character.
+Stop the search at LIMIT.
+Do not call this function from within a string."
+ (unless limit
+ (setq limit (point-max)))
+ (while (and (<= (point) limit)
+ (progn (forward-comment 10000)
+ (if (and (not (eobp))
+ (save-excursion (forward-char 1)
+ (ada-in-string-p)))
+ (progn (forward-sexp 1) t)))))
+ (if (< (point) limit)
+ (point)
+ nil)
+ )
+
+
+(defun ada-goto-stmt-end (&optional limit)
+ "Moves point to the end of the statement that point is in or before.
+Returns the new position of point or nil if not found.
+Stop the search at LIMIT."
+ (if (ada-search-ignore-string-comment ada-end-stmt-re nil limit)
+ (point)
+ nil))
+
+
+(defun ada-goto-next-word (&optional backward)
+ "Moves point to the beginning of the next word of Ada code.
+If BACKWARD is non-nil, jump to the beginning of the previous word.
+Returns the new position of point or nil if not found."
+ (let ((match-cons nil)
+ (orgpoint (point))
+ (old-syntax (char-to-string (char-syntax ?_))))
+ (modify-syntax-entry ?_ "w")
+ (unless backward
+ (skip-syntax-forward "w"))
+ (if (setq match-cons
+ (if backward
+ (ada-search-ignore-string-comment "\\w" t nil t)
+ (ada-search-ignore-string-comment "\\w" nil nil t)))
+ ;;
+ ;; move to the beginning of the word found
+ ;;
+ (progn
+ (goto-char (car match-cons))
+ (skip-syntax-backward "w")
+ (point))
+ ;;
+ ;; if not found, restore old position of point
+ ;;
+ (goto-char orgpoint)
+ 'nil)
+ (modify-syntax-entry ?_ old-syntax))
+ )
+
+
+(defun ada-check-matching-start (keyword)
+ "Signals an error if matching block start is not KEYWORD.
+Moves point to the matching block start."
+ (ada-goto-matching-start 0)
+ (unless (looking-at (concat "\\<" keyword "\\>"))
+ (error "matching start is not '%s'" keyword)))
+
+
+(defun ada-check-defun-name (defun-name)
+ "Checks if the name of the matching defun really is DEFUN-NAME.
+Assumes point to be already positioned by 'ada-goto-matching-start'.
+Moves point to the beginning of the declaration."
+
+ ;; named block without a `declare'
+ (if (save-excursion
+ (ada-goto-previous-word)
+ (looking-at (concat "\\<" defun-name "\\> *:")))
+ t ; do nothing
+ ;;
+ ;; 'accept' or 'package' ?
+ ;;
+ (unless (looking-at ada-subprog-start-re)
+ (ada-goto-matching-decl-start))
+ ;;
+ ;; 'begin' of 'procedure'/'function'/'task' or 'declare'
+ ;;
+ (save-excursion
+ ;;
+ ;; a named 'declare'-block ?
+ ;;
+ (if (looking-at "\\<declare\\>")
+ (ada-goto-stmt-start)
+ ;;
+ ;; no, => 'procedure'/'function'/'task'/'protected'
+ ;;
+ (progn
+ (forward-word 2)
+ (backward-word 1)
+ ;;
+ ;; skip 'body' 'type'
+ ;;
+ (if (looking-at "\\<\\(body\\|type\\)\\>")
+ (forward-word 1))
+ (forward-sexp 1)
+ (backward-sexp 1)))
+ ;;
+ ;; should be looking-at the correct name
+ ;;
+ (unless (looking-at (concat "\\<" defun-name "\\>"))
+ (error "matching defun has different name: %s"
+ (buffer-substring (point)
+ (progn (forward-sexp 1) (point))))))))
+
+(defun ada-goto-matching-decl-start (&optional noerror recursive)
+ "Moves point to the matching declaration start of the current 'begin'.
+If NOERROR is non-nil, it only returns nil if no match was found."
+ (let ((nest-count 1)
+
+ ;; first should be set to t if we should stop at the first
+ ;; "begin" we encounter.
+ (first (not recursive))
+ (count-generic nil)
+ (stop-at-when nil)
+ )
+
+ ;; Ignore "when" most of the time, except if we are looking at the
+ ;; beginning of a block (structure: case .. is
+ ;; when ... =>
+ ;; begin ...
+ ;; exception ... )
+ (if (looking-at "begin")
+ (setq stop-at-when t))
+
+ (if (or
+ (looking-at "\\<\\(package\\|procedure\\|function\\)\\>")
+ (save-excursion
+ (ada-search-ignore-string-comment
+ "\\<\\(package\\|procedure\\|function\\|generic\\)\\>" t)
+ (looking-at "generic")))
+ (setq count-generic t))
+
+ ;; search backward for interesting keywords
+ (while (and
+ (not (zerop nest-count))
+ (ada-search-ignore-string-comment ada-matching-decl-start-re t))
+ ;;
+ ;; calculate nest-depth
+ ;;
+ (cond
+ ;;
+ ((looking-at "end")
+ (ada-goto-matching-start 1 noerror)
+
+ ;; In some case, two begin..end block can follow each other closely,
+ ;; which we have to detect, as in
+ ;; procedure P is
+ ;; procedure Q is
+ ;; begin
+ ;; end;
+ ;; begin -- here we should go to procedure, not begin
+ ;; end
+
+ (if (looking-at "begin")
+ (let ((loop-again t))
+ (save-excursion
+ (while loop-again
+ ;; If begin was just there as the beginning of a block
+ ;; (with no declare) then do nothing, otherwise just
+ ;; register that we have to find the statement that
+ ;; required the begin
+
+ (ada-search-ignore-string-comment
+ "\\<\\(declare\\|begin\\|end\\|procedure\\|function\\|task\\|package\\)\\>"
+ t)
+
+ (if (looking-at "end")
+ (ada-goto-matching-start 1 noerror t)
+ ;; (ada-goto-matching-decl-start noerror t)
+
+ (setq loop-again nil)
+ (unless (looking-at "begin")
+ (setq nest-count (1+ nest-count))))
+ ))
+ )))
+ ;;
+ ((looking-at "generic")
+ (if count-generic
+ (progn
+ (setq first nil)
+ (setq nest-count (1- nest-count)))))
+ ;;
+ ((looking-at "if")
+ (save-excursion
+ (forward-word -1)
+ (unless (looking-at "\\<end[ \t\n]*if\\>")
+ (progn
+ (setq nest-count (1- nest-count))
+ (setq first nil)))))
+
+ ;;
+ ((looking-at "declare\\|generic")
+ (setq nest-count (1- nest-count))
+ (setq first t))
+ ;;
+ ((looking-at "is")
+ ;; check if it is only a type definition, but not a protected
+ ;; type definition, which should be handled like a procedure.
+ (if (or (looking-at "is[ \t]+<>")
+ (save-excursion
+ (forward-comment -10000)
+ (forward-char -1)
+
+ ;; Detect if we have a closing parenthesis (Could be
+ ;; either the end of subprogram parameters or (<>)
+ ;; in a type definition
+ (if (= (char-after) ?\))
+ (progn
+ (forward-char 1)
+ (backward-sexp 1)
+ (forward-comment -10000)
+ ))
+ (skip-chars-backward "a-zA-Z0-9_.'")
+ (ada-goto-previous-word)
+ (and
+ (looking-at "\\<\\(sub\\)?type\\|case\\>")
+ (save-match-data
+ (ada-goto-previous-word)
+ (not (looking-at "\\<protected\\>"))))
+ )) ; end of `or'
+ (goto-char (match-beginning 0))
+ (progn
+ (setq nest-count (1- nest-count))
+ (setq first nil))))
+
+ ;;
+ ((looking-at "new")
+ (if (save-excursion
+ (ada-goto-previous-word)
+ (looking-at "is"))
+ (goto-char (match-beginning 0))))
+ ;;
+ ((and first
+ (looking-at "begin"))
+ (setq nest-count 0))
+ ;;
+ ((looking-at "when")
+ (save-excursion
+ (forward-word -1)
+ (unless (looking-at "\\<exit[ \t\n]*when\\>")
+ (progn
+ (if stop-at-when
+ (setq nest-count (1- nest-count)))
+ ))))
+ ;;
+ ((looking-at "begin")
+ (setq first nil))
+ ;;
+ (t
+ (setq nest-count (1+ nest-count))
+ (setq first nil)))
+
+ );; end of loop
+
+ ;; check if declaration-start is really found
+ (if (and
+ (zerop nest-count)
+ (if (looking-at "is")
+ (ada-search-ignore-string-comment ada-subprog-start-re t)
+ (looking-at "declare\\|generic")))
+ t
+ (if noerror nil
+ (error "no matching proc/func/task/declare/package/protected")))
+ ))
+
+(defun ada-goto-matching-start (&optional nest-level noerror gotothen)
+ "Moves point to the beginning of a block-start.
+Which block depends on the value of NEST-LEVEL, which defaults to zero. If
+NOERROR is non-nil, it only returns nil if no matching start was found.
+If GOTOTHEN is non-nil, point moves to the 'then' following 'if'."
+ (let ((nest-count (if nest-level nest-level 0))
+ (found nil)
+ (pos nil))
+
+ ;;
+ ;; search backward for interesting keywords
+ ;;
+ (while (and
+ (not found)
+ (ada-search-ignore-string-comment ada-matching-start-re t))
+
+ (unless (and (looking-at "\\<record\\>")
+ (save-excursion
+ (forward-word -1)
+ (looking-at "\\<null\\>")))
+ (progn
+ ;;
+ ;; calculate nest-depth
+ ;;
+ (cond
+ ;; found block end => increase nest depth
+ ((looking-at "end")
+ (setq nest-count (1+ nest-count)))
+
+ ;; found loop/select/record/case/if => check if it starts or
+ ;; ends a block
+ ((looking-at "loop\\|select\\|record\\|case\\|if")
+ (setq pos (point))
+ (save-excursion
+ ;;
+ ;; check if keyword follows 'end'
+ ;;
+ (ada-goto-previous-word)
+ (if (looking-at "\\<end\\>[ \t]*[^;]")
+ ;; it ends a block => increase nest depth
+ (setq nest-count (1+ nest-count)
+ pos (point))
+
+ ;; it starts a block => decrease nest depth
+ (setq nest-count (1- nest-count))))
+ (goto-char pos))
+
+ ;; found package start => check if it really is a block
+ ((looking-at "package")
+ (save-excursion
+ ;; ignore if this is just a renames statement
+ (let ((current (point))
+ (pos (ada-search-ignore-string-comment
+ "\\<\\(is\\|renames\\|;\\)\\>" nil)))
+ (if pos
+ (goto-char (car pos))
+ (error (concat
+ "No matching 'is' or 'renames' for 'package' at"
+ " line "
+ (number-to-string (count-lines 1 (1+ current)))))))
+ (unless (looking-at "renames")
+ (progn
+ (forward-word 1)
+ (ada-goto-next-non-ws)
+ ;; ignore it if it is only a declaration with 'new'
+ ;; We could have package Foo is new ....
+ ;; or package Foo is separate;
+ ;; or package Foo is begin null; end Foo
+ ;; for elaboration code (elaboration)
+ (if (not (looking-at "\\<\\(new\\|separate\\|begin\\)\\>"))
+ (setq nest-count (1- nest-count)))))))
+ ;; found task start => check if it has a body
+ ((looking-at "task")
+ (save-excursion
+ (forward-word 1)
+ (ada-goto-next-non-ws)
+ (cond
+ ((looking-at "\\<body\\>"))
+ ((looking-at "\\<type\\>")
+ ;; In that case, do nothing if there is a "is"
+ (forward-word 2);; skip "type"
+ (ada-goto-next-non-ws);; skip type name
+
+ ;; Do nothing if we are simply looking at a simple
+ ;; "task type name;" statement with no block
+ (unless (looking-at ";")
+ (progn
+ ;; Skip the parameters
+ (if (looking-at "(")
+ (ada-search-ignore-string-comment ")" nil))
+ (let ((tmp (ada-search-ignore-string-comment
+ "\\<\\(is\\|;\\)\\>" nil)))
+ (if tmp
+ (progn
+ (goto-char (car tmp))
+ (if (looking-at "is")
+ (setq nest-count (1- nest-count)))))))))
+ (t
+ ;; Check if that task declaration had a block attached to
+ ;; it (i.e do nothing if we have just "task name;")
+ (unless (progn (forward-word 1)
+ (looking-at "[ \t]*;"))
+ (setq nest-count (1- nest-count)))))))
+ ;; all the other block starts
+ (t
+ (setq nest-count (1- nest-count)))) ; end of 'cond'
+
+ ;; match is found, if nest-depth is zero
+ ;;
+ (setq found (zerop nest-count))))) ; end of loop
+
+ (if (bobp)
+ (point)
+ (if found
+ ;;
+ ;; match found => is there anything else to do ?
+ ;;
+ (progn
+ (cond
+ ;;
+ ;; found 'if' => skip to 'then', if it's on a separate line
+ ;; and GOTOTHEN is non-nil
+ ;;
+ ((and
+ gotothen
+ (looking-at "if")
+ (save-excursion
+ (ada-search-ignore-string-comment "then" nil nil nil
+ 'word-search-forward)
+ (back-to-indentation)
+ (looking-at "\\<then\\>")))
+ (goto-char (match-beginning 0)))
+
+ ;;
+ ;; found 'do' => skip back to 'accept'
+ ;;
+ ((looking-at "do")
+ (unless (ada-search-ignore-string-comment
+ "accept" t nil nil
+ 'word-search-backward)
+ (error "missing 'accept' in front of 'do'"))))
+ (point))
+
+ (if noerror
+ nil
+ (error "no matching start"))))))
+
+
+(defun ada-goto-matching-end (&optional nest-level noerror)
+ "Moves point to the end of a block.
+Which block depends on the value of NEST-LEVEL, which defaults to zero.
+If NOERROR is non-nil, it only returns nil if found no matching start."
+ (let ((nest-count (or nest-level 0))
+ (regex (eval-when-compile
+ (concat "\\<"
+ (regexp-opt '("end" "loop" "select" "begin" "case"
+ "if" "task" "package" "record" "do"
+ "procedure" "function") t)
+ "\\>")))
+ found
+ pos
+
+ ;; First is used for subprograms: they are generally handled
+ ;; recursively, but of course we do not want to do that the
+ ;; first time (see comment below about subprograms)
+ (first (not (looking-at "declare"))))
+
+ ;; If we are already looking at one of the keywords, this shouldn't count
+ ;; in the nesting loop below, so we just make sure we don't count it.
+ ;; "declare" is a special case because we need to look after the "begin"
+ ;; keyword
+ (if (looking-at "\\<if\\|loop\\|case\\|begin\\>")
+ (forward-char 1))
+
+ ;;
+ ;; search forward for interesting keywords
+ ;;
+ (while (and
+ (not found)
+ (ada-search-ignore-string-comment regex nil))
+
+ ;;
+ ;; calculate nest-depth
+ ;;
+ (backward-word 1)
+ (cond
+ ;; procedures and functions need to be processed recursively, in
+ ;; case they are defined in a declare/begin block, as in:
+ ;; declare -- NL 0 (nested level)
+ ;; A : Boolean;
+ ;; procedure B (C : D) is
+ ;; begin -- NL 1
+ ;; null;
+ ;; end B; -- NL 0, and we would exit
+ ;; begin
+ ;; end; -- we should exit here
+ ;; processing them recursively avoids the need for any special
+ ;; handling.
+ ;; Nothing should be done if we have only the specs or a
+ ;; generic instantion.
+
+ ((and (looking-at "\\<procedure\\|function\\>"))
+ (if first
+ (forward-word 1)
+
+ (setq pos (point))
+ (ada-search-ignore-string-comment "is\\|;")
+ (if (= (char-before) ?s)
+ (progn
+ (ada-goto-next-non-ws)
+ (unless (looking-at "\\<new\\>")
+ (progn
+ (goto-char pos)
+ (ada-goto-matching-end 0 t)))))))
+
+ ;; found block end => decrease nest depth
+ ((looking-at "\\<end\\>")
+ (setq nest-count (1- nest-count)
+ found (<= nest-count 0))
+ ;; skip the following keyword
+ (if (progn
+ (skip-chars-forward "end")
+ (ada-goto-next-non-ws)
+ (looking-at "\\<\\(loop\\|select\\|record\\|case\\|if\\)\\>"))
+ (forward-word 1)))
+
+ ;; found package start => check if it really starts a block, and is not
+ ;; in fact a generic instantiation for instance
+ ((looking-at "\\<package\\>")
+ (ada-search-ignore-string-comment "is" nil nil nil
+ 'word-search-forward)
+ (ada-goto-next-non-ws)
+ ;; ignore and skip it if it is only a 'new' package
+ (if (looking-at "\\<new\\>")
+ (goto-char (match-end 0))
+ (setq nest-count (1+ nest-count)
+ found (<= nest-count 0))))
+
+ ;; all the other block starts
+ (t
+ (if (not first)
+ (setq nest-count (1+ nest-count)))
+ (setq found (<= nest-count 0))
+ (forward-word 1))) ; end of 'cond'
+
+ (setq first nil))
+
+ (if found
+ t
+ (if noerror
+ nil
+ (error "no matching end")))
+ ))
+
+
+(defun ada-search-ignore-string-comment
+ (search-re &optional backward limit paramlists search-func)
+ "Regexp-search for SEARCH-RE, ignoring comments, strings.
+If PARAMLISTS is nil, ignore parameter lists. Returns a cons cell of
+begin and end of match data or nil, if not found.
+The search is done using SEARCH-FUNC, which should search backward if
+BACKWARD is non-nil, forward otherwise. SEARCH-FUNC can be optimized in case
+we are searching for a constant string.
+The search stops at pos LIMIT.
+Point is moved at the beginning of the search-re."
+ (let (found
+ begin
+ end
+ parse-result
+ (previous-syntax-table (syntax-table)))
+
+ (unless search-func
+ (setq search-func (if backward 're-search-backward 're-search-forward)))
+
+ ;;
+ ;; search until found or end-of-buffer
+ ;; We have to test that we do not look further than limit
+ ;;
+ (set-syntax-table ada-mode-symbol-syntax-table)
+ (while (and (not found)
+ (or (not limit)
+ (or (and backward (<= limit (point)))
+ (>= limit (point))))
+ (funcall search-func search-re limit 1))
+ (setq begin (match-beginning 0))
+ (setq end (match-end 0))
+
+ (setq parse-result (parse-partial-sexp
+ (save-excursion (beginning-of-line) (point))
+ (point)))
+
+ (cond
+ ;;
+ ;; If inside a string, skip it (and the following comments)
+ ;;
+ ((ada-in-string-p parse-result)
+ (if (featurep 'xemacs)
+ (search-backward "\"" nil t)
+ (goto-char (nth 8 parse-result)))
+ (unless backward (forward-sexp 1)))
+ ;;
+ ;; If inside a comment, skip it (and the following comments)
+ ;; There is a special code for comments at the end of the file
+ ;;
+ ((ada-in-comment-p parse-result)
+ (if (featurep 'xemacs)
+ (progn
+ (forward-line 1)
+ (beginning-of-line)
+ (forward-comment -1))
+ (goto-char (nth 8 parse-result)))
+ (unless backward
+ ;; at the end of the file, it is not possible to skip a comment
+ ;; so we just go at the end of the line
+ (if (forward-comment 1)
+ (progn
+ (forward-comment 1000)
+ (beginning-of-line))
+ (end-of-line))))
+ ;;
+ ;; directly in front of a comment => skip it, if searching forward
+ ;;
+ ((and (= (char-after begin) ?-) (= (char-after (1+ begin)) ?-))
+ (unless backward (progn (forward-char -1) (forward-comment 1000))))
+
+ ;;
+ ;; found a parameter-list but should ignore it => skip it
+ ;;
+ ((and (not paramlists) (ada-in-paramlist-p))
+ (if backward
+ (search-backward "(" nil t)
+ (search-forward ")" nil t)))
+ ;;
+ ;; found what we were looking for
+ ;;
+ (t
+ (setq found t)))) ; end of loop
+
+ (set-syntax-table previous-syntax-table)
+
+ (if found
+ (cons begin end)
+ nil)))
+
+;; -------------------------------------------------------
+;; -- Testing the position of the cursor
+;; -------------------------------------------------------
+
+(defun ada-in-decl-p ()
+ "Returns t if point is inside a declarative part.
+Assumes point to be at the end of a statement."
+ (or (ada-in-paramlist-p)
+ (save-excursion
+ (ada-goto-matching-decl-start t))))
+
+
+(defun ada-looking-at-semi-or ()
+ "Returns t if looking-at an 'or' following a semicolon."
+ (save-excursion
+ (and (looking-at "\\<or\\>")
+ (progn
+ (forward-word 1)
+ (ada-goto-stmt-start)
+ (looking-at "\\<or\\>")))))
+
+
+(defun ada-looking-at-semi-private ()
+ "Returns t if looking at the start of a private section in a package.
+Returns nil if the private is part of the package name, as in
+'private package A is...' (this can only happen at top level)."
+ (save-excursion
+ (and (looking-at "\\<private\\>")
+ (not (looking-at "\\<private[ \t]*\\(package\\|generic\\)"))
+
+ ;; Make sure this is the start of a private section (ie after
+ ;; a semicolon or just after the package declaration, but not
+ ;; after a 'type ... is private' or 'is new ... with private'
+ ;;
+ ;; Note that a 'private' statement at the beginning of the buffer
+ ;; does not indicate a private section, since this is instead a
+ ;; 'private procedure ...'
+ (progn (forward-comment -1000)
+ (and (not (bobp))
+ (or (= (char-before) ?\;)
+ (and (forward-word -3)
+ (looking-at "\\<package\\>"))))))))
+
+
+(defun ada-in-paramlist-p ()
+ "Returns t if point is inside a parameter-list."
+ (save-excursion
+ (and
+ (ada-search-ignore-string-comment "(\\|)" t nil t)
+ ;; inside parentheses ?
+ (= (char-after) ?\()
+
+ ;; We could be looking at two things here:
+ ;; operator definition: function "." (
+ ;; subprogram definition: procedure .... (
+ ;; Let's skip back over the first one
+ (progn
+ (skip-chars-backward " \t\n")
+ (if (= (char-before) ?\")
+ (backward-char 3)
+ (backward-word 1))
+ t)
+
+ ;; and now over the second one
+ (backward-word 1)
+
+ ;; We should ignore the case when the reserved keyword is in a
+ ;; comment (for instance, when we have:
+ ;; -- .... package
+ ;; Test (A)
+ ;; we should return nil
+
+ (not (ada-in-string-or-comment-p))
+
+ ;; right keyword two words before parenthesis ?
+ ;; Type is in this list because of discriminants
+ (looking-at (eval-when-compile
+ (concat "\\<\\("
+ "procedure\\|function\\|body\\|"
+ "task\\|entry\\|accept\\|"
+ "access[ \t]+procedure\\|"
+ "access[ \t]+function\\|"
+ "pragma\\|"
+ "type\\)\\>"))))))
+
+(defun ada-search-ignore-complex-boolean (regexp backwardp)
+ "Like `ada-search-ignore-string-comment', except that it also ignores
+boolean expressions 'and then' and 'or else'."
+ (let (result)
+ (while (and (setq result (ada-search-ignore-string-comment regexp backwardp))
+ (save-excursion (forward-word -1)
+ (looking-at "and then\\|or else"))))
+ result))
+
+(defun ada-in-open-paren-p ()
+ "Returns the position of the first non-ws behind the last unclosed
+parenthesis, or nil."
+ (save-excursion
+ (let ((parse (parse-partial-sexp
+ (point)
+ (or (car (ada-search-ignore-complex-boolean
+ "\\<\\(;\\|is\\|then\\|loop\\|begin\\|else\\)\\>"
+ t))
+ (point-min)))))
+
+ (if (nth 1 parse)
+ (progn
+ (goto-char (1+ (nth 1 parse)))
+
+ ;; Skip blanks, if they are not followed by a comment
+ ;; See:
+ ;; type A is ( Value_0,
+ ;; Value_1);
+ ;; type B is ( -- comment
+ ;; Value_2);
+
+ (if (or (not ada-indent-handle-comment-special)
+ (not (looking-at "[ \t]+--")))
+ (skip-chars-forward " \t"))
+
+ (point))))))
+
+\f
+;; -----------------------------------------------------------
+;; -- Behavior Of TAB Key
+;; -----------------------------------------------------------
+
+(defun ada-tab ()
+ "Do indenting or tabbing according to `ada-tab-policy'.
+In Transient Mark mode, if the mark is active, operate on the contents
+of the region. Otherwise, operates only on the current line."
+ (interactive)
+ (cond ((eq ada-tab-policy 'indent-rigidly) (ada-tab-hard))
+ ((eq ada-tab-policy 'indent-auto)
+ (if (ada-region-selected)
+ (ada-indent-region (region-beginning) (region-end))
+ (ada-indent-current)))
+ ((eq ada-tab-policy 'always-tab) (error "not implemented"))
+ ))
+
+(defun ada-untab (arg)
+ "Delete leading indenting according to `ada-tab-policy'."
+ (interactive "P")
+ (cond ((eq ada-tab-policy 'indent-rigidly) (ada-untab-hard))
+ ((eq ada-tab-policy 'indent-auto) (error "not implemented"))
+ ((eq ada-tab-policy 'always-tab) (error "not implemented"))
+ ))
+
+(defun ada-indent-current-function ()
+ "Ada mode version of the indent-line-function."
+ (interactive "*")
+ (let ((starting-point (point-marker)))
+ (beginning-of-line)
+ (ada-tab)
+ (if (< (point) starting-point)
+ (goto-char starting-point))
+ (set-marker starting-point nil)
+ ))
+
+(defun ada-tab-hard ()
+ "Indent current line to next tab stop."
+ (interactive)
+ (save-excursion
+ (beginning-of-line)
+ (insert-char ? ada-indent))
+ (if (save-excursion (= (point) (progn (beginning-of-line) (point))))
+ (forward-char ada-indent)))
+
+(defun ada-untab-hard ()
+ "indent current line to previous tab stop."
+ (interactive)
+ (let ((bol (save-excursion (progn (beginning-of-line) (point))))
+ (eol (save-excursion (progn (end-of-line) (point)))))
+ (indent-rigidly bol eol (- 0 ada-indent))))
+
+
+\f
+;; ------------------------------------------------------------
+;; -- Miscellaneous
+;; ------------------------------------------------------------
+
+;; Not needed any more for Emacs 21.2, but still needed for backward
+;; compatibility
+(defun ada-remove-trailing-spaces ()
+ "Remove trailing spaces in the whole buffer."
+ (interactive)
+ (save-match-data
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t]+$" (point-max) t)
+ (replace-match "" nil nil))))))
+
+(defun ada-gnat-style ()
+ "Clean up comments, `(' and `,' for GNAT style checking switch."
+ (interactive)
+ (save-excursion
+
+ ;; The \n is required, or the line after an empty comment line is
+ ;; simply ignored.
+ (goto-char (point-min))
+ (while (re-search-forward "--[ \t]*\\([^-\n]\\)" nil t)
+ (replace-match "-- \\1")
+ (forward-line 1)
+ (beginning-of-line))
+
+ (goto-char (point-min))
+ (while (re-search-forward "\\>(" nil t)
+ (if (not (ada-in-string-or-comment-p))
+ (replace-match " (")))
+ (goto-char (point-min))
+ (while (re-search-forward ";--" nil t)
+ (forward-char -1)
+ (if (not (ada-in-string-or-comment-p))
+ (replace-match "; --")))
+ (goto-char (point-min))
+ (while (re-search-forward "([ \t]+" nil t)
+ (if (not (ada-in-string-or-comment-p))
+ (replace-match "(")))
+ (goto-char (point-min))
+ (while (re-search-forward ")[ \t]+)" nil t)
+ (if (not (ada-in-string-or-comment-p))
+ (replace-match "))")))
+ (goto-char (point-min))
+ (while (re-search-forward "\\>:" nil t)
+ (if (not (ada-in-string-or-comment-p))
+ (replace-match " :")))
+
+ ;; Make sure there is a space after a ','.
+ ;; Always go back to the beginning of the match, since otherwise
+ ;; a statement like ('F','D','E') is incorrectly modified.
+ (goto-char (point-min))
+ (while (re-search-forward ",[ \t]*\\(.\\)" nil t)
+ (if (not (save-excursion
+ (goto-char (match-beginning 0))
+ (ada-in-string-or-comment-p)))
+ (replace-match ", \\1")))
+
+ ;; Operators should be surrounded by spaces.
+ (goto-char (point-min))
+ (while (re-search-forward
+ "[ \t]*\\(/=\\|\\*\\*\\|:=\\|\\.\\.\\|[-:+*/]\\)[ \t]*"
+ nil t)
+ (goto-char (match-beginning 1))
+ (if (or (looking-at "--")
+ (ada-in-string-or-comment-p))
+ (progn
+ (forward-line 1)
+ (beginning-of-line))
+ (cond
+ ((string= (match-string 1) "/=")
+ (replace-match " /= "))
+ ((string= (match-string 1) "..")
+ (replace-match " .. "))
+ ((string= (match-string 1) "**")
+ (replace-match " ** "))
+ ((string= (match-string 1) ":=")
+ (replace-match " := "))
+ (t
+ (replace-match " \\1 ")))
+ (forward-char 1)))
+ ))
+
+
+\f
+;; -------------------------------------------------------------
+;; -- Moving To Procedures/Packages/Statements
+;; -------------------------------------------------------------
+
+(defun ada-move-to-start ()
+ "Moves point to the matching start of the current Ada structure."
+ (interactive)
+ (let ((pos (point))
+ (previous-syntax-table (syntax-table)))
+ (unwind-protect
+ (progn
+ (set-syntax-table ada-mode-symbol-syntax-table)
+
+ (save-excursion
+ ;;
+ ;; do nothing if in string or comment or not on 'end ...;'
+ ;; or if an error occurs during processing
+ ;;
+ (or
+ (ada-in-string-or-comment-p)
+ (and (progn
+ (or (looking-at "[ \t]*\\<end\\>")
+ (backward-word 1))
+ (or (looking-at "[ \t]*\\<end\\>")
+ (backward-word 1))
+ (or (looking-at "[ \t]*\\<end\\>")
+ (error "not on end ...;")))
+ (ada-goto-matching-start 1)
+ (setq pos (point))
+
+ ;;
+ ;; on 'begin' => go on, according to user option
+ ;;
+ ada-move-to-declaration
+ (looking-at "\\<begin\\>")
+ (ada-goto-matching-decl-start)
+ (setq pos (point))))
+
+ ) ; end of save-excursion
+
+ ;; now really move to the found position
+ (goto-char pos))
+
+ ;; restore syntax-table
+ (set-syntax-table previous-syntax-table))))
+
+(defun ada-move-to-end ()
+ "Moves point to the matching end of the block around point.
+Moves to 'begin' if in a declarative part."
+ (interactive)
+ (let ((pos (point))
+ decl-start
+ (previous-syntax-table (syntax-table)))
+ (unwind-protect
+ (progn
+ (set-syntax-table ada-mode-symbol-syntax-table)
+
+ (save-excursion
+
+ (cond
+ ;; Go to the beginning of the current word, and check if we are
+ ;; directly on 'begin'
+ ((save-excursion
+ (skip-syntax-backward "w")
+ (looking-at "\\<begin\\>"))
+ (ada-goto-matching-end 1)
+ )
+
+ ;; on first line of subprogram body
+ ;; Do nothing for specs or generic instantion, since these are
+ ;; handled as the general case (find the enclosing block)
+ ;; We also need to make sure that we ignore nested subprograms
+ ((save-excursion
+ (and (skip-syntax-backward "w")
+ (looking-at "\\<function\\>\\|\\<procedure\\>" )
+ (ada-search-ignore-string-comment "is\\|;")
+ (not (= (char-before) ?\;))
+ ))
+ (skip-syntax-backward "w")
+ (ada-goto-matching-end 0 t))
+
+ ;; on first line of task declaration
+ ((save-excursion
+ (and (ada-goto-stmt-start)
+ (looking-at "\\<task\\>" )
+ (forward-word 1)
+ (ada-goto-next-non-ws)
+ (looking-at "\\<body\\>")))
+ (ada-search-ignore-string-comment "begin" nil nil nil
+ 'word-search-forward))
+ ;; accept block start
+ ((save-excursion
+ (and (ada-goto-stmt-start)
+ (looking-at "\\<accept\\>" )))
+ (ada-goto-matching-end 0))
+ ;; package start
+ ((save-excursion
+ (setq decl-start (and (ada-goto-matching-decl-start t) (point)))
+ (and decl-start (looking-at "\\<package\\>")))
+ (ada-goto-matching-end 1))
+
+ ;; On a "declare" keyword
+ ((save-excursion
+ (skip-syntax-backward "w")
+ (looking-at "\\<declare\\>"))
+ (ada-goto-matching-end 0 t))
+
+ ;; inside a 'begin' ... 'end' block
+ (decl-start
+ (goto-char decl-start)
+ (ada-goto-matching-end 0 t))
+
+ ;; (hopefully ;-) everything else
+ (t
+ (ada-goto-matching-end 1)))
+ (setq pos (point))
+ )
+
+ ;; now really move to the position found
+ (goto-char pos))
+
+ ;; restore syntax-table
+ (set-syntax-table previous-syntax-table))))
+
+(defun ada-next-procedure ()
+ "Moves point to next procedure."
+ (interactive)
+ (end-of-line)
+ (if (re-search-forward ada-procedure-start-regexp nil t)
+ (goto-char (match-beginning 2))
+ (error "No more functions/procedures/tasks")))
+
+(defun ada-previous-procedure ()
+ "Moves point to previous procedure."
+ (interactive)
+ (beginning-of-line)
+ (if (re-search-backward ada-procedure-start-regexp nil t)
+ (goto-char (match-beginning 2))
+ (error "No more functions/procedures/tasks")))
+
+(defun ada-next-package ()
+ "Moves point to next package."
+ (interactive)
+ (end-of-line)
+ (if (re-search-forward ada-package-start-regexp nil t)
+ (goto-char (match-beginning 1))
+ (error "No more packages")))
+
+(defun ada-previous-package ()
+ "Moves point to previous package."
+ (interactive)
+ (beginning-of-line)
+ (if (re-search-backward ada-package-start-regexp nil t)
+ (goto-char (match-beginning 1))
+ (error "No more packages")))
+
+\f
+;; ------------------------------------------------------------
+;; -- Define keymap and menus for Ada
+;; -------------------------------------------------------------
+
+(defun ada-create-keymap ()
+ "Create the keymap associated with the Ada mode."
+
+ ;; Indentation and Formatting
+ (define-key ada-mode-map "\C-j" 'ada-indent-newline-indent-conditional)
+ (define-key ada-mode-map "\C-m" 'ada-indent-newline-indent-conditional)
+ (define-key ada-mode-map "\t" 'ada-tab)
+ (define-key ada-mode-map "\C-c\t" 'ada-justified-indent-current)
+ (define-key ada-mode-map "\C-c\C-l" 'ada-indent-region)
+ (if (featurep 'xemacs)
+ (define-key ada-mode-map '(shift tab) 'ada-untab)
+ (define-key ada-mode-map [(shift tab)] 'ada-untab))
+ (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist)
+ ;; We don't want to make meta-characters case-specific.
+
+ ;; Movement
+ (define-key ada-mode-map "\M-\C-e" 'ada-next-procedure)
+ (define-key ada-mode-map "\M-\C-a" 'ada-previous-procedure)
+ (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start)
+ (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end)
+
+ ;; Compilation
+ (unless (lookup-key ada-mode-map "\C-c\C-c")
+ (define-key ada-mode-map "\C-c\C-c" 'compile))
+
+ ;; Casing
+ (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer)
+ (define-key ada-mode-map "\C-c\C-t" 'ada-case-read-exceptions)
+ (define-key ada-mode-map "\C-c\C-y" 'ada-create-case-exception)
+ (define-key ada-mode-map "\C-c\C-\M-y" 'ada-create-case-exception-substring)
+
+ ;; On XEmacs, you can easily specify whether DEL should deletes
+ ;; one character forward or one character backward. Take this into
+ ;; account
+ (if (boundp 'delete-key-deletes-forward)
+ (define-key ada-mode-map [backspace] 'backward-delete-char-untabify)
+ (define-key ada-mode-map "\177" 'backward-delete-char-untabify))
+
+ ;; Make body
+ (define-key ada-mode-map "\C-c\C-n" 'ada-make-subprogram-body)
+
+ ;; Use predefined function of Emacs19 for comments (RE)
+ (define-key ada-mode-map "\C-c;" 'comment-region)
+ (define-key ada-mode-map "\C-c:" 'ada-uncomment-region)
+
+ ;; The following keys are bound to functions defined in ada-xref.el or
+ ;; ada-prj,el., However, RMS rightly thinks that the code should be shared,
+ ;; and activated only if the right compiler is used
+ (if (featurep 'xemacs)
+ (progn
+ (define-key ada-mode-map '(shift button3) 'ada-point-and-xref)
+ (define-key ada-mode-map '(control tab) 'ada-complete-identifier))
+ (define-key ada-mode-map [C-tab] 'ada-complete-identifier)
+ (define-key ada-mode-map [S-mouse-3] 'ada-point-and-xref))
+
+ (define-key ada-mode-map "\C-co" 'ff-find-other-file)
+ (define-key ada-mode-map "\C-c5\C-d" 'ada-goto-declaration-other-frame)
+ (define-key ada-mode-map "\C-c\C-d" 'ada-goto-declaration)
+ (define-key ada-mode-map "\C-c\C-s" 'ada-xref-goto-previous-reference)
+ (define-key ada-mode-map "\C-c\C-c" 'ada-compile-application)
+ (define-key ada-mode-map "\C-cc" 'ada-change-prj)
+ (define-key ada-mode-map "\C-cd" 'ada-set-default-project-file)
+ (define-key ada-mode-map "\C-cg" 'ada-gdb-application)
+ (define-key ada-mode-map "\C-cr" 'ada-run-application)
+ (define-key ada-mode-map "\C-c\C-o" 'ada-goto-parent)
+ (define-key ada-mode-map "\C-c\C-r" 'ada-find-references)
+ (define-key ada-mode-map "\C-cl" 'ada-find-local-references)
+ (define-key ada-mode-map "\C-c\C-v" 'ada-check-current)
+ (define-key ada-mode-map "\C-cf" 'ada-find-file)
+
+ (define-key ada-mode-map "\C-cu" 'ada-prj-edit)
+
+ ;; The templates, defined in ada-stmt.el
+
+ (let ((map (make-sparse-keymap)))
+ (define-key map "h" 'ada-header)
+ (define-key map "\C-a" 'ada-array)
+ (define-key map "b" 'ada-exception-block)
+ (define-key map "d" 'ada-declare-block)
+ (define-key map "c" 'ada-case)
+ (define-key map "\C-e" 'ada-elsif)
+ (define-key map "e" 'ada-else)
+ (define-key map "\C-k" 'ada-package-spec)
+ (define-key map "k" 'ada-package-body)
+ (define-key map "\C-p" 'ada-procedure-spec)
+ (define-key map "p" 'ada-subprogram-body)
+ (define-key map "\C-f" 'ada-function-spec)
+ (define-key map "f" 'ada-for-loop)
+ (define-key map "i" 'ada-if)
+ (define-key map "l" 'ada-loop)
+ (define-key map "\C-r" 'ada-record)
+ (define-key map "\C-s" 'ada-subtype)
+ (define-key map "S" 'ada-tabsize)
+ (define-key map "\C-t" 'ada-task-spec)
+ (define-key map "t" 'ada-task-body)
+ (define-key map "\C-y" 'ada-type)
+ (define-key map "\C-v" 'ada-private)
+ (define-key map "u" 'ada-use)
+ (define-key map "\C-u" 'ada-with)
+ (define-key map "\C-w" 'ada-when)
+ (define-key map "w" 'ada-while-loop)
+ (define-key map "\C-x" 'ada-exception)
+ (define-key map "x" 'ada-exit)
+ (define-key ada-mode-map "\C-ct" map))
+ )
+
+
+(defun ada-create-menu ()
+ "Create the ada menu as shown in the menu bar."
+ (let ((m '("Ada"
+ ("Help"
+ ["Ada Mode" (info "ada-mode") t]
+ ["GNAT User's Guide" (info "gnat_ugn")
+ (eq ada-which-compiler 'gnat)]
+ ["GNAT Reference Manual" (info "gnat_rm")
+ (eq ada-which-compiler 'gnat)]
+ ["Gcc Documentation" (info "gcc")
+ (eq ada-which-compiler 'gnat)]
+ ["Gdb Documentation" (info "gdb")
+ (eq ada-which-compiler 'gnat)]
+ ["Ada95 Reference Manual" (info "arm95")
+ (eq ada-which-compiler 'gnat)])
+ ("Options" :included (eq major-mode 'ada-mode)
+ ["Auto Casing" (setq ada-auto-case (not ada-auto-case))
+ :style toggle :selected ada-auto-case]
+ ["Auto Indent After Return"
+ (setq ada-indent-after-return (not ada-indent-after-return))
+ :style toggle :selected ada-indent-after-return]
+ ["Automatically Recompile For Cross-references"
+ (setq ada-xref-create-ali (not ada-xref-create-ali))
+ :style toggle :selected ada-xref-create-ali
+ :included (eq ada-which-compiler 'gnat)]
+ ["Confirm Commands"
+ (setq ada-xref-confirm-compile (not ada-xref-confirm-compile))
+ :style toggle :selected ada-xref-confirm-compile
+ :included (eq ada-which-compiler 'gnat)]
+ ["Show Cross-references In Other Buffer"
+ (setq ada-xref-other-buffer (not ada-xref-other-buffer))
+ :style toggle :selected ada-xref-other-buffer
+ :included (eq ada-which-compiler 'gnat)]
+ ["Tight Integration With GNU Visual Debugger"
+ (setq ada-tight-gvd-integration (not ada-tight-gvd-integration))
+ :style toggle :selected ada-tight-gvd-integration
+ :included (string-match "gvd" ada-prj-default-debugger)])
+ ["Customize" (customize-group 'ada)
+ :included (fboundp 'customize-group)]
+ ["Check file" ada-check-current (eq ada-which-compiler 'gnat)]
+ ["Compile file" ada-compile-current (eq ada-which-compiler 'gnat)]
+ ["Build" ada-compile-application
+ (eq ada-which-compiler 'gnat)]
+ ["Run" ada-run-application t]
+ ["Debug" ada-gdb-application (eq ada-which-compiler 'gnat)]
+ ["------" nil nil]
+ ("Project"
+ :included (eq ada-which-compiler 'gnat)
+ ["Load..." ada-set-default-project-file t]
+ ["New..." ada-prj-new t]
+ ["Edit..." ada-prj-edit t])
+ ("Goto" :included (eq major-mode 'ada-mode)
+ ["Goto Declaration/Body" ada-goto-declaration
+ (eq ada-which-compiler 'gnat)]
+ ["Goto Body" ada-goto-body
+ (eq ada-which-compiler 'gnat)]
+ ["Goto Declaration Other Frame"
+ ada-goto-declaration-other-frame
+ (eq ada-which-compiler 'gnat)]
+ ["Goto Previous Reference" ada-xref-goto-previous-reference
+ (eq ada-which-compiler 'gnat)]
+ ["List Local References" ada-find-local-references
+ (eq ada-which-compiler 'gnat)]
+ ["List References" ada-find-references
+ (eq ada-which-compiler 'gnat)]
+ ["Goto Reference To Any Entity" ada-find-any-references
+ (eq ada-which-compiler 'gnat)]
+ ["Goto Parent Unit" ada-goto-parent
+ (eq ada-which-compiler 'gnat)]
+ ["--" nil nil]
+ ["Next compilation error" next-error t]
+ ["Previous Package" ada-previous-package t]
+ ["Next Package" ada-next-package t]
+ ["Previous Procedure" ada-previous-procedure t]
+ ["Next Procedure" ada-next-procedure t]
+ ["Goto Start Of Statement" ada-move-to-start t]
+ ["Goto End Of Statement" ada-move-to-end t]
+ ["-" nil nil]
+ ["Other File" ff-find-other-file t]
+ ["Other File Other Window" ada-ff-other-window t])
+ ("Edit" :included (eq major-mode 'ada-mode)
+ ["Search File On Source Path" ada-find-file t]
+ ["------" nil nil]
+ ["Complete Identifier" ada-complete-identifier t]
+ ["-----" nil nil]
+ ["Indent Line" ada-indent-current-function t]
+ ["Justify Current Indentation" ada-justified-indent-current t]
+ ["Indent Lines in Selection" ada-indent-region t]
+ ["Indent Lines in File"
+ (ada-indent-region (point-min) (point-max)) t]
+ ["Format Parameter List" ada-format-paramlist t]
+ ["-" nil nil]
+ ["Comment Selection" comment-region t]
+ ["Uncomment Selection" ada-uncomment-region t]
+ ["--" nil nil]
+ ["Fill Comment Paragraph" fill-paragraph t]
+ ["Fill Comment Paragraph Justify"
+ ada-fill-comment-paragraph-justify t]
+ ["Fill Comment Paragraph Postfix"
+ ada-fill-comment-paragraph-postfix t]
+ ["---" nil nil]
+ ["Adjust Case Selection" ada-adjust-case-region t]
+ ["Adjust Case in File" ada-adjust-case-buffer t]
+ ["Create Case Exception" ada-create-case-exception t]
+ ["Create Case Exception Substring"
+ ada-create-case-exception-substring t]
+ ["Reload Case Exceptions" ada-case-read-exceptions t]
+ ["----" nil nil]
+ ["Make body for subprogram" ada-make-subprogram-body t]
+ ["-----" nil nil]
+ ["Narrow to subprogram" ada-narrow-to-defun t])
+ ("Templates"
+ :included (eq major-mode 'ada-mode)
+ ["Header" ada-header t]
+ ["-" nil nil]
+ ["Package Body" ada-package-body t]
+ ["Package Spec" ada-package-spec t]
+ ["Function Spec" ada-function-spec t]
+ ["Procedure Spec" ada-procedure-spec t]
+ ["Proc/func Body" ada-subprogram-body t]
+ ["Task Body" ada-task-body t]
+ ["Task Spec" ada-task-spec t]
+ ["Declare Block" ada-declare-block t]
+ ["Exception Block" ada-exception-block t]
+ ["--" nil nil]
+ ["Entry" ada-entry t]
+ ["Entry family" ada-entry-family t]
+ ["Select" ada-select t]
+ ["Accept" ada-accept t]
+ ["Or accept" ada-or-accep t]
+ ["Or delay" ada-or-delay t]
+ ["Or terminate" ada-or-terminate t]
+ ["---" nil nil]
+ ["Type" ada-type t]
+ ["Private" ada-private t]
+ ["Subtype" ada-subtype t]
+ ["Record" ada-record t]
+ ["Array" ada-array t]
+ ["----" nil nil]
+ ["If" ada-if t]
+ ["Else" ada-else t]
+ ["Elsif" ada-elsif t]
+ ["Case" ada-case t]
+ ["-----" nil nil]
+ ["While Loop" ada-while-loop t]
+ ["For Loop" ada-for-loop t]
+ ["Loop" ada-loop t]
+ ["------" nil nil]
+ ["Exception" ada-exception t]
+ ["Exit" ada-exit t]
+ ["When" ada-when t])
+ )))
+
+ (easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode" m)
+ (easy-menu-add ada-mode-menu ada-mode-map)
+ (if (featurep 'xemacs)
+ (progn
+ (define-key ada-mode-map [menu-bar] ada-mode-menu)
+ (set 'mode-popup-menu (cons "Ada mode" ada-mode-menu))))))
+
+\f
+;; -------------------------------------------------------
+;; Commenting/Uncommenting code
+;; The following two calls are provided to enhance the standard
+;; comment-region function, which only allows uncommenting if the
+;; comment is at the beginning of a line. If the line have been re-indented,
+;; we are unable to use comment-region, which makes no sense.
+;;
+;; In addition, we provide an interface to the standard comment handling
+;; function for justifying the comments.
+;; -------------------------------------------------------
+
+(defadvice comment-region (before ada-uncomment-anywhere disable)
+ (if (and arg
+ (listp arg) ;; a prefix with \C-u is of the form '(4), whereas
+ ;; \C-u 2 sets arg to '2' (fixed by S.Leake)
+ (string= mode-name "Ada"))
+ (save-excursion
+ (let ((cs (concat "^[ \t]*" (regexp-quote comment-start))))
+ (goto-char beg)
+ (while (re-search-forward cs end t)
+ (replace-match comment-start))
+ ))))
+
+(defun ada-uncomment-region (beg end &optional arg)
+ "Delete `comment-start' at the beginning of a line in the region."
+ (interactive "r\nP")
+
+ ;; This advice is not needed anymore with Emacs21. However, for older
+ ;; versions, as well as for XEmacs, we still need to enable it.
+ (if (or (<= emacs-major-version 20) (featurep 'xemacs))
+ (progn
+ (ad-activate 'comment-region)
+ (comment-region beg end (- (or arg 2)))
+ (ad-deactivate 'comment-region))
+ (comment-region beg end (list (- (or arg 2))))
+ (ada-indent-region beg end)))
+
+(defun ada-fill-comment-paragraph-justify ()
+ "Fills current comment paragraph and justifies each line as well."
+ (interactive)
+ (ada-fill-comment-paragraph 'full))
+
+(defun ada-fill-comment-paragraph-postfix ()
+ "Fills current comment paragraph and justifies each line as well.
+Adds `ada-fill-comment-postfix' at the end of each line."
+ (interactive)
+ (ada-fill-comment-paragraph 'full t))
+
+(defun ada-fill-comment-paragraph (&optional justify postfix)
+ "Fills 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 filled and justified line.
+The paragraph is indented on the first line."
+ (interactive "P")
+
+ ;; check if inside comment or just in front a comment
+ (if (and (not (ada-in-comment-p))
+ (not (looking-at "[ \t]*--")))
+ (error "not inside comment"))
+
+ (let* (indent from to
+ (opos (point-marker))
+
+ ;; Sets this variable to nil, otherwise it prevents
+ ;; fill-region-as-paragraph to work on Emacs <= 20.2
+ (parse-sexp-lookup-properties nil)
+
+ fill-prefix
+ (fill-column (current-fill-column)))
+
+ ;; Find end of 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))
+
+ ;; We want one line above the first one, unless we are at the beginning
+ ;; of the buffer
+ (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 "--\n" to t)
+ (replace-match "\n"))
+
+ (goto-char (1- to))
+ (setq to (point-marker))
+
+ ;; Indent and justify the paragraph
+ (setq fill-prefix ada-fill-comment-prefix)
+ (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))
+ ))
+
+ ;; In Emacs <= 20.2 and XEmacs <=20.4, there is a bug, and a newline is
+ ;; inserted at the end. Delete it
+ (if (or (featurep 'xemacs)
+ (<= emacs-major-version 19)
+ (and (= emacs-major-version 20)
+ (<= emacs-minor-version 2)))
+ (progn
+ (goto-char to)
+ (end-of-line)
+ (delete-char 1)))
+
+ (goto-char opos)))
+
+
+;; ---------------------------------------------------
+;; support for find-file.el
+;; These functions are used by find-file to guess the file names from
+;; unit names, and to find the other file (spec or body) from the current
+;; file (body or spec).
+;; It is also used to find in which function we are, so as to put the
+;; cursor at the correct position.
+;; Standard Ada does not force any relation between unit names and file names,
+;; so some of these functions can only be a good approximation. However, they
+;; are also overriden in `ada-xref'.el when we know that the user is using
+;; GNAT.
+;; ---------------------------------------------------
+
+;; Overriden when we work with GNAT, to use gnatkrunch
+(defun ada-make-filename-from-adaname (adaname)
+ "Determine the filename in which ADANAME is found.
+This is a generic function, independent from any compiler."
+ (while (string-match "\\." adaname)
+ (setq adaname (replace-match "-" t t adaname)))
+ (downcase adaname)
+ )
+
+(defun ada-other-file-name ()
+ "Return the name of the other file.
+The name returned is the body if current-buffer is the spec, or the spec
+otherwise."
+
+ (let ((is-spec nil)
+ (is-body nil)
+ (suffixes ada-spec-suffixes)
+ (name (buffer-file-name)))
+
+ ;; Guess whether we have a spec or a body, and get the basename of the
+ ;; file. Since the extension may not start with '.', we can not use
+ ;; file-name-extension
+ (while (and (not is-spec)
+ suffixes)
+ (if (string-match (concat "\\(.*\\)" (car suffixes) "$") name)
+ (setq is-spec t
+ name (match-string 1 name)))
+ (setq suffixes (cdr suffixes)))
+
+ (if (not is-spec)
+ (progn
+ (setq suffixes ada-body-suffixes)
+ (while (and (not is-body)
+ suffixes)
+ (if (string-match (concat "\\(.*\\)" (car suffixes) "$") name)
+ (setq is-body t
+ name (match-string 1 name)))
+ (setq suffixes (cdr suffixes)))))
+
+ ;; If this wasn't in either list, return name itself
+ (if (not (or is-spec is-body))
+ name
+
+ ;; Else find the other possible names
+ (if is-spec
+ (setq suffixes ada-body-suffixes)
+ (setq suffixes ada-spec-suffixes))
+ (setq is-spec name)
+
+ (while suffixes
+
+ ;; If we are using project file, search for the other file in all
+ ;; the possible src directories.
+
+ (if (fboundp 'ada-find-src-file-in-dir)
+ (let ((other
+ (ada-find-src-file-in-dir
+ (file-name-nondirectory (concat name (car suffixes))))))
+ (if other
+ (set 'is-spec other)))
+
+ ;; Else search in the current directory
+ (if (file-exists-p (concat name (car suffixes)))
+ (setq is-spec (concat name (car suffixes)))))
+ (setq suffixes (cdr suffixes)))
+
+ is-spec)))
+
+(defun ada-which-function-are-we-in ()
+ "Return the name of the function whose definition/declaration point is in.
+Redefines the function `ff-which-function-are-we-in'."
+ (setq ff-function-name nil)
+ (save-excursion
+ (end-of-line);; make sure we get the complete name
+ (if (or (re-search-backward ada-procedure-start-regexp nil t)
+ (re-search-backward ada-package-start-regexp nil t))
+ (setq ff-function-name (match-string 0)))
+ ))
+
+
+(defvar ada-last-which-function-line -1
+ "Last on which ada-which-function was called")
+(defvar ada-last-which-function-subprog 0
+ "Last subprogram name returned by ada-which-function")
+(make-variable-buffer-local 'ada-last-which-function-subprog)
+(make-variable-buffer-local 'ada-last-which-function-line)
+
+
+(defun ada-which-function ()
+ "Returns the name of the function whose body the point is in.
+This function works even in the case of nested subprograms, whereas the
+standard Emacs function `which-function' does not.
+Since the search can be long, the results are cached."
+
+ (let ((line (count-lines 1 (point)))
+ (pos (point))
+ end-pos
+ func-name indent
+ found)
+
+ ;; If this is the same line as before, simply return the same result
+ (if (= line ada-last-which-function-line)
+ ada-last-which-function-subprog
+
+ (save-excursion
+ ;; In case the current line is also the beginning of the body
+ (end-of-line)
+
+ ;; Are we looking at "function Foo\n (paramlist)"
+ (skip-chars-forward " \t\n(")
+
+ (condition-case nil
+ (up-list 1)
+ (error nil))
+
+ (skip-chars-forward " \t\n")
+ (if (looking-at "return")
+ (progn
+ (forward-word 1)
+ (skip-chars-forward " \t\n")
+ (skip-chars-forward "a-zA-Z0-9_'")))
+
+ ;; Can't simply do forward-word, in case the "is" is not on the
+ ;; same line as the closing parenthesis
+ (skip-chars-forward "is \t\n")
+
+ ;; No look for the closest subprogram body that has not ended yet.
+ ;; Not that we expect all the bodies to be finished by "end <name>",
+ ;; or a simple "end;" indented in the same column as the start of
+ ;; the subprogram. The goal is to be as efficient as possible.
+
+ (while (and (not found)
+ (re-search-backward ada-imenu-subprogram-menu-re nil t))
+
+ ;; Get the function name, but not the properties, or this changes
+ ;; the face in the modeline on Emacs 21
+ (setq func-name (match-string-no-properties 2))
+ (if (and (not (ada-in-comment-p))
+ (not (save-excursion
+ (goto-char (match-end 0))
+ (looking-at "[ \t\n]*new"))))
+ (save-excursion
+ (back-to-indentation)
+ (setq indent (current-column))
+ (if (ada-search-ignore-string-comment
+ (concat "end[ \t]+" func-name "[ \t]*;\\|^"
+ (make-string indent ? ) "end;"))
+ (setq end-pos (point))
+ (setq end-pos (point-max)))
+ (if (>= end-pos pos)
+ (setq found func-name))))
+ )
+ (setq ada-last-which-function-line line
+ ada-last-which-function-subprog found)
+ found))))
+
+(defun ada-ff-other-window ()
+ "Find other file in other window using `ff-find-other-file'."
+ (interactive)
+ (and (fboundp 'ff-find-other-file)
+ (ff-find-other-file t)))
+
+(defun ada-set-point-accordingly ()
+ "Move to the function declaration that was set by
+`ff-which-function-are-we-in'."
+ (if ff-function-name
+ (progn
+ (goto-char (point-min))
+ (unless (ada-search-ignore-string-comment
+ (concat ff-function-name "\\b") nil)
+ (goto-char (point-min))))))
+
+(defun ada-get-body-name (&optional spec-name)
+ "Returns the file name for the body of SPEC-NAME.
+If SPEC-NAME is nil, returns the body for the current package.
+Returns nil if no body was found."
+ (interactive)
+
+ (unless spec-name (setq spec-name (buffer-file-name)))
+
+ ;; Remove the spec extension. We can not simply remove the file extension,
+ ;; but we need to take into account the specific non-GNAT extensions that the
+ ;; user might have specified.
+
+ (let ((suffixes ada-spec-suffixes)
+ end)
+ (while suffixes
+ (setq end (- (length spec-name) (length (car suffixes))))
+ (if (string-equal (car suffixes) (substring spec-name end))
+ (setq spec-name (substring spec-name 0 end)))
+ (setq suffixes (cdr suffixes))))
+
+ ;; If find-file.el was available, use its functions
+ (if (fboundp 'ff-get-file-name)
+ (ff-get-file-name ada-search-directories-internal
+ (ada-make-filename-from-adaname
+ (file-name-nondirectory
+ (file-name-sans-extension spec-name)))
+ ada-body-suffixes)
+ ;; Else emulate it very simply
+ (concat (ada-make-filename-from-adaname
+ (file-name-nondirectory
+ (file-name-sans-extension spec-name)))
+ ".adb")))
+
+\f
+;; ---------------------------------------------------
+;; support for font-lock.el
+;; Strings are a real pain in Ada because a single quote character is
+;; overloaded as a string quote and type/instance delimiter. By default, a
+;; single quote is given punctuation syntax in `ada-mode-syntax-table'.
+;; So, for Font Lock mode purposes, we mark single quotes as having string
+;; syntax when the gods that created Ada determine them to be.
+;;
+;; This only works in Emacs. See the comments before the grammar functions
+;; at the beginning of this file for how this is done with XEmacs.
+;; ----------------------------------------------------
+
+(defconst ada-font-lock-syntactic-keywords
+ ;; Mark single quotes as having string quote syntax in 'c' instances.
+ ;; As a special case, ''' will not be highlighted, but if we do not
+ ;; set this special case, then the rest of the buffer is highlighted as
+ ;; a string
+ ;; This sets the properties of the characters, so that ada-in-string-p
+ ;; correctly handles '"' too...
+ '(("[^a-zA-Z0-9)]\\('\\)[^'\n]\\('\\)" (1 (7 . ?')) (2 (7 . ?')))
+ ("^[ \t]*\\(#\\(if\\|else\\|elsif\\|end\\)\\)" (1 (11 . ?\n)))
+ ))
+
+(defvar ada-font-lock-keywords
+ (eval-when-compile
+ (list
+ ;;
+ ;; handle "type T is access function return S;"
+ (list "\\<\\(function[ \t]+return\\)\\>" '(1 font-lock-keyword-face) )
+
+ ;; preprocessor line
+ (list "^[ \t]*\\(#.*\n\\)" '(1 font-lock-type-face t))
+
+ ;;
+ ;; accept, entry, function, package (body), protected (body|type),
+ ;; pragma, procedure, task (body) plus name.
+ (list (concat
+ "\\<\\("
+ "accept\\|"
+ "entry\\|"
+ "function\\|"
+ "package[ \t]+body\\|"
+ "package\\|"
+ "pragma\\|"
+ "procedure\\|"
+ "protected[ \t]+body\\|"
+ "protected[ \t]+type\\|"
+ "protected\\|"
+ "task[ \t]+body\\|"
+ "task[ \t]+type\\|"
+ "task"
+ "\\)\\>[ \t]*"
+ "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
+ '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t))
+ ;;
+ ;; Optional keywords followed by a type name.
+ (list (concat ; ":[ \t]*"
+ "\\<\\(access[ \t]+all\\|access[ \t]+constant\\|access\\|constant\\|in[ \t]+reverse\\|\\|in[ \t]+out\\|in\\|out\\)\\>"
+ "[ \t]*"
+ "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
+ '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t))
+
+ ;;
+ ;; Main keywords, except those treated specially below.
+ (concat "\\<"
+ (regexp-opt
+ '("abort" "abs" "abstract" "accept" "access" "aliased" "all"
+ "and" "array" "at" "begin" "case" "declare" "delay" "delta"
+ "digits" "do" "else" "elsif" "entry" "exception" "exit" "for"
+ "generic" "if" "in" "is" "limited" "loop" "mod" "not"
+ "null" "or" "others" "private" "protected" "raise"
+ "range" "record" "rem" "renames" "requeue" "return" "reverse"
+ "select" "separate" "tagged" "task" "terminate" "then" "until"
+ "when" "while" "with" "xor") t)
+ "\\>")
+ ;;
+ ;; Anything following end and not already fontified is a body name.
+ '("\\<\\(end\\)\\>\\([ \t]+\\)?\\(\\(\\sw\\|[_.]\\)+\\)?"
+ (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t))
+ ;;
+ ;; Keywords followed by a type or function name.
+ (list (concat "\\<\\("
+ "new\\|of\\|subtype\\|type"
+ "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?[ \t]*\\((\\)?")
+ '(1 font-lock-keyword-face)
+ '(2 (if (match-beginning 4)
+ font-lock-function-name-face
+ font-lock-type-face) nil t))
+ ;;
+ ;; Keywords followed by a (comma separated list of) reference.
+ ;; Note that font-lock only works on single lines, thus we can not
+ ;; correctly highlight a with_clause that spans multiple lines.
+ (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)"
+ "[ \t]+\\([a-zA-Z0-9_., \t]+\\)\\W")
+ '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t))
+
+ ;;
+ ;; Goto tags.
+ '("<<\\(\\sw+\\)>>" 1 font-lock-reference-face)
+
+ ;; Highlight based-numbers (R. Reagan <robin-reply@reagans.org>)
+ (list "\\([0-9]+#[0-9a-fA-F_]+#\\)" '(1 font-lock-constant-face t))
+
+ ;; Ada unnamed numerical constants
+ (list "\\W\\([-+]?[0-9._]+\\)\\>" '(1 font-lock-constant-face))
+
+ ))
+ "Default expressions to highlight in Ada mode.")
+
+
+;; ---------------------------------------------------------
+;; Support for outline.el
+;; ---------------------------------------------------------
+
+(defun ada-outline-level ()
+ "This is so that `current-column` DTRT in otherwise-hidden text"
+ ;; patch from Dave Love <fx@gnu.org>
+ (let (buffer-invisibility-spec)
+ (save-excursion
+ (back-to-indentation)
+ (current-column))))
+
+;; ---------------------------------------------------------
+;; Support for narrow-to-region
+;; ---------------------------------------------------------
+
+(defun ada-narrow-to-defun (&optional arg)
+ "make text outside current subprogram invisible.
+The subprogram visible is the one that contains or follow point.
+Optional ARG is ignored.
+Use `M-x widen' to go back to the full visibility for the buffer"
+
+ (interactive)
+ (save-excursion
+ (let (end)
+ (widen)
+ (forward-line 1)
+ (ada-previous-procedure)
+
+ (save-excursion
+ (beginning-of-line)
+ (setq end (point)))
+
+ (ada-move-to-end)
+ (end-of-line)
+ (narrow-to-region end (point))
+ (message
+ "Use M-x widen to get back to full visibility in the buffer"))))
+
+;; ---------------------------------------------------------
+;; Automatic generation of code
+;; The Ada-mode has a set of function to automatically generate a subprogram
+;; or package body from its spec.
+;; These function only use a primary and basic algorithm, this could use a
+;; lot of improvement.
+;; When the user is using GNAT, we rather use gnatstub to generate an accurate
+;; body.
+;; ----------------------------------------------------------
+
+(defun ada-gen-treat-proc (match)
+ "Make dummy body of a procedure/function specification.
+MATCH is a cons cell containing the start and end location of the last search
+for ada-procedure-start-regexp."
+ (goto-char (car match))
+ (let (func-found procname functype)
+ (cond
+ ((or (looking-at "^[ \t]*procedure")
+ (setq func-found (looking-at "^[ \t]*function")))
+ ;; treat it as a proc/func
+ (forward-word 2)
+ (forward-word -1)
+ (setq procname (buffer-substring (point) (cdr match))) ; store proc name
+
+ ;; goto end of procname
+ (goto-char (cdr match))
+
+ ;; skip over parameterlist
+ (unless (looking-at "[ \t\n]*\\(;\\|return\\)")
+ (forward-sexp))
+
+ ;; if function, skip over 'return' and result type.
+ (if func-found
+ (progn
+ (forward-word 1)
+ (skip-chars-forward " \t\n")
+ (setq functype (buffer-substring (point)
+ (progn
+ (skip-chars-forward
+ "a-zA-Z0-9_\.")
+ (point))))))
+ ;; look for next non WS
+ (cond
+ ((looking-at "[ \t]*;")
+ (delete-region (match-beginning 0) (match-end 0));; delete the ';'
+ (ada-indent-newline-indent)
+ (insert "is")
+ (ada-indent-newline-indent)
+ (if func-found
+ (progn
+ (insert "Result : " functype ";")
+ (ada-indent-newline-indent)))
+ (insert "begin")
+ (ada-indent-newline-indent)
+ (if func-found
+ (insert "return Result;")
+ (insert "null;"))
+ (ada-indent-newline-indent)
+ (insert "end " procname ";")
+ (ada-indent-newline-indent)
+ )
+ ;; else
+ ((looking-at "[ \t\n]*is")
+ ;; do nothing
+ )
+ ((looking-at "[ \t\n]*rename")
+ ;; do nothing
+ )
+ (t
+ (message "unknown syntax"))))
+ (t
+ (if (looking-at "^[ \t]*task")
+ (progn
+ (message "Task conversion is not yet implemented")
+ (forward-word 2)
+ (if (looking-at "[ \t]*;")
+ (forward-line)
+ (ada-move-to-end))
+ ))))))
+
+(defun ada-make-body ()
+ "Create an Ada package body in the current buffer.
+The potential old buffer contents is deleted first, then we copy the
+spec buffer in here and modify it to make it a body.
+This function typically is to be hooked into `ff-file-created-hooks'."
+ (interactive)
+ (delete-region (point-min) (point-max))
+ (insert-buffer (car (cdr (buffer-list))))
+ (ada-mode)
+
+ (let (found ada-procedure-or-package-start-regexp)
+ (if (setq found
+ (ada-search-ignore-string-comment ada-package-start-regexp nil))
+ (progn (goto-char (cdr found))
+ (insert " body")
+ )
+ (error "No package"))
+
+ (setq ada-procedure-or-package-start-regexp
+ (concat ada-procedure-start-regexp
+ "\\|"
+ ada-package-start-regexp))
+
+ (while (setq found
+ (ada-search-ignore-string-comment
+ ada-procedure-or-package-start-regexp nil))
+ (progn
+ (goto-char (car found))
+ (if (looking-at ada-package-start-regexp)
+ (progn (goto-char (cdr found))
+ (insert " body"))
+ (ada-gen-treat-proc found))))))
+
+
+(defun ada-make-subprogram-body ()
+ "Make one dummy subprogram body from spec surrounding point."
+ (interactive)
+ (let* ((found (re-search-backward ada-procedure-start-regexp nil t))
+ (spec (match-beginning 0))
+ body-file)
+ (if found
+ (progn
+ (goto-char spec)
+ (if (and (re-search-forward "(\\|;" nil t)
+ (= (char-before) ?\())
+ (progn
+ (ada-search-ignore-string-comment ")" nil)
+ (ada-search-ignore-string-comment ";" nil)))
+ (setq spec (buffer-substring spec (point)))
+
+ ;; If find-file.el was available, use its functions
+ (setq body-file (ada-get-body-name))
+ (if body-file
+ (find-file body-file)
+ (error "No body found for the package. Create it first."))
+
+ (save-restriction
+ (widen)
+ (goto-char (point-max))
+ (forward-comment -10000)
+ (re-search-backward "\\<end\\>" nil t)
+ ;; Move to the beginning of the elaboration part, if any
+ (re-search-backward "^begin" nil t)
+ (newline)
+ (forward-char -1)
+ (insert spec)
+ (re-search-backward ada-procedure-start-regexp nil t)
+ (ada-gen-treat-proc (cons (match-beginning 0) (match-end 0)))
+ ))
+ (error "Not in subprogram spec"))))
+
+;; --------------------------------------------------------
+;; Global initializations
+;; --------------------------------------------------------
+
+;; Create the keymap once and for all. If we do that in ada-mode,
+;; the keys changed in the user's .emacs have to be modified
+;; every time
+(ada-create-keymap)
+(ada-create-menu)
+
+;; Create the syntax tables, but do not activate them
+(ada-create-syntax-table)
+
+;; Add the default extensions (and set up speedbar)
+(ada-add-extensions ".ads" ".adb")
+;; This two files are generated by GNAT when running with -gnatD
+(if (equal ada-which-compiler 'gnat)
+ (ada-add-extensions ".ads.dg" ".adb.dg"))
+
+;; Read the special cases for exceptions
+(ada-case-read-exceptions)
+
+;; Setup auto-loading of the other ada-mode files.
+(if (equal ada-which-compiler 'gnat)
+ (progn
+ (autoload 'ada-change-prj "ada-xref" nil t)
+ (autoload 'ada-check-current "ada-xref" nil t)
+ (autoload 'ada-compile-application "ada-xref" nil t)
+ (autoload 'ada-compile-current "ada-xref" nil t)
+ (autoload 'ada-complete-identifier "ada-xref" nil t)
+ (autoload 'ada-find-file "ada-xref" nil t)
+ (autoload 'ada-find-any-references "ada-xref" nil t)
+ (autoload 'ada-find-src-file-in-dir "ada-xref" nil t)
+ (autoload 'ada-find-local-references "ada-xref" nil t)
+ (autoload 'ada-find-references "ada-xref" nil t)
+ (autoload 'ada-gdb-application "ada-xref" nil t)
+ (autoload 'ada-goto-declaration "ada-xref" nil t)
+ (autoload 'ada-goto-declaration-other-frame "ada-xref" nil t)
+ (autoload 'ada-goto-parent "ada-xref" nil t)
+ (autoload 'ada-make-body-gnatstub "ada-xref" nil t)
+ (autoload 'ada-point-and-xref "ada-xref" nil t)
+ (autoload 'ada-reread-prj-file "ada-xref" nil t)
+ (autoload 'ada-run-application "ada-xref" nil t)
+ (autoload 'ada-set-default-project-file "ada-xref" nil nil)
+ (autoload 'ada-set-default-project-file "ada-xref" nil t)
+ (autoload 'ada-xref-goto-previous-reference "ada-xref" nil t)
+
+ (autoload 'ada-customize "ada-prj" nil t)
+ (autoload 'ada-prj-edit "ada-prj" nil t)
+ (autoload 'ada-prj-new "ada-prj" nil t)
+ (autoload 'ada-prj-save "ada-prj" nil t)
+ ))
+
+(autoload 'ada-array "ada-stmt" nil t)
+(autoload 'ada-case "ada-stmt" nil t)
+(autoload 'ada-declare-block "ada-stmt" nil t)
+(autoload 'ada-else "ada-stmt" nil t)
+(autoload 'ada-elsif "ada-stmt" nil t)
+(autoload 'ada-exception "ada-stmt" nil t)
+(autoload 'ada-exception-block "ada-stmt" nil t)
+(autoload 'ada-exit "ada-stmt" nil t)
+(autoload 'ada-for-loop "ada-stmt" nil t)
+(autoload 'ada-function-spec "ada-stmt" nil t)
+(autoload 'ada-header "ada-stmt" nil t)
+(autoload 'ada-if "ada-stmt" nil t)
+(autoload 'ada-loop "ada-stmt" nil t)
+(autoload 'ada-package-body "ada-stmt" nil t)
+(autoload 'ada-package-spec "ada-stmt" nil t)
+(autoload 'ada-private "ada-stmt" nil t)
+(autoload 'ada-procedure-spec "ada-stmt" nil t)
+(autoload 'ada-record "ada-stmt" nil t)
+(autoload 'ada-subprogram-body "ada-stmt" nil t)
+(autoload 'ada-subtype "ada-stmt" nil t)
+(autoload 'ada-tabsize "ada-stmt" nil t)
+(autoload 'ada-task-body "ada-stmt" nil t)
+(autoload 'ada-task-spec "ada-stmt" nil t)
+(autoload 'ada-type "ada-stmt" nil t)
+(autoload 'ada-use "ada-stmt" nil t)
+(autoload 'ada-when "ada-stmt" nil t)
+(autoload 'ada-while-loop "ada-stmt" nil t)
+(autoload 'ada-with "ada-stmt" nil t)
+
+;;; provide ourselves
+(provide 'ada-mode)
+
+;;; ada-mode.el ends here
HCoop / bpt / emacs.git / blobdiff