diff options
| author | Daniel <[email protected]> | 2024-04-20 11:19:15 -0400 |
|---|---|---|
| committer | Daniel <[email protected]> | 2024-04-20 11:19:15 -0400 |
| commit | 0172b10b8b0f352fdc45757abfe7fdf2a4d03960 (patch) | |
| tree | ef5100d059c4dc06dfcb4844454cd1aaba1b0281 /old_ada/ada-mode.el | |
| parent | b139c8ff5cd3d784d3b462012a1911f00b6c4542 (diff) | |
rename old-ada dir
Diffstat (limited to 'old_ada/ada-mode.el')
| -rw-r--r-- | old_ada/ada-mode.el | 5494 |
1 files changed, 0 insertions, 5494 deletions
diff --git a/old_ada/ada-mode.el b/old_ada/ada-mode.el deleted file mode 100644 index b7f0535..0000000 --- a/old_ada/ada-mode.el +++ /dev/null @@ -1,5494 +0,0 @@ -;;; ada-mode.el --- major-mode for editing Ada sources - -;; Copyright (C) 1994-1995, 1997-2019 Free Software Foundation, Inc. - -;; Author: Rolf Ebert <[email protected]> -;; Markus Heritsch <[email protected]> -;; Emmanuel Briot <[email protected]> -;; Maintainer: Stephen Leake <[email protected]> -;; Keywords: languages ada -;; Version: 4.0 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: -;; This mode is a major mode for editing Ada 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. - -;;; 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. - -;;; Credits: -;; Many thanks to John McCabe <[email protected]> for sending so -;; many patches included in this package. -;; Christian Egli <[email protected]>: -;; ada-imenu-generic-expression -;; Many thanks also to the following persons that have contributed -;; to the ada-mode -;; Philippe Waroquiers (PW) <[email protected]> in particular, -;; [email protected] (John Woodruff) -;; [email protected] (Jesper Joergensen) -;; [email protected] (Scott Evans) -;; [email protected] (Cyrille Comar) -;; [email protected] (Stephen Leake) -;; 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 in the mode line the name of the subprogram -;; the cursor is in. -;; `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. - -(require 'find-file nil t) -(require 'align nil t) -(require 'which-func nil t) -(require 'compile nil t) - -(defvar ispell-check-comments) -(defvar skeleton-further-elements) - -(define-error 'ada-mode-errors nil) - -(defun ada-mode-version () - "Return Ada mode version." - (interactive) - (let ((version-string "4.00")) - (if (called-interactively-p 'interactive) - (message version-string) - version-string))) - -(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 and compiling Ada source in Emacs." - :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) - :link '(custom-manual "(ada-mode) Top") - :link '(emacs-commentary-link :tag "Commentary" "ada-mode.el") - :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;" - :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);" - :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) -(make-obsolete-variable 'ada-clean-buffer-before-saving - "it has no effect - use `write-file-functions' hook." - "23.2") - - -(defcustom ada-indent 3 - "Size of Ada indentation. - -An example is : -procedure Foo is -begin ->>>>>>>>>>null;" - :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. -A nil value 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" - :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; - >>>renames Foo;" - :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;" - :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. -Used by `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: - -This is also used for <<..>> labels" - :type 'integer :group 'ada) - -(defcustom ada-language-version 'ada95 - "Ada language version; one of `ada83', `ada95', `ada2005'." - :type '(choice (const ada83) (const ada95) (const ada2005)) :group 'ada) - -(defcustom ada-move-to-declaration nil - "Non-nil means `ada-move-to-start' moves 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")) - "Default list of directories to search for Ada files. -See the description for the `ff-search-directories' variable. This variable -is the initial value of `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" - :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;" - :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 =>" - :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;" - :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 - - -(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-extra-map (make-sparse-keymap) - "Keymap used for non-standard keybindings.") - -;; default is C-c C-q because it's free in ada-mode-map -(defvar ada-mode-extra-prefix "\C-c\C-q" - "Prefix key to access `ada-mode-extra-map' functions.") - -(define-abbrev-table 'ada-mode-abbrev-table () - "Local abbrev table for Ada mode.") - -(eval-when-compile - ;; These values are used in eval-when-compile expressions. - (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 83 keywords. -Used to define `ada-*-keywords'.") - - (defconst ada-95-string-keywords - '("abstract" "aliased" "protected" "requeue" "tagged" "until") - "List of keywords new in Ada 95. -Used to define `ada-*-keywords'.") - - (defconst ada-2005-string-keywords - '("interface" "overriding" "synchronized") - "List of keywords new in Ada 2005. -Used to define `ada-*-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 constituent 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 - (eval-when-compile - (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 matching Ada83 keywords.") - -(defconst ada-95-keywords - (eval-when-compile - (concat "\\<" (regexp-opt - (append - ada-95-string-keywords - ada-83-string-keywords) t) "\\>")) - "Regular expression matching Ada95 keywords.") - -(defconst ada-2005-keywords - (eval-when-compile - (concat "\\<" (regexp-opt - (append - ada-2005-string-keywords - ada-83-string-keywords - ada-95-string-keywords) t) "\\>")) - "Regular expression matching Ada2005 keywords.") - -(defvar ada-keywords ada-2005-keywords - "Regular expression matching Ada keywords.") -;; FIXME: make this customizable - -(defconst ada-ident-re - "[[:alpha:]]\\(?:[_[:alnum:]]\\)*" - ;; [:alnum:] matches any multibyte word constituent, as well as - ;; Latin-1 letters and numbers. This allows __ and trailing _; - ;; someone (emacs bug#1919) proposed [^\W_] to fix that, but \W does - ;; _not_ mean "not word constituent" inside a character alternative. - "Regexp matching an Ada identifier.") - -(defconst ada-goto-label-re - (concat "<<" ada-ident-re ">>") - "Regexp matching a goto label.") - -(defconst ada-block-label-re - (concat ada-ident-re "[ \t\n]*:[^=]") - "Regexp matching a block label. -Note that this also matches a variable declaration.") - -(defconst ada-label-re - (concat "\\(?:" ada-block-label-re "\\)\\|\\(?:" ada-goto-label-re "\\)") - "Regexp matching a goto or block label.") - -;; "with" needs to be included in the regexp, to match generic subprogram parameters -;; Similarly, we put '[not] overriding' on the same line with 'procedure' etc. -(defvar ada-procedure-start-regexp - (concat - "^[ \t]*\\(with[ \t]+\\)?\\(\\(not[ \t]+\\)?overriding[ \t]+\\)?\\(procedure\\|function\\|task\\)[ \t\n]+" - - ;; subprogram name: operator ("[+/=*]") - "\\(" - "\\(\"[^\"]+\"\\)" - - ;; subprogram name: name - "\\|" - "\\(\\(\\sw\\|[_.]\\)+\\)" - "\\)") - "Regexp matching Ada subprogram start. -The actual start is at (match-beginning 4). The name is in (match-string 5).") - -(defconst ada-name-regexp - "\\([a-zA-Z][a-zA-Z0-9_.']*[a-zA-Z0-9]\\)" - "Regexp matching a fully qualified name (including attribute).") - -(defconst ada-package-start-regexp - (concat "^[ \t]*\\(private[ \t]+\\)?\\(package\\)[ \t\n]+\\(body[ \t]*\\)?" ada-name-regexp) - "Regexp matching start of package. -The package name is in (match-string 4).") - -(defconst ada-compile-goto-error-file-linenr-re - "\\([-_.a-zA-Z0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?" - "Regexp matching filename:linenr[:column].") - - -;;; ---- 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]*--.*$" "\\|" - "^[ \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" "declare" - "if" "task" "package" "procedure" "function" "record" "protected") t) - "\\>")) - "Regexp used in `ada-goto-matching-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" "overriding" "package" "procedure" - "protected" "task") t) "\\>")) - "Regexp for the start of a subprogram.") - -(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])) - - -;;------------------------------------------------------------------ -;; Support for imenu (see imenu.el) -;;------------------------------------------------------------------ - -(defconst ada-imenu-comment-re "\\([ \t]*--.*\\)?") - -(defconst ada-imenu-subprogram-menu-re - (concat "^[ \t]*\\(overriding[ \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 3) - (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.") - - -;;------------------------------------------------------------ -;; 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) - "Replace `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 these lines: - foo.adb:61:11: [...] in call to size declared at foo.ads:11 - foo.adb:61:11: [...] in call to local declared at line 20 -the 4 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 - ;; or a simple line reference "at line ..." - ((and (not (bolp)) - (or (looking-at ada-compile-goto-error-file-linenr-re) - (and - (save-excursion - (beginning-of-line) - (looking-at ada-compile-goto-error-file-linenr-re)) - (save-excursion - (if (looking-at "\\([0-9]+\\)") (backward-word-strictly 1)) - (looking-at "line \\([0-9]+\\)")))) - ) - (let ((line (if (match-beginning 2) (match-string 2) (match-string 1))) - (file (if (match-beginning 2) (match-string 1) - (save-excursion (beginning-of-line) - (looking-at ada-compile-goto-error-file-linenr-re) - (match-string 1)))) - (error-pos (point-marker)) - source) - - ;; set source marker - (save-excursion - (compilation-find-file (point-marker) (match-string 1) "./") - (set-buffer file) - - (when (stringp line) - (goto-char (point-min)) - (forward-line (1- (string-to-number line)))) - - (setq source (point-marker))) - - (compilation-goto-locus error-pos source nil) - - )) - - ;; otherwise, default behavior - (t - (compile-goto-error)) - ) - (recenter)) - - -;;------------------------------------------------------------------------- -;; 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 literal 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 -;; corresponding action is applied automatically each time the buffer -;; changes via syntax-propertize-function. -;; -;; 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. -;;------------------------------------------------------------------------- - -(defvar ada-mode-syntax-table - (let ((st (make-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 ?% "$" st) - (modify-syntax-entry ?\" "\"" st) - - (modify-syntax-entry ?: "." st) - (modify-syntax-entry ?\; "." st) - (modify-syntax-entry ?& "." st) - (modify-syntax-entry ?\| "." st) - (modify-syntax-entry ?+ "." st) - (modify-syntax-entry ?* "." st) - (modify-syntax-entry ?/ "." st) - (modify-syntax-entry ?= "." st) - (modify-syntax-entry ?< "." st) - (modify-syntax-entry ?> "." st) - (modify-syntax-entry ?$ "." st) - (modify-syntax-entry ?\[ "." st) - (modify-syntax-entry ?\] "." st) - (modify-syntax-entry ?\{ "." st) - (modify-syntax-entry ?\} "." st) - (modify-syntax-entry ?. "." st) - (modify-syntax-entry ?\\ "." st) - (modify-syntax-entry ?\' "." st) - - ;; A single hyphen is punctuation, but a double hyphen starts a comment. - (modify-syntax-entry ?- ". 12" st) - - ;; See the comment above on grammar related function for the special - ;; setup for '#'. - (modify-syntax-entry ?# (if (featurep 'xemacs) "<" "$") st) - - ;; And \f and \n end a comment. - (modify-syntax-entry ?\f "> " st) - (modify-syntax-entry ?\n "> " st) - - ;; Define what belongs in Ada symbols. - (modify-syntax-entry ?_ "_" st) - - ;; Define parentheses to match. - (modify-syntax-entry ?\( "()" st) - (modify-syntax-entry ?\) ")(" st) - st) - "Syntax table to be used for editing Ada source code.") - -(defvar ada-mode-symbol-syntax-table - (let ((st (make-syntax-table ada-mode-syntax-table))) - (modify-syntax-entry ?_ "w" st) - st) - "Syntax table for Ada, where `_' is a word constituent.") - -;; 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 "\\(#[[:xdigit:]]*#\\)" 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))))))) - -(unless (eval-when-compile (fboundp 'syntax-propertize-via-font-lock)) - ;; Before `syntax-propertize', we had to use font-lock to apply syntax-table - ;; properties, and in some cases we even had to do it manually (in - ;; `ada-after-change-function'). `ada-handle-syntax-table-properties' - ;; decides which method to use. - -(defun ada-set-syntax-table-properties () - "Assign `syntax-table' properties in accessible part of buffer. -In particular, character constants are said to be strings, #...# -are treated as numbers instead of gnatprep comments." - (let ((modified (buffer-modified-p)) - (buffer-undo-list t) - (inhibit-read-only t) - (inhibit-point-motion-hooks t) - (inhibit-modification-hooks t)) - (remove-text-properties (point-min) (point-max) '(syntax-table nil)) - (goto-char (point-min)) - (while (re-search-forward - ;; The following regexp was adapted from - ;; `ada-font-lock-syntactic-keywords'. - "^[ \t]*\\(#\\(?:if\\|else\\|elsif\\|end\\)\\)\\|[^a-zA-Z0-9)]\\('\\)[^'\n]\\('\\)" - nil t) - (if (match-beginning 1) - (put-text-property - (match-beginning 1) (match-end 1) 'syntax-table '(11 . ?\n)) - (put-text-property - (match-beginning 2) (match-end 2) 'syntax-table '(7 . ?')) - (put-text-property - (match-beginning 3) (match-end 3) 'syntax-table '(7 . ?')))) - (unless modified - (restore-buffer-modified-p nil)))) - -(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." - (save-excursion - (save-restriction - (let ((from (progn (goto-char beg) (line-beginning-position))) - (to (progn (goto-char end) (line-end-position)))) - (narrow-to-region from to) - (save-match-data - (ada-set-syntax-table-properties)))))) - -(defun ada-initialize-syntax-table-properties () - "Assign `syntax-table' properties in current buffer." - (save-excursion - (save-restriction - (widen) - (save-match-data - (ada-set-syntax-table-properties)))) - (add-hook 'after-change-functions 'ada-after-change-function nil t)) - -(defun ada-handle-syntax-table-properties () - "Handle `syntax-table' properties." - (if font-lock-mode - ;; `font-lock-mode' will take care of `syntax-table' properties. - (remove-hook 'after-change-functions 'ada-after-change-function t) - ;; Take care of `syntax-table' properties manually. - (ada-initialize-syntax-table-properties))) - -) ;;(not (fboundp 'syntax-propertize)) - -;;------------------------------------------------------------------ -;; Testing the grammatical context -;;------------------------------------------------------------------ - -(defsubst ada-in-comment-p (&optional parse-result) - "Return t if inside a comment. -If PARSE-RESULT is non-nil, use it instead of calling `parse-partial-sexp'." - (nth 4 (or parse-result - (parse-partial-sexp - (line-beginning-position) (point))))) - -(defsubst ada-in-string-p (&optional parse-result) - "Return t if point is inside a string. -If PARSE-RESULT is non-nil, use it instead of calling `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) - "Return t if inside a comment or string. -If PARSE-RESULT is non-nil, use it instead of calling `parse-partial-sexp'." - (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))) - -(defsubst ada-in-numeric-literal-p () - "Return t if point is after a prefix of a numeric literal." - (looking-back "\\([0-9]+#[[:xdigit:]_]+\\)" (line-beginning-position))) - -;;------------------------------------------------------------------ -;; 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)))) - -(defvar ada-font-lock-syntactic-keywords) ; defined below - -;;;###autoload -(define-derived-mode ada-mode prog-mode "Ada" - "Ada mode is the major mode for editing Ada code." - - ;; 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) - (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)) - - (setq case-fold-search t) - (if (boundp 'imenu-case-fold-search) - (setq imenu-case-fold-search t)) - - (set (make-local-variable 'fill-paragraph-function) - 'ada-fill-comment-paragraph) - - ;; Support for compile.el - ;; We just substitute our own functions to go to the error. - (add-hook 'compilation-mode-hook - (lambda() - ;; 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 : - - (set (make-local-variable 'font-lock-defaults) - '(ada-font-lock-keywords - nil t - ((?\_ . "w") (?# . ".")) - beginning-of-line)) - - (if (eval-when-compile (fboundp 'syntax-propertize-via-font-lock)) - (set (make-local-variable 'syntax-propertize-function) - (syntax-propertize-via-font-lock ada-font-lock-syntactic-keywords)) - (set (make-local-variable '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) - - (make-local-variable 'ff-special-constructs) - (mapc (lambda (pair) (add-to-list 'ff-special-constructs pair)) - (list - ;; Top level child package declaration; go to the parent package. - (cons (eval-when-compile - (concat "^\\(private[ \t]\\)?[ \t]*package[ \t]+" - "\\(body[ \t]+\\)?" - "\\(\\(\\sw\\|[_.]\\)+\\)\\.\\(\\sw\\|_\\)+[ \t\n]+is")) - (lambda () - (ff-get-file - ada-search-directories-internal - (ada-make-filename-from-adaname (match-string 3)) - ada-spec-suffixes))) - - ;; A "separate" clause. - (cons "^separate[ \t\n]*(\\(\\(\\sw\\|[_.]\\)+\\))" - (lambda () - (ff-get-file - ada-search-directories-internal - (ada-make-filename-from-adaname (match-string 1)) - ada-spec-suffixes))) - - ;; A "with" clause. - (cons "^with[ \t]+\\([a-zA-Z0-9_\\.]+\\)" - (lambda () - (ff-get-file - ada-search-directories-internal - (ada-make-filename-from-adaname (match-string 1)) - ada-spec-suffixes))) - )) - - ;; 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-generic-expression ada-imenu-generic-expression) - - (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 - (add-to-list 'align-dq-string-modes 'ada-mode) - (add-to-list 'align-open-comment-modes 'ada-mode) - (set (make-local-variable 'align-region-separate) ada-align-region-separate) - - ;; 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 needs to "M-x abbrev-mode"). - (setq local-abbrev-table ada-mode-abbrev-table) - - ;; Support for which-function mode - (set (make-local-variable 'which-func-functions) '(ada-which-function)) - - ;; Support for indent-new-comment-line (Especially for XEmacs) - (set (make-local-variable 'comment-multi-line) nil) - - ;; Support for add-log - (set (make-local-variable 'add-log-current-defun-function) - 'ada-which-function) - - (easy-menu-add ada-mode-menu ada-mode-map) - - (set (make-local-variable 'skeleton-further-elements) - '((< '(backward-delete-char-untabify - (min ada-indent (current-column)))))) - (add-hook 'skeleton-end-hook 'ada-adjust-case-skeleton nil t) - - ;; To be run after the hook, in case the user modified - ;; ada-fill-comment-prefix - (add-hook 'hack-local-variables-hook - (lambda () - (set (make-local-variable 'comment-start) - (or ada-fill-comment-prefix "-- ")) - - ;; Run this after the hook to give the users a chance - ;; to activate font-lock-mode. - - (unless (or (eval-when-compile (fboundp 'syntax-propertize-via-font-lock)) - (featurep 'xemacs)) - (ada-initialize-syntax-table-properties) - (add-hook 'font-lock-mode-hook - 'ada-handle-syntax-table-properties nil t)) - - ;; FIXME: ada-language-version might be set in the mode - ;; hook or it might even be set later on via file-local - ;; vars, so ada-keywords should be set lazily. - (cond ((eq ada-language-version 'ada83) - (setq ada-keywords ada-83-keywords)) - ((eq ada-language-version 'ada95) - (setq ada-keywords ada-95-keywords)) - ((eq ada-language-version 'ada2005) - (setq ada-keywords ada-2005-keywords))) - - (if ada-auto-case - (ada-activate-keys-for-case))) - nil 'local)) - -(defun ada-adjust-case-skeleton () - "Adjust the case of the text inserted by a skeleton." - (save-excursion - (let ((aa-end (point))) - (ada-adjust-case-region - (progn (goto-char (symbol-value 'beg)) (forward-word-strictly -1) - (point)) - (goto-char aa-end))))) - -(defun ada-region-selected () - "Should we operate on an active region?" - (if (fboundp 'use-region-p) - (use-region-p) - (region-active-p))) - -;;----------------------------------------------------------------- -;; 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 casing exception lists to the file FILE-NAME. -Casing exception lists are `ada-case-exception' and `ada-case-exception-substring'." - (find-file (expand-file-name file-name)) - (erase-buffer) - (mapc (lambda (x) (insert (car x) "\n")) - (sort (copy-sequence ada-case-exception) - (lambda(a b) (string< (car a) (car b))))) - (mapc (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) - "Define 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 word is added to the first file in `ada-case-exception-file'. -The standard casing rules will no longer apply to this word." - (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")))))) - - (unless word - (with-syntax-table ada-mode-symbol-syntax-table - (save-excursion - (skip-syntax-backward "w") - (setq word (buffer-substring-no-properties - (point) (save-excursion (forward-word-strictly 1) - (point))))))) - - ;; 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-string word ada-case-exception t)) - (setcar (assoc-string word ada-case-exception t) 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) - "Define 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 word 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") - (setq word (buffer-substring-no-properties - (point) - (save-excursion (forward-word-strictly 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-string word ada-case-exception-substring t)) - (setcar (assoc-string word ada-case-exception-substring t) word) - (add-to-list 'ada-case-exception-substring (cons word t)) - ) - - (ada-save-exceptions-to-file file-name) - - (message "%s" (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-strictly 1) - (point))))) - - ;; Handling a substring ? - (if (char-equal (string-to-char word) ?*) - (progn - (setq word (substring word 1)) - (unless (assoc-string word ada-case-exception-substring t) - (add-to-list 'ada-case-exception-substring (cons word t)))) - (unless (assoc-string word ada-case-exception t) - (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-string (buffer-substring start end) - ada-case-exception t)) - - (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 () - "Return t if cursor is after a keyword that is not an attribute." - (save-excursion - (forward-word-strictly -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 character just typed. -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 in a numeric literal - (not (ada-in-numeric-literal-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 \\[universal-argument]." - (interactive "P") - - (if ada-auto-case - (let ((lastk last-command-event)) - - (with-syntax-table ada-mode-symbol-syntax-table - (cond ((memq lastk '(?\n ?\r)) - ;; Horrible kludge. - (insert " ") - (ada-adjust-case) - ;; horrible dekludge - (delete-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)))) - - ;; Else, no auto-casing - (cond - ((eq last-command-event ?\n) - (funcall ada-lfd-binding)) - ((eq last-command-event ?\r) - (funcall ada-ret-binding)) - (t - (self-insert-command (prefix-numeric-value arg)))))) - -(defun ada-activate-keys-for-case () - ;; FIXME: Use post-self-insert-hook instead of changing key bindings. - "Modify 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) - "Do nothing. ARG is ignored. -This function can be used for the auto-casing variables in Ada mode, to -adapt to unusual 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." - nil) - -(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)))) - (capitalize-region begin end))) - -(defun ada-adjust-case-region (from to) - "Adjust 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)) - (message "Adjusting case ...") - (with-syntax-table ada-mode-symbol-syntax-table - (save-excursion - (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"))))) - -(defun ada-adjust-case-buffer () - "Adjust 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))) - - -;;-------------------------------------------------------------- -;; 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 reformatting will fail. -;;-------------------------------------------------------------- - -(defun ada-format-paramlist () - "Reformat the parameter list point is in." - (interactive) - (let ((begin nil) - (end nil) - (delend nil) - (paramlist nil)) - (with-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)))) - -(defun ada-scan-paramlist (begin end) - "Scan the parameter list found in between BEGIN and END. -Return 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-strictly 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) - "Insert 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)) - )) - - - -;;;---------------------------------------------------------------- -;; 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 () - "Indent the current line, insert a newline and then indent 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 re-indented if `ada-indent-after-return' is non-nil." - (interactive "*") - ;; If at end of buffer (entering brand new code), some indentation - ;; fails. For example, a block label requires whitespace following - ;; the : to be recognized. So we do the newline first, then - ;; go back and indent the original line. - (newline) - (if ada-indent-after-return - (progn - (forward-char -1) - (ada-indent-current) - (forward-char 1))) - (ada-indent-current)) - -(defun ada-justified-indent-current () - "Indent the current line and explain 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 "%s" (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 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 "Formatting %s" 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 () - "Move point to the beginning of the previous word of Ada code. -Return 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. -Return the calculation that was done, including the reference point -and the offset." - (interactive) - (let ((orgpoint (point-marker)) - cur-indent tmp-indent - prev-indent) - - (unwind-protect - (with-syntax-table ada-mode-symbol-syntax-table - - ;; This needs 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))) - - (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 - (back-to-indentation) - (if (looking-at ada-block-label-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-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 (point-at-eol)) - (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 "\\<overriding\\|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 - (setq pos (ada-search-ignore-string-comment ";\\|return\\>" t))) - (if (and pos - (= (downcase (char-after (car pos))) ?r)) - (goto-char (car pos))) - (setq var 'ada-indent-renames))) - - (forward-comment -1000) - (if (= (char-before) ?\)) - (forward-sexp -1) - (forward-word-strictly -1)) - - ;; If there is a parameter list, and we have a function declaration - ;; or access to subprogram declaration - (let ((num-back 1)) - (if (and (= (following-char) ?\() - (save-excursion - (or (progn - (backward-word-strictly 1) - (looking-at "\\(function\\|procedure\\)\\>")) - (progn - (backward-word-strictly 1) - (setq 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-strictly 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-strictly -1) - (looking-at "function\\>"))) - (list (progn (forward-word-strictly -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 "--" (point-at-eol) 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 (point-at-bol) 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, or 'overriding' for this function/procedure - (let (found) - (while (and (not found) - (ada-search-ignore-string-comment - "\\<\\(generic\\|end\\|begin\\|overriding\\|package\\|procedure\\|function\\)\\>" t)) - - ;; avoid "with procedure"... in generic parts - (save-excursion - (forward-word-strictly -1) - (setq found (not (looking-at "with")))))) - - (cond - ((looking-at "\\<generic\\|overriding\\>") - (list (progn (back-to-indentation) (point)) 0)) - - (t - (ada-indent-on-previous-lines nil orgpoint orgpoint))))) - - ;;--------------------------------- - ;; label - ;;--------------------------------- - - ((looking-at ada-label-re) - (if (ada-in-decl-p) - ;; ada-block-label-re matches variable declarations - (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. If already at a - ;; statement start, move to beginning of enclosing statement. - (unless nomove - (ada-goto-stmt-start t)) - - ;; 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 ada-block-label-re) ; also variable declaration - (ada-get-indent-block-label orgpoint)) - ;; - ((looking-at ada-goto-label-re) - (ada-get-indent-goto-label 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 "separate\\>") - (ada-get-indent-nochange)) - ;; - ((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 () - "Calculate 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 () - "Calculate 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) 'ada-broken-indent))))) - -(defun ada-get-indent-end (orgpoint) - "Calculate 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-strictly 1) - (ada-goto-next-non-ws) - (cond - ;; - ;; loop/select/if/case/return - ;; - ((looking-at "\\<\\(loop\\|select\\|if\\|case\\|return\\)\\>") - (save-excursion (ada-check-matching-start (match-string 0))) - (list (save-excursion (back-to-indentation) (point)) 0)) - - ;; - ;; record - ;; - ((looking-at "\\<record\\>") - (save-excursion - (ada-check-matching-start (match-string 0)) - ;; we are now looking at the matching "record" statement - (forward-word-strictly 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-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) - "Calculate 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) - "Calculate 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) - "Calculate 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-strictly 1) - (list cur-indent 'ada-indent)) - - (list cur-indent 'ada-broken-indent)))) - -(defun ada-get-indent-block-start (orgpoint) - "Calculate 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-strictly 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))) - - ;; Special case for label: - ((looking-at ada-block-label-re) - (list (- (save-excursion (back-to-indentation) (point)) ada-label-indent) 'ada-indent)) - - ;; nothing follows the block-start - (t - (list (save-excursion (back-to-indentation) (point)) 'ada-indent))))) - -(defun ada-get-indent-subprog (orgpoint) - "Calculate 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) - "Calculate 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 other case when indenting a line at the - ;; top level - (t - (if (looking-at (concat "[ \t]*" ada-block-label-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-block-label (orgpoint) - "Calculate 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-goto-label (orgpoint) - "Calculate the indentation when at a goto label." - (search-forward ">>") - (ada-goto-next-non-ws) - (if (>= (point) orgpoint) - ;; labeled statement is the one we need to indent - (list (- (point) ada-label-indent)) - ;; else indentation is indent for labeled statement - (ada-indent-on-previous-lines t orgpoint))) - -(defun ada-get-indent-loop (orgpoint) - "Calculate 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 - (back-to-indentation) - (if (looking-at ada-block-label-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) (cadr 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-strictly 1) - (if (= (char-after) ?') (forward-word-strictly 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) - "Calculate 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-strictly 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))))) - - -;; ----------------------------------------------------------- -;; -- searching and matching -;; ----------------------------------------------------------- - -(defun ada-goto-stmt-start (&optional ignore-goto-label) - "Move point to the beginning of the statement that point is in or after. -Return 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 ignore-goto-label)) - ;; - ;; 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 () - "Move point to previous end statement. -Return a cons cell whose car is the beginning and whose cdr -is 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-strictly -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" - "private" "abstract" "new") t) - "\\>\\|(")))))))) - - ((looking-at "private") - (save-excursion - (backward-word-strictly 1) - (setq found (not (looking-at "is"))))) - - (t - (setq found t)) - ))) - - (if found - match-dat - nil))) - -(defun ada-goto-next-non-ws (&optional limit skip-goto-label) - "Skip to next non-whitespace character. -Skips spaces, newlines and comments, and possibly goto labels. -Return `point' if moved, nil if not. -Stop the search at LIMIT. -Do not call this function from within a string." - (unless limit - (setq limit (point-max))) - (while (and (<= (point) limit) - (or (progn (forward-comment 10000) - (if (and (not (eobp)) - (save-excursion (forward-char 1) - (ada-in-string-p))) - (progn (forward-sexp 1) t))) - (and skip-goto-label - (looking-at ada-goto-label-re) - (progn - (goto-char (match-end 0)) - t))))) - (if (< (point) limit) - (point) - nil) - ) - - -(defun ada-goto-stmt-end (&optional limit) - "Move point to the end of the statement that point is in or before. -Return 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) - "Move point to the beginning of the next word of Ada code. -If BACKWARD is non-nil, jump to the beginning of the previous word. -Return the new position of point or nil if not found." - (let ((match-cons nil) - (orgpoint (point))) - (unless backward - (skip-syntax-forward "w_")) - (if (setq match-cons - (ada-search-ignore-string-comment "\\sw\\|\\s_" backward 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))) - - -(defun ada-check-matching-start (keyword) - "Signal 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) - "Check 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'; ada-goto-matching-start leaves - ;; point at start of 'begin' for a block. - (if (save-excursion - (ada-goto-previous-word) - (looking-at (concat "\\<" defun-name "\\> *:"))) - t ; name matches - ;; else - ;; - ;; 'accept' or 'package' ? - ;; - (unless (looking-at ada-subprog-start-re) - (ada-goto-decl-start)) - ;; - ;; 'begin' of 'procedure'/'function'/'task' or 'declare' - ;; - (save-excursion - ;; - ;; a named 'declare'-block ? => jump to the label - ;; - (if (looking-at "\\<declare\\>") - (progn - (forward-comment -1) - (backward-word-strictly 1)) - ;; - ;; no, => 'procedure'/'function'/'task'/'protected' - ;; - (progn - (forward-word-strictly 2) - (backward-word-strictly 1) - ;; - ;; skip 'body' 'type' - ;; - (if (looking-at "\\<\\(body\\|type\\)\\>") - (forward-word-strictly 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-decl-start (&optional noerror) - "Move point to the declaration start of the current construct. -If NOERROR is non-nil, return nil if no match was found; -otherwise throw error." - (let ((nest-count 1) - (regexp (eval-when-compile - (concat "\\<" - (regexp-opt - '("is" "separate" "end" "declare" "if" "new" "begin" "generic" "when") t) - "\\>"))) - - ;; first should be set to t if we should stop at the first - ;; "begin" we encounter. - (first t) - (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 regexp 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) - - (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-strictly -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") - ;; look for things to ignore - (if - (or - ;; generic formal parameter - (looking-at "is[ t]+<>") - - ;; A type definition, or a case statement. Note that the - ;; goto-matching-start above on 'end record' leaves us at - ;; 'record', not at 'type'. - ;; - ;; We get to a case statement here by calling - ;; 'ada-move-to-end' from inside a case statement; then - ;; we are not ignoring 'when'. - (save-excursion - ;; Skip type discriminants or case argument function call param list - (forward-comment -10000) - (forward-char -1) - (if (= (char-after) ?\)) - (progn - (forward-char 1) - (backward-sexp 1) - (forward-comment -10000) - )) - ;; skip type or case argument name - (skip-chars-backward "a-zA-Z0-9_.'") - (ada-goto-previous-word) - (and - ;; if it's a protected type, it's the decl start we - ;; are looking for; since we didn't see the 'end' - ;; above, we are inside it. - (looking-at "\\<\\(sub\\)?type\\|case\\>") - (save-match-data - (ada-goto-previous-word) - (not (looking-at "\\<protected\\>")))) - ) ; end of type definition p - - ;; null procedure declaration - (save-excursion (ada-goto-next-word) (looking-at "\\<null\\>")) - );; end or - ;; skip this construct - nil - ;; this is the right "is" - (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-strictly -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) - "Move 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) - - (last-was-begin '()) - ;; List all keywords encountered while traversing - ;; something like '("end" "end" "begin") - ;; This is removed from the list when "package", "procedure",... - ;; are seen. The goal is to find whether a package has an elaboration - ;; part - - (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-strictly -1) - (looking-at "\\<null\\>"))) - (progn - ;; calculate nest-depth - (cond - ;; found block end => increase nest depth - ((looking-at "end") - (push nil last-was-begin) - (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]*[^;]") - (progn - ;; it ends a block => increase nest depth - (setq nest-count (1+ nest-count) - pos (point)) - (push nil last-was-begin)) - - ;; it starts a block => decrease nest depth - (setq nest-count (1- nest-count)) - - ;; Some nested "begin .. end" blocks with no "declare"? - ;; => remove those entries - (while (car last-was-begin) - (setq last-was-begin (cdr (cdr last-was-begin)))) - - (setq last-was-begin (cdr last-was-begin)) - )) - (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-strictly 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 (and (not (looking-at "\\<\\(new\\|separate\\|begin\\)\\>")) - (not (car last-was-begin))) - (setq nest-count (1- nest-count)))))) - - (setq last-was-begin (cdr last-was-begin)) - ) - ;; found task start => check if it has a body - ((looking-at "task") - (save-excursion - (forward-word-strictly 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-strictly 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-strictly 1) - (looking-at "[ \t]*;")) - (setq nest-count (1- nest-count)))))) - (setq last-was-begin (cdr last-was-begin)) - ) - - ((looking-at "declare") - ;; remove entry for begin and end (include nested begin..end - ;; groups) - (setq last-was-begin (cdr last-was-begin)) - (let ((count 1)) - (while (and (> count 0)) - (if (equal (car last-was-begin) t) - (setq count (1+ count)) - (setq count (1- count))) - (setq last-was-begin (cdr last-was-begin)) - ))) - - ((looking-at "protected") - ;; Ignore if this is just a declaration - (save-excursion - (let ((pos (ada-search-ignore-string-comment - "\\(\\<is\\>\\|\\<renames\\>\\|;\\)" nil))) - (if pos - (goto-char (car pos))) - (if (looking-at "is") - ;; remove entry for end - (setq last-was-begin (cdr last-was-begin))))) - (setq nest-count (1- nest-count))) - - ((or (looking-at "procedure") - (looking-at "function")) - ;; Ignore if this is just a declaration - (save-excursion - (let ((pos (ada-search-ignore-string-comment - "\\(\\<is\\>\\|\\<renames\\>\\|)[ \t]*;\\)" nil))) - (if pos - (goto-char (car pos))) - (if (looking-at "is") - ;; remove entry for begin and end - (setq last-was-begin (cdr (cdr last-was-begin)))))) - ) - - ;; all the other block starts - (t - (push (looking-at "begin") last-was-begin) - (setq nest-count (1- nest-count))) - - ) - - ;; 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' or 'return' - ;; - ((looking-at "do") - (unless (ada-search-ignore-string-comment - "\\<accept\\|return\\>" t) - (error "Missing `accept' or `return' in front of `do'")))) - (point)) - - (if noerror - nil - (error "No matching start")))))) - - -(defun ada-goto-matching-end (&optional nest-level noerror) - "Move 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 no matching start found." - (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-strictly 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 instantiation. - - ((and (looking-at "\\<procedure\\|function\\>")) - (if first - (forward-word-strictly 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-strictly 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-strictly 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. -Returns a cons cell of begin and end of match data or nil, if not found. -If BACKWARD is non-nil, search backward; search forward otherwise. -The search stops at pos LIMIT. -If PARAMLISTS is nil, ignore parameter lists. -The search is done using SEARCH-FUNC. SEARCH-FUNC can be optimized -in case we are searching for a constant string. -Point is moved at the beginning of the SEARCH-RE." - (let (found - begin - end - parse-result) - - ;; FIXME: need to pass BACKWARD to search-func! - (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 - ;; - (with-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 (point-at-bol) (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 - - (if found - (cons begin end) - nil))) - -;; ------------------------------------------------------- -;; -- Testing the position of the cursor -;; ------------------------------------------------------- - -(defun ada-in-decl-p () - "Return 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-decl-start t)))) - - -(defun ada-looking-at-semi-or () - "Return t if looking at an `or' following a semicolon." - (save-excursion - (and (looking-at "\\<or\\>") - (progn - (forward-word-strictly 1) - (ada-goto-stmt-start) - (looking-at "\\<or\\>"))))) - - -(defun ada-looking-at-semi-private () - "Return t if looking at the start of a private section in a package. -Return 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-strictly -3) - (looking-at "\\<package\\>")))))))) - - -(defun ada-in-paramlist-p () - "Return t if point is inside the parameter-list of a declaration, but not a subprogram call or aggregate." - (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-strictly 1)) - t) - - ;; and now over the second one - (backward-word-strictly 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 - ;; pragma is not, because the syntax is that of a subprogram call. - (looking-at (eval-when-compile - (concat "\\<\\(" - "procedure\\|function\\|body\\|" - "task\\|entry\\|accept\\|" - "access[ \t]+procedure\\|" - "access[ \t]+function\\|" - "type\\)\\>")))))) - -(defun ada-search-ignore-complex-boolean (regexp backwardp) - "Search for REGEXP, ignoring comments, strings, `and then', `or else'. -If BACKWARDP is non-nil, search backward; search forward otherwise." - (let (result) - (while (and (setq result (ada-search-ignore-string-comment regexp backwardp)) - (save-excursion (forward-word-strictly -1) - (looking-at "and then\\|or else")))) - result)) - -(defun ada-in-open-paren-p () - "Non-nil if in an open parenthesis. -Return value is the position of the first non-ws behind the last unclosed -parenthesis, or nil." - (save-excursion - (let ((parse (parse-partial-sexp - ;; In Emacs 28, TO has to be greater than FROM. - (or (car (ada-search-ignore-complex-boolean - "\\<\\(;\\|is\\|then\\|loop\\|begin\\|else\\)\\>" - t)) - (point-min)) - (point)))) - - (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)))))) - - -;; ----------------------------------------------------------- -;; -- 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, operate 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'." - ;; FIXME: ARG is ignored - (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 (bolp) (forward-char ada-indent))) - -(defun ada-untab-hard () - "Indent current line to previous tab stop." - (interactive) - (indent-rigidly (point-at-bol) (point-at-eol) (- 0 ada-indent))) - - -;; ------------------------------------------------------------ -;; -- 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))) - )) - - - -;; ------------------------------------------------------------- -;; -- Moving To Procedures/Packages/Statements -;; ------------------------------------------------------------- - -(defun ada-move-to-start () - "Move point to the matching start of the current Ada structure." - (interactive) - (let ((pos (point))) - (with-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-strictly 1)) - (or (looking-at "[ \t]*\\<end\\>") - (backward-word-strictly 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-decl-start) - (setq pos (point)))) - - ) ; end of save-excursion - - ;; now really move to the found position - (goto-char pos)))) - -(defun ada-move-to-end () - "Move point to the end of the block around point. -Moves to `begin' if in a declarative part." - (interactive) - (let ((pos (point)) - decl-start) - (with-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 instantiation, 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-strictly 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-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)))) - -(defun ada-next-procedure () - "Move point to next procedure." - (interactive) - (end-of-line) - (if (re-search-forward ada-procedure-start-regexp nil t) - (goto-char (match-beginning 4)) - (error "No more functions/procedures/tasks"))) - -(defun ada-previous-procedure () - "Move point to previous procedure." - (interactive) - (beginning-of-line) - (if (re-search-backward ada-procedure-start-regexp nil t) - (goto-char (match-beginning 4)) - (error "No more functions/procedures/tasks"))) - -(defun ada-next-package () - "Move 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 () - "Move 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"))) - - -;; ------------------------------------------------------------ -;; -- Define keymap and menus for Ada -;; ------------------------------------------------------------- - -(defun ada-create-keymap () - "Create the keymap associated with the Ada mode." - - ;; All non-standard keys go into ada-mode-extra-map - (define-key ada-mode-map ada-mode-extra-prefix ada-mode-extra-map) - - ;; 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) - (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 - (define-key ada-mode-map - (if (boundp 'delete-key-deletes-forward) [backspace] "\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) - ;; FIXME: Made redundant with Emacs-21's standard comment-dwim binding on M-; - (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 - - (define-key ada-mode-map (if (featurep 'xemacs) '(shift button3) [S-mouse-3]) - 'ada-point-and-xref) - (define-key ada-mode-map [(control tab)] 'ada-complete-identifier) - - (define-key ada-mode-extra-map "o" '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-extra-map "c" 'ada-change-prj) - (define-key ada-mode-extra-map "d" 'ada-set-default-project-file) - (define-key ada-mode-extra-map "g" 'ada-gdb-application) - (define-key ada-mode-map "\C-c\C-m" 'ada-set-main-compile-application) - (define-key ada-mode-extra-map "r" '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-extra-map "l" 'ada-find-local-references) - (define-key ada-mode-map "\C-c\C-v" 'ada-check-current) - (define-key ada-mode-extra-map "f" 'ada-find-file) - - (define-key ada-mode-extra-map "u" 'ada-prj-edit) - - (define-key ada-mode-map "\C-xnd" 'ada-narrow-to-defun); override narrow-to-defun - - ;; 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-extra-map "t" 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") t]) - ("Options" :included (derived-mode-p '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 t] - ["Compile file" ada-compile-current t] - ["Set main and Build" ada-set-main-compile-application t] - ["Show main" ada-show-current-main t] - ["Build" ada-compile-application t] - ["Run" ada-run-application t] - ["Debug" ada-gdb-application (eq ada-which-compiler 'gnat)] - ["------" nil nil] - ("Project" - ["Show project" ada-show-current-project t] - ["Load..." ada-set-default-project-file t] - ["New..." ada-prj-new t] - ["Edit..." ada-prj-edit t]) - ("Goto" :included (derived-mode-p '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 (derived-mode-p '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 (derived-mode-p '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-accept 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) - (if (featurep 'xemacs) - (progn - (define-key ada-mode-map [menu-bar] ada-mode-menu) - (setq mode-popup-menu (cons "Ada mode" ada-mode-menu)))))) - - -;; ------------------------------------------------------- -;; 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. -;; ------------------------------------------------------- - -(when (or (<= emacs-major-version 20) (featurep 'xemacs)) - (defadvice comment-region (before ada-uncomment-anywhere disable) - (if (and (consp arg) ;; a prefix with \C-u is of the form '(4), whereas - ;; \C-u 2 sets arg to '2' (fixed by S.Leake) - (derived-mode-p 'ada-mode)) - (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) - "Uncomment region BEG .. END. -ARG gives number of comment characters." - (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 () - "Fill current comment paragraph and justify each line as well." - (interactive) - (ada-fill-comment-paragraph 'full)) - -(defun ada-fill-comment-paragraph-postfix () - "Fill current comment paragraph and justify 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) - "Fill the current comment paragraph. -If JUSTIFY is non-nil, each line is justified as well. -If POSTFIX and JUSTIFY are non-nil, `ada-fill-comment-postfix' is appended -to each line filled and justified. -The paragraph is indented on the first line." - (interactive "P") - - ;; 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 overridden in `ada-xref'.el when we know that the user is using -;; GNAT. -;; --------------------------------------------------- - -;; Overridden when we work with GNAT, to use gnatkrunch -(defun ada-make-filename-from-adaname (adaname) - "Determine the filename in which ADANAME is found. -This matches the GNAT default naming convention, except for -pre-defined units." - (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 - (setq 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. -Used in `ff-pre-load-hook'." - (setq ff-function-name nil) - (save-excursion - (end-of-line);; make sure we get the complete name - (or (if (re-search-backward ada-procedure-start-regexp nil t) - (setq ff-function-name (match-string 5))) - (if (re-search-backward ada-package-start-regexp nil t) - (setq ff-function-name (match-string 4)))) - )) - - -(defvar ada-last-which-function-line -1 - "Last line 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 () - "Return 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-strictly 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 mode line on Emacs 21 - (setq func-name (match-string-no-properties 3)) - (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) - "Return the file name for the body of SPEC-NAME. -If SPEC-NAME is nil, return the body for the current package. -Return 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"))) - - -;; --------------------------------------------------- -;; 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. - ;; We used to explicitly avoid ''' as a special case for fear the buffer - ;; be highlighted as a string, but it seems this fear is unfounded. - ;; - ;; 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" "interface" "is" "limited" "loop" "mod" "not" - "null" "or" "others" "overriding" "private" "protected" "raise" - "range" "record" "rem" "renames" "requeue" "return" "reverse" - "select" "separate" "synchronized" "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-constant-face nil t)) - - ;; - ;; Goto tags. - '("<<\\(\\sw+\\)>>" 1 font-lock-constant-face) - - ;; Highlight based-numbers (R. Reagan <[email protected]>) - (list "\\([0-9]+#[[:xdigit:]_]+#\\)" '(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 <[email protected]> - (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 \\[widen] to go back to the full visibility for the buffer." - - (interactive) - (save-excursion - (let (end) - (widen) - (forward-line 1) - (ada-previous-procedure) - (setq end (point-at-bol)) - (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 locations 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-strictly 2) - (forward-word-strictly -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-strictly 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) - ) - - ((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-strictly 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 spec must be the previously visited buffer. -This function typically is to be hooked into `ff-file-created-hook'." - (delete-region (point-min) (point-max)) - (insert-buffer-substring (car (cdr (buffer-list)))) - (goto-char (point-min)) - (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 () - "Create a dummy subprogram body in package body file 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) - -;; 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. -(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 t) -(autoload 'ada-xref-goto-previous-reference "ada-xref" nil t) -(autoload 'ada-set-main-compile-application "ada-xref" nil t) -(autoload 'ada-show-current-main "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 |