-;; @(#) ada-mode.el --- major-mode for editing Ada source.
+;;; ada-mode.el --- major-mode for editing Ada sources
-;; Copyright (C) 1994, 95, 97, 98, 99, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 95, 97, 98, 99, 2000, 2001, 2002, 03, 2004
+;; Free Software Foundation, Inc.
;; Author: Rolf Ebert <ebert@inf.enst.fr>
;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
;; Emmanuel Briot <briot@gnat.com>
;; Maintainer: Emmanuel Briot <briot@gnat.com>
-;; Ada Core Technologies's version: $Revision: 1.38 $
+;; Ada Core Technologies's version: Revision: 1.188
;; Keywords: languages ada
-;; This file is not part of GNU Emacs
+;; This file is part of GNU Emacs.
-;; This program is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
-;; This program is distributed in the hope that it will be useful,
+;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; This mode is a major mode for editing Ada83 and Ada95 source code.
;;; This is a major rewrite of the file packaged with Emacs-20. The
-;;; ada-mode is composed of four lisp file, ada-mode.el, ada-xref.el,
-;;; ada-prj.el and ada-stmt.el. Only this file (ada-mode.el) is
+;;; 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 provides only by Gnat.
+;;; by Ada Core Technologies. All the other files rely heavily on
+;;; features provided only by Gnat.
;;;
;;; Note: this mode will not work with Emacs 19. If you are on a VMS
;;; system, where the latest version of Emacs is 19.28, you will need
;;; gse@ocsystems.com (Scott Evans)
;;; comar@gnat.com (Cyrille Comar)
;;; stephen.leake@gsfc.nasa.gov (Stephen Leake)
+;;; robin-reply@reagans.org
;;; and others for their valuable hints.
;;; Code:
;;; the customize mode. They are sorted in alphabetical order in this
;;; file.
+;;; Supported packages.
+;;; This package supports a number of other Emacs modes. These other modes
+;;; should be loaded before the ada-mode, which will then setup some variables
+;;; to improve the support for Ada code.
+;;; Here is the list of these modes:
+;;; `which-function-mode': Display the name of the subprogram the cursor is
+;;; in in the mode line.
+;;; `outline-mode': Provides the capability to collapse or expand the code
+;;; for specific language constructs, for instance if you want to hide the
+;;; code corresponding to a subprogram
+;;; `align': This mode is now provided with Emacs 21, but can also be
+;;; installed manually for older versions of Emacs. It provides the
+;;; capability to automatically realign the selected region (for instance
+;;; all ':=', ':' and '--' will be aligned on top of each other.
+;;; `imenu': Provides a menu with the list of entities defined in the current
+;;; buffer, and an easy way to jump to any of them
+;;; `speedbar': Provides a separate file browser, and the capability for each
+;;; file to see the list of entities defined in it and to jump to them
+;;; easily
+;;; `abbrev-mode': Provides the capability to define abbreviations, which
+;;; are automatically expanded when you type them. See the Emacs manual.
+
+(eval-when-compile
+ (require 'ispell nil t)
+ (require 'find-file nil t)
+ (require 'align nil t)
+ (require 'which-func nil t)
+ (require 'compile nil t))
;; this function is needed at compile time
(eval-and-compile
(defun ada-check-emacs-version (major minor &optional is-xemacs)
- "Returns t if Emacs's version is greater or equal to MAJOR.MINOR.
+ "Return t if Emacs's version is greater or equal to MAJOR.MINOR.
If IS-XEMACS is non-nil, check for XEmacs instead of Emacs."
(let ((xemacs-running (or (string-match "Lucid" emacs-version)
(string-match "XEmacs" emacs-version))))
(>= emacs-minor-version minor)))))))
-;; We create a constant for that, for efficiency only
-;; This should be evaluated both at compile time, only a runtime
-(eval-and-compile
- (defconst ada-xemacs (and (boundp 'running-xemacs)
- (symbol-value 'running-xemacs))
- "Return t if we are using XEmacs."))
-
-(unless ada-xemacs
- (require 'outline))
-
-(eval-and-compile
- (condition-case nil (require 'find-file) (error nil)))
-
;; This call should not be made in the release that is done for the
-;; official FSF Emacs, since it does nothing useful for the latest version
-;; (require 'ada-support)
+;; official Emacs, since it does nothing useful for the latest version
+;;(if (not (ada-check-emacs-version 21 1))
+;; (require 'ada-support))
(defvar ada-mode-hook nil
"*List of functions to call when Ada mode is invoked.
-This hook is automatically executed after the ada-mode is
+This hook is automatically executed after the `ada-mode' is
fully loaded.
This is a good place to add Ada environment specific bindings.")
>>>>>>>>>Value); -- from ada-broken-indent"
:type 'integer :group 'ada)
+(defcustom ada-continuation-indent ada-broken-indent
+ "*Number of columns to indent the continuation of broken lines in parenthesis.
+
+An example is :
+ Func (Param1,
+ >>>>>Param2);"
+ :type 'integer :group 'ada)
+
(defcustom ada-case-attribute 'ada-capitalize-word
"*Function to call to adjust the case of Ada attributes.
It may be `downcase-word', `upcase-word', `ada-loose-case-word',
(const ada-no-auto-case))
:group 'ada)
-(defcustom ada-case-exception-file '("~/.emacs_case_exceptions")
+(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. Each line can be terminated by
+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-indent-comment-as-code t
"*Non-nil means indent comment lines as code.
-Nil means do not auto-indent comments."
+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
(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).
+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)
(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).
+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)
"*Non-nil means indent according to the innermost open parenthesis."
:type 'boolean :group 'ada)
-(defcustom ada-fill-comment-prefix "-- "
+(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 restart the ada-mode to
-reread this variable."
+Note: if you modify this variable, you will have to invoke `ada-mode'
+again to take account of the new value."
:type 'string :group 'ada)
(defcustom ada-fill-comment-postfix " --"
"*Text inserted at the end of each line when filling a comment paragraph.
-with `ada-fill-comment-paragraph-postfix'."
+Used by `ada-fill-comment-paragraph-postfix'."
:type 'string :group 'ada)
(defcustom ada-label-indent -4
An example is:
procedure Foo is
begin
->>>>>>>>>>>>Label: -- from ada-label-indent"
+>>>>>>>>>>>>Label: -- from ada-label-indent
+
+This is also used for <<..>> labels"
:type 'integer :group 'ada)
(defcustom ada-language-version 'ada95
:group 'ada)
(defcustom ada-search-directories
- '("." "$ADA_INCLUDE_PATH" "/usr/adainclude" "/usr/local/adainclude"
- "/opt/gnu/adainclude")
+ (append '(".")
+ (split-string (or (getenv "ADA_INCLUDE_PATH") "") ":")
+ '("/usr/adainclude" "/usr/local/adainclude"
+ "/opt/gnu/adainclude"))
"*List of directories to search for Ada files.
-See the description for the `ff-search-directories' variable.
-Emacs will automatically add the paths defined in your project file, and if you
-are using the GNAT compiler the output of the gnatls command to find where the
-runtime really is."
+See the description for the `ff-search-directories' variable. This variable
+is the initial value of this variable, and is copied and modified in
+`ada-search-directories-internal'."
:type '(repeat (choice :tag "Directory"
(const :tag "default" nil)
(directory :format "%v")))
:group 'ada)
+(defvar ada-search-directories-internal ada-search-directories
+ "Internal version of `ada-search-directories'.
+Its value is the concatenation of the search path as read in the project file
+and the standard runtime location, and the value of the user-defined
+`ada-search-directories'.")
+
(defcustom ada-stmt-end-indent 0
"*Number of columns to indent the end of a statement on a separate line.
(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-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)
"*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
+`gnat': Use Ada Core Technologies' Gnat compiler. Add some cross-referencing
features
`generic': Use a generic compiler"
:type '(choice (const gnat)
(defvar ada-case-exception '()
"Alist of words (entities) that have special casing.")
+(defvar ada-case-exception-substring '()
+ "Alist of substrings (entities) that have special casing.
+The substrings are detected for word constituant when the word
+is not itself in `ada-case-exception', and only for substrings that
+either are at the beginning or end of the word, or start after '_'.")
+
(defvar ada-lfd-binding nil
"Variable to save key binding of LFD when casing is activated.")
(defvar ada-other-file-alist nil
- "Variable used by find-file to find the name of the other package.
+ "Variable used by `find-file' to find the name of the other package.
See `ff-other-file-alist'.")
+(defvar ada-align-list
+ '(("[^:]\\(\\s-*\\):[^:]" 1 t)
+ ("[^=]\\(\\s-+\\)=[^=]" 1 t)
+ ("\\(\\s-*\\)use\\s-" 1)
+ ("\\(\\s-*\\)--" 1))
+ "Ada support for align.el <= 2.2
+This variable provides regular expressions on which to align different lines.
+See `align-mode-alist' for more information.")
+
+(defvar ada-align-modes
+ '((ada-declaration
+ (regexp . "[^:]\\(\\s-*\\):[^:]")
+ (valid . (lambda() (not (ada-in-comment-p))))
+ (modes . '(ada-mode)))
+ (ada-assignment
+ (regexp . "[^=]\\(\\s-+\\)=[^=]")
+ (valid . (lambda() (not (ada-in-comment-p))))
+ (modes . '(ada-mode)))
+ (ada-comment
+ (regexp . "\\(\\s-*\\)--")
+ (modes . '(ada-mode)))
+ (ada-use
+ (regexp . "\\(\\s-*\\)use\\s-")
+ (valid . (lambda() (not (ada-in-comment-p))))
+ (modes . '(ada-mode)))
+ )
+ "Ada support for align.el >= 2.8
+This variable defines several rules to use to align different lines.")
+
+(defconst ada-align-region-separate
+ (concat
+ "^\\s-*\\($\\|\\("
+ "begin\\|"
+ "declare\\|"
+ "else\\|"
+ "end\\|"
+ "exception\\|"
+ "for\\|"
+ "function\\|"
+ "generic\\|"
+ "if\\|"
+ "is\\|"
+ "procedure\\|"
+ "record\\|"
+ "return\\|"
+ "type\\|"
+ "when"
+ "\\)\\>\\)")
+ "See the variable `align-region-separate' for more information.")
+
;;; ---- Below are the regexp used in this package for parsing
(defconst ada-83-keywords
"\\(\\sw\\|[_.]\\)+"
"Regexp matching Ada (qualified) identifiers.")
+;; "with" needs to be included in the regexp, so that we can insert new lines
+;; after the declaration of the parameter for a generic.
(defvar ada-procedure-start-regexp
- "^[ \t]*\\(procedure\\|function\\|task\\)[ \t\n]+\\(\\(\\sw\\|[_.]\\)+\\)"
+ (concat
+ "^[ \t]*\\(with[ \t]+\\)?\\(procedure\\|function\\|task\\)[ \t\n]+"
+
+ ;; subprogram name: operator ("[+/=*]")
+ "\\("
+ "\\(\"[^\"]+\"\\)"
+
+ ;; subprogram name: name
+ "\\|"
+ "\\(\\(\\sw\\|[_.]\\)+\\)"
+ "\\)")
"Regexp used to find Ada procedures/functions.")
(defvar ada-package-start-regexp
'("end" "loop" "select" "begin" "case" "do"
"if" "task" "package" "record" "protected") t)
"\\>"))
- "Regexp used in ada-goto-matching-start.")
+ "Regexp used in `ada-goto-matching-start'.")
(defvar ada-matching-decl-start-re
(eval-when-compile
(regexp-opt
'("is" "separate" "end" "declare" "if" "new" "begin" "generic" "when") t)
"\\>"))
- "Regexp used in ada-goto-matching-decl-start.")
+ "Regexp used in `ada-goto-matching-decl-start'.")
(defvar ada-loop-start-re
"\\<\\(for\\|while\\|loop\\)\\>"
"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
+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.")
-(defvar ada-contextual-menu
- (if ada-xemacs
- '("Ada"
- ["Goto Declaration/Body"
- (ada-call-from-contextual-menu 'ada-point-and-xref)
- :included (and (functionp 'ada-point-and-xref)
- ada-contextual-menu-on-identifier)]
- ["Goto Previous Reference"
- (ada-call-from-contextual-menu 'ada-xref-goto-previous-reference)
- :included (functionp 'ada-xref-goto-previous-reference)]
- ["List References" ada-find-references
- :included ada-contextual-menu-on-identifier]
- ["-" nil nil]
- ["Other File" ff-find-other-file]
- ["Goto Parent Unit" ada-goto-parent]
- )
-
- (let ((map (make-sparse-keymap "Ada")))
- ;; The identifier part
- (if (equal ada-which-compiler 'gnat)
- (progn
- (define-key-after map [Ref]
- '(menu-item "Goto Declaration/Body"
- (lambda()(interactive)
- (ada-call-from-contextual-menu
- 'ada-point-and-xref))
- :visible
- (and (functionp 'ada-point-and-xref)
- ada-contextual-menu-on-identifier))
- t)
- (define-key-after map [Prev]
- '(menu-item "Goto Previous Reference"
- (lambda()(interactive)
- (ada-call-from-contextual-menu
- 'ada-xref-goto-previous-reference))
- :visible
- (functionp 'ada-xref-goto-previous-reference))
- t)
- (define-key-after map [List]
- '(menu-item "List References"
- ada-find-references
- :visible ada-contextual-menu-on-identifier) t)
- (define-key-after map [-] '("-" nil) t)
- ))
- (define-key-after map [Other] '("Other file" . ff-find-other-file) t)
- (define-key-after map [Parent] '("Goto Parent Unit" . ada-goto-parent)t)
- map))
- "Defines the menu to use when the user presses the right mouse button.
+(easy-menu-define ada-contextual-menu nil
+ "Menu to use when the user presses the right mouse button.
The variable `ada-contextual-menu-on-identifier' will be set to t before
displaying the menu if point was on an identifier."
- )
+ '("Ada"
+ ["Goto Declaration/Body" ada-point-and-xref
+ :included ada-contextual-menu-on-identifier]
+ ["Goto Body" ada-point-and-xref-body
+ :included ada-contextual-menu-on-identifier]
+ ["Goto Previous Reference" ada-xref-goto-previous-reference]
+ ["List References" ada-find-references
+ :included ada-contextual-menu-on-identifier]
+ ["List Local References" ada-find-local-references
+ :included ada-contextual-menu-on-identifier]
+ ["-" nil nil]
+ ["Other File" ff-find-other-file]
+ ["Goto Parent Unit" ada-goto-parent]))
\f
;;------------------------------------------------------------------
;; Support for imenu (see imenu.el)
;;------------------------------------------------------------------
+(defconst ada-imenu-comment-re "\\([ \t]*--.*\\)?")
+
(defconst ada-imenu-subprogram-menu-re
- "^[ \t]*\\(procedure\\|function\\)[ \t\n]+\\(\\(\\sw\\|_\\)+\\)[ \t\n]*\\([ \t\n]\\|([^)]+)\\)[ \t\n]*\\(return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?is[ \t\n]")
+ (concat "^[ \t]*\\(procedure\\|function\\)[ \t\n]+"
+ "\\(\\(\\sw\\|_\\)+\\)[ \t\n]*\\([ \t\n]\\|([^)]+)"
+ ada-imenu-comment-re
+ "\\)[ \t\n]*"
+ "\\(return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?is[ \t\n]"))
(defvar ada-imenu-generic-expression
(list
(concat
"^[ \t]*\\(procedure\\|function\\)[ \t\n]+\\(\\(\\sw\\|_\\)+\\)"
"\\("
- "\\([ \t\n]+\\|[ \t\n]*([^)]+)\\)";; parameter list or simple space
+ "\\(" 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]+\\(\\(body\\|type\\)[ \t]+\\)?\\(\\(\\sw\\|_\\)+\\)" 3)
+ '("*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 two submenus, one
-for type and subtype definitions, the other for subprograms declarations.
-The main menu will reference the bodies of the subprograms.")
-
+See `imenu-generic-expression'. This variable will create several submenus for
+each type of entity that can be found in an Ada file.")
\f
;;------------------------------------------------------------
)
(defun ada-compile-goto-error (pos)
- "Replaces `compile-goto-error' from compile.el.
-If POS is on a file and line location, go to this position. It adds to
-compile.el the capacity to go to a reference in an error message.
+ "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 this line:
foo.adb:61:11: [...] in call to size declared at foo.ads:11
both file locations can be clicked on and jumped to."
(looking-at
"\\([-_.a-zA-Z0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?"))
(let ((line (match-string 2))
+ file
(error-pos (point-marker))
source)
(save-excursion
(save-restriction
(widen)
;; Use funcall so as to prevent byte-compiler warnings
- (set-buffer (funcall (symbol-function 'compilation-find-file)
- (point-marker) (match-string 1)
- "./"))
+ ;; `ada-find-file' is not defined if ada-xref wasn't loaded. But
+ ;; if we can find it, we should use it instead of
+ ;; `compilation-find-file', since the latter doesn't know anything
+ ;; about source path.
+
+ (if (functionp 'ada-find-file)
+ (setq file (funcall (symbol-function 'ada-find-file)
+ (match-string 1)))
+ (setq file (funcall (symbol-function 'compilation-find-file)
+ (point-marker) (match-string 1)
+ "./")))
+ (set-buffer file)
+
(if (stringp line)
(goto-line (string-to-number line)))
(setq source (point-marker))))
;; See the comment above on grammar related function for the special
;; setup for '#'.
- (if ada-xemacs
+ (if (featurep 'xemacs)
(modify-syntax-entry ?# "<" ada-mode-syntax-table)
(modify-syntax-entry ?# "$" ada-mode-syntax-table))
;; Support of special characters in XEmacs (see the comments at the beginning
;; of the section on Grammar related functions).
-(if ada-xemacs
+(if (featurep 'xemacs)
(defadvice parse-partial-sexp (around parse-partial-sexp-protect-constants)
"Handles special character constants and gnatprep statements."
(let (change)
;; Setting this only if font-lock is not set won't work
;; if the user activates or deactivates font-lock-mode,
;; but will make things faster most of the time
- (make-local-hook 'after-change-functions)
(add-hook 'after-change-functions 'ada-after-change-function nil t)
)))
(beginning-of-line)
(if (looking-at "^[ \t]*#")
(add-text-properties (match-beginning 0) (match-end 0)
- '(syntax-table (11 . 10))))
- ))))
+ '(syntax-table (11 . 10))))))))
;;------------------------------------------------------------------
;; Testing the grammatical context
;;------------------------------------------------------------------
(defsubst ada-in-comment-p (&optional parse-result)
- "Returns t if inside a comment."
+ "Return t if inside a comment."
(nth 4 (or parse-result
(parse-partial-sexp
- (save-excursion (beginning-of-line) (point)) (point)))))
+ (line-beginning-position) (point)))))
(defsubst ada-in-string-p (&optional parse-result)
- "Returns t if point is inside a string.
-If parse-result is non-nil, use is instead of calling parse-partial-sexp."
+ "Return t if point is inside a string.
+If parse-result is non-nil, use is instead of calling `parse-partial-sexp'."
(nth 3 (or parse-result
(parse-partial-sexp
- (save-excursion (beginning-of-line) (point)) (point)))))
+ (line-beginning-position) (point)))))
(defsubst ada-in-string-or-comment-p (&optional parse-result)
- "Returns t if inside a comment or string."
+ "Return t if inside a comment or string."
(setq parse-result (or parse-result
(parse-partial-sexp
- (save-excursion (beginning-of-line) (point)) (point))))
+ (line-beginning-position) (point))))
(or (ada-in-string-p parse-result) (ada-in-comment-p parse-result)))
"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."
+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
(save-excursion (skip-syntax-forward "w")
(not (ada-after-keyword-p)))
))
- (let (choice)
- (if ada-xemacs
- (setq choice (funcall (symbol-function 'popup-menu)
- ada-contextual-menu))
- (setq choice (x-popup-menu position ada-contextual-menu)))
- (if choice
- (funcall (lookup-key ada-contextual-menu (vector (car choice))))))
+ (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))
))
"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"
+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 body (cadr tmp))))
(add-to-list 'ada-other-file-alist (list reg (list body)))))
- (add-to-list 'auto-mode-alist (cons spec 'ada-mode))
- (add-to-list 'auto-mode-alist (cons body 'ada-mode))
+ (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)
- (condition-case nil
+ (if (fboundp 'speedbar-add-supported-extension)
(progn
- (require 'speedbar)
(funcall (symbol-function 'speedbar-add-supported-extension)
spec)
(funcall (symbol-function 'speedbar-add-supported-extension)
"Ada mode is the major mode for editing Ada code.
Bindings are as follows: (Note: 'LFD' is control-j.)
+\\{ada-mode-map}
Indent line '\\[ada-tab]'
Indent line, insert newline and indent the new line. '\\[newline-and-indent]'
Continue comment on next line '\\[indent-new-comment-line]'
If you use imenu.el:
- Display index-menu of functions & procedures '\\[imenu]'
+ Display index-menu of functions and procedures '\\[imenu]'
If you use find-file.el:
Switch to other file (Body <-> Spec) '\\[ff-find-other-file]'
(interactive)
(kill-all-local-variables)
- (set (make-local-variable 'require-final-newline) t)
-
- (make-local-variable 'comment-start)
- (if ada-fill-comment-prefix
- (setq comment-start ada-fill-comment-prefix)
- (setq comment-start "-- "))
+ (set (make-local-variable 'require-final-newline) mode-require-final-newline)
;; Set the paragraph delimiters so that one can select a whole block
;; simply with M-h
;; 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 ada-xemacs
+ (unless (featurep 'xemacs)
(progn
(if (ada-check-emacs-version 20 3)
(progn
(set (make-local-variable 'parse-sexp-lookup-properties) t)
))
- (setq case-fold-search t)
+ (set 'case-fold-search t)
(if (boundp 'imenu-case-fold-search)
- (setq imenu-case-fold-search t))
+ (set 'imenu-case-fold-search t))
(set (make-local-variable 'fill-paragraph-function)
'ada-fill-comment-paragraph)
;; We just substitute our own functions to go to the error.
(add-hook 'compilation-mode-hook
(lambda()
- (setq compile-auto-highlight 40)
+ (set (make-local-variable 'compile-auto-highlight) 40)
+ ;; FIXME: This has global impact! -stef
(define-key compilation-minor-mode-map [mouse-2]
'ada-compile-mouse-goto-error)
(define-key compilation-minor-mode-map "\C-c\C-c"
'ada-compile-goto-error)
(define-key compilation-minor-mode-map "\C-m"
- 'ada-compile-goto-error)
- ))
+ 'ada-compile-goto-error)))
;; font-lock support :
;; We need to set some properties for XEmacs, and define some variables
;; for Emacs
- (if ada-xemacs
+ (if (featurep 'xemacs)
;; XEmacs
(put 'ada-mode 'font-lock-defaults
'(ada-font-lock-keywords
)
;; Set up support for find-file.el.
- (set (make-variable-buffer-local 'ff-other-file-alist)
+ (set (make-local-variable 'ff-other-file-alist)
'ada-other-file-alist)
- (set (make-variable-buffer-local 'ff-search-directories)
- 'ada-search-directories)
- (setq ff-post-load-hooks 'ada-set-point-accordingly
- ff-file-created-hooks 'ada-make-body)
- (add-hook 'ff-pre-load-hooks 'ada-which-function-are-we-in)
+ (set (make-local-variable 'ff-search-directories)
+ 'ada-search-directories-internal)
+ (setq ff-post-load-hook 'ada-set-point-accordingly
+ ff-file-created-hook 'ada-make-body)
+ (add-hook 'ff-pre-load-hook 'ada-which-function-are-we-in)
;; Some special constructs for find-file.el
;; We do not need to add the construction for 'with', which is in the
"\\(body[ \t]+\\)?"
"\\(\\(\\sw\\|[_.]\\)+\\)\\.\\(\\sw\\|_\\)+[ \t\n]+is"))
(lambda ()
- (setq fname (ff-get-file
- ada-search-directories
- (ada-make-filename-from-adaname
- (match-string 3))
- ada-spec-suffixes)))))
+ (if (fboundp 'ff-get-file)
+ (if (boundp 'fname)
+ (set 'fname (ff-get-file
+ ada-search-directories-internal
+ (ada-make-filename-from-adaname
+ (match-string 3))
+ ada-spec-suffixes)))))))
;; Another special construct for find-file.el : when in a separate clause,
;; go to the correct package.
(add-to-list 'ff-special-constructs
(cons "^separate[ \t\n]*(\\(\\(\\sw\\|[_.]\\)+\\))"
(lambda ()
- (setq fname (ff-get-file
- ada-search-directories
- (ada-make-filename-from-adaname
- (match-string 1))
- ada-spec-suffixes)))))
+ (if (fboundp 'ff-get-file)
+ (if (boundp 'fname)
+ (setq fname (ff-get-file
+ ada-search-directories-internal
+ (ada-make-filename-from-adaname
+ (match-string 1))
+ ada-spec-suffixes)))))))
+
;; Another special construct, that redefines the one in find-file.el. The
;; old one can handle only one possible type of extension for Ada files
;; remove from the list the standard "with..." that is put by find-file.el,
(assoc "^with[ \t]+\\([a-zA-Z0-9_\\.]+\\)" ff-special-constructs))
(new-cdr
(lambda ()
- (setq fname (ff-get-file
- ada-search-directories
- (ada-make-filename-from-adaname
- (match-string 1))
- ada-spec-suffixes)))))
+ (if (fboundp 'ff-get-file)
+ (if (boundp 'fname)
+ (set 'fname (ff-get-file
+ ada-search-directories-internal
+ (ada-make-filename-from-adaname
+ (match-string 1))
+ ada-spec-suffixes)))))))
(if old-construct
(setcdr old-construct new-cdr)
(add-to-list 'ff-special-constructs
;; Support for imenu : We want a sorted index
(setq imenu-sort-function 'imenu--sort-by-name)
- ;; Support for which-function-mode is provided in ada-support (support
- ;; for nested subprograms)
+ ;; Support for ispell : Check only comments
+ (set (make-local-variable 'ispell-check-comments) 'exclusive)
+
+ ;; Support for align.el <= 2.2, if present
+ ;; align.el is distributed with Emacs 21, but not with earlier versions.
+ (if (boundp 'align-mode-alist)
+ (add-to-list 'align-mode-alist '(ada-mode . ada-align-list)))
+
+ ;; Support for align.el >= 2.8, if present
+ (if (boundp 'align-dq-string-modes)
+ (progn
+ (add-to-list 'align-dq-string-modes 'ada-mode)
+ (add-to-list 'align-open-comment-modes 'ada-mode)
+ (set (make-variable-buffer-local 'align-region-separate)
+ ada-align-region-separate)
+
+ ;; Exclude comments alone on line from alignment.
+ (add-to-list 'align-exclude-rules-list
+ '(ada-solo-comment
+ (regexp . "^\\(\\s-*\\)--")
+ (modes . '(ada-mode))))
+ (add-to-list 'align-exclude-rules-list
+ '(ada-solo-use
+ (regexp . "^\\(\\s-*\\)\\<use\\>")
+ (modes . '(ada-mode))))
+
+ (setq ada-align-modes nil)
+
+ (add-to-list 'ada-align-modes
+ '(ada-declaration-assign
+ (regexp . "[^:]\\(\\s-*\\):[^:]")
+ (valid . (lambda() (not (ada-in-comment-p))))
+ (repeat . t)
+ (modes . '(ada-mode))))
+ (add-to-list 'ada-align-modes
+ '(ada-associate
+ (regexp . "[^=]\\(\\s-*\\)=>")
+ (valid . (lambda() (not (ada-in-comment-p))))
+ (modes . '(ada-mode))))
+ (add-to-list 'ada-align-modes
+ '(ada-comment
+ (regexp . "\\(\\s-*\\)--")
+ (modes . '(ada-mode))))
+ (add-to-list 'ada-align-modes
+ '(ada-use
+ (regexp . "\\(\\s-*\\)\\<use\\s-")
+ (valid . (lambda() (not (ada-in-comment-p))))
+ (modes . '(ada-mode))))
+ (add-to-list 'ada-align-modes
+ '(ada-at
+ (regexp . "\\(\\s-+\\)at\\>")
+ (modes . '(ada-mode))))
+
+
+ (setq align-mode-rules-list ada-align-modes)
+ ))
;; Set up the contextual menu
(if ada-popup-key
(define-abbrev-table 'ada-mode-abbrev-table ())
(setq local-abbrev-table ada-mode-abbrev-table)
+ ;; Support for which-function mode
+ ;; which-function-mode does not work with nested subprograms, since it is
+ ;; based only on the regexps generated by imenu, and thus can only detect the
+ ;; beginning of subprograms, not the end.
+ ;; Fix is: redefine a new function ada-which-function, and call it when the
+ ;; major-mode is ada-mode.
+
+ (make-local-variable 'which-func-functions)
+ (setq which-func-functions '(ada-which-function))
+
;; Support for indent-new-comment-line (Especially for XEmacs)
(setq comment-multi-line nil)
- (defconst comment-indent-function (lambda () comment-column))
- (setq major-mode 'ada-mode)
- (setq mode-name "Ada")
+ (setq major-mode 'ada-mode
+ mode-name "Ada")
(use-local-map ada-mode-map)
- (if ada-xemacs
- (funcall (symbol-function 'easy-menu-add)
- ada-mode-menu ada-mode-map))
+ (easy-menu-add ada-mode-menu ada-mode-map)
(set-syntax-table ada-mode-syntax-table)
(if ada-clean-buffer-before-saving
(progn
;; remove all spaces at the end of lines in the whole buffer.
- (add-hook 'local-write-file-hooks 'delete-trailing-whitespace)
+ (add-hook 'local-write-file-hooks 'delete-trailing-whitespace)
;; convert all tabs to the correct number of spaces.
(add-hook 'local-write-file-hooks
(lambda () (untabify (point-min) (point-max))))))
- (run-hooks 'ada-mode-hook)
+ (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)
+
+ (run-mode-hooks 'ada-mode-hook)
+
+ ;; To be run after the hook, in case the user modified
+ ;; ada-fill-comment-prefix
+ (make-local-variable 'comment-start)
+ (if ada-fill-comment-prefix
+ (set 'comment-start ada-fill-comment-prefix)
+ (set 'comment-start "-- "))
;; Run this after the hook to give the users a chance to activate
;; font-lock-mode
- (unless ada-xemacs
+ (unless (featurep 'xemacs)
(progn
(ada-initialize-properties)
- (make-local-hook 'font-lock-mode-hook)
(add-hook 'font-lock-mode-hook 'ada-deactivate-properties nil t)))
;; the following has to be done after running the ada-mode-hook
(if ada-auto-case
(ada-activate-keys-for-case)))
+(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 -1) (point))
+ (goto-char aa-end)))))
+
+;; transient-mark-mode and mark-active are not defined in XEmacs
+(defun ada-region-selected ()
+ "Return t if a region has been selected by the user and is still active."
+ (or (and (featurep 'xemacs) (funcall (symbol-function 'region-active-p)))
+ (and (not (featurep 'xemacs))
+ (symbol-value 'transient-mark-mode)
+ (symbol-value 'mark-active))))
+
\f
;;-----------------------------------------------------------------
;; auto-casing
;; For backward compatibility, this variable can also be a string.
;;-----------------------------------------------------------------
+(defun ada-save-exceptions-to-file (file-name)
+ "Save the exception lists `ada-case-exception' and
+`ada-case-exception-substring' to the file FILE-NAME."
+
+ ;; Save the list in the file
+ (find-file (expand-file-name file-name))
+ (erase-buffer)
+ (mapcar (lambda (x) (insert (car x) "\n"))
+ (sort (copy-sequence ada-case-exception)
+ (lambda(a b) (string< (car a) (car b)))))
+ (mapcar (lambda (x) (insert "*" (car x) "\n"))
+ (sort (copy-sequence ada-case-exception-substring)
+ (lambda(a b) (string< (car a) (car b)))))
+ (save-buffer)
+ (kill-buffer nil)
+ )
+
(defun ada-create-case-exception (&optional word)
- "Defines WORD as an exception for the casing system.
+ "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 words is added to the first file in `ada-case-exception-file'.
The standard casing rules will no longer apply to this word."
(interactive)
(let ((previous-syntax-table (syntax-table))
- (exception-list '())
file-name
)
((listp ada-case-exception-file)
(setq file-name (car ada-case-exception-file)))
(t
- (error "No exception file specified")))
+ (error (concat "No exception file specified. "
+ "See variable ada-case-exception-file"))))
(set-syntax-table ada-mode-symbol-syntax-table)
(unless word
(skip-syntax-backward "w")
(setq word (buffer-substring-no-properties
(point) (save-excursion (forward-word 1) (point))))))
+ (set-syntax-table previous-syntax-table)
;; Reread the exceptions file, in case it was modified by some other,
- ;; and to keep the end-of-line comments that may exist in it.
- (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))
- (add-to-list 'exception-list
- (list
- (buffer-substring-no-properties
- (point) (save-excursion (forward-word 1) (point)))
- (buffer-substring-no-properties
- (save-excursion (forward-word 1) (point))
- (save-excursion (end-of-line) (point)))
- t))
- (forward-line 1))
- (kill-buffer nil)
- (set-buffer buffer)))
+ (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 exception-list '()))
- (assoc-ignore-case word exception-list))
- (setcar (assoc-ignore-case word exception-list)
- word)
- (add-to-list 'exception-list (list word "" t))
- )
-
(if (and (not (equal ada-case-exception '()))
- (assoc-ignore-case word ada-case-exception))
- (setcar (assoc-ignore-case word ada-case-exception)
- word)
+ (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))
)
- ;; Save the list in the file
- (find-file (expand-file-name file-name))
- (erase-buffer)
- (mapcar (lambda (x) (insert (car x) (nth 1 x) "\n"))
- (sort exception-list
- (lambda(a b) (string< (car a) (car b)))))
- (save-buffer)
- (kill-buffer nil)
- (set-syntax-table previous-syntax-table)
+ (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")
+ (set 'word (buffer-substring-no-properties
+ (point)
+ (save-excursion (forward-word 1) (point))))))
+ (modify-syntax-entry ?_ (make-string 1 underscore-syntax)
+ (syntax-table))))))
+
+ ;; Reread the exceptions file, in case it was modified by some other,
+ (ada-case-read-exceptions-from-file file-name)
+
+ ;; If the word is already in the list, even with a different casing
+ ;; we simply want to replace it.
+ (if (and (not (equal ada-case-exception-substring '()))
+ (assoc-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 (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))
;; priority should be applied to each casing exception
(let ((word (buffer-substring-no-properties
(point) (save-excursion (forward-word 1) (point)))))
- (unless (assoc-ignore-case word ada-case-exception)
- (add-to-list 'ada-case-exception (cons word t))))
+
+ ;; 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)
(interactive)
;; Reinitialize the casing exception list
- (setq ada-case-exception '())
+ (setq ada-case-exception '()
+ ada-case-exception-substring '())
(cond ((stringp ada-case-exception-file)
(ada-case-read-exceptions-from-file 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
(interactive)
(if (or (equal ada-case-exception '())
(equal (char-after) ?_))
- (funcall ada-case-identifier -1)
+ (progn
+ (funcall ada-case-identifier -1)
+ (ada-adjust-case-substring))
(progn
(let ((end (point))
(point)))
match)
;; If we have an exception, replace the word by the correct casing
- (if (setq match (assoc-ignore-case (buffer-substring start end)
- ada-case-exception))
+ (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))))))
+ (funcall ada-case-identifier -1)
+ (ada-adjust-case-substring))))))
(defun ada-after-keyword-p ()
- "Returns t if cursor is after a keyword that is not an attribute."
+ "Return t if cursor is after a keyword that is not an attribute."
(save-excursion
(forward-word -1)
(and (not (and (char-before)
(looking-at (concat ada-keywords "[^_]")))))
(defun ada-adjust-case (&optional force-identifier)
- "Adjust the case of the word before the just typed character.
+ "Adjust the case of the word before the character just typed.
If FORCE-IDENTIFIER is non-nil then also adjust keyword as identifier."
- (forward-char -1)
- (if (and (> (point) 1)
- ;; or if at the end of a character constant
- (not (and (eq (char-after) ?')
- (eq (char-before (1- (point))) ?')))
- ;; or if the previous character was not part of a word
- (eq (char-syntax (char-before)) ?w)
- ;; if in a string or a comment
- (not (ada-in-string-or-comment-p))
- )
- (if (save-excursion
- (forward-word -1)
- (or (= (point) (point-min))
- (backward-char 1))
- (= (char-after) ?'))
- (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)
+ (if (not (bobp))
+ (progn
+ (forward-char -1)
+ (if (and (not (bobp))
+ ;; or if at the end of a character constant
+ (not (and (eq (following-char) ?')
+ (eq (char-before (1- (point))) ?')))
+ ;; or if the previous character was not part of a word
+ (eq (char-syntax (char-before)) ?w)
+ ;; if in a string or a comment
+ (not (ada-in-string-or-comment-p))
+ )
+ (if (save-excursion
+ (forward-word -1)
+ (or (= (point) (point-min))
+ (backward-char 1))
+ (= (following-char) ?'))
+ (funcall ada-case-attribute -1)
+ (if (and
+ (not force-identifier) ; (MH)
+ (ada-after-keyword-p))
+ (funcall ada-case-keyword -1)
+ (ada-adjust-case-identifier))))
+ (forward-char 1)
+ ))
)
(defun ada-adjust-case-interactive (arg)
"Adjust the case of the previous word, and process the character just typed.
-ARG is the prefix the user entered with \C-u."
+ARG is the prefix the user entered with \\[universal-argument]."
(interactive "P")
(if ada-auto-case
))
(defun ada-activate-keys-for-case ()
- "Modifies the key bindings for all the keys that should readjust the casing."
+ "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.
(delete-char 1)))))
(defun ada-no-auto-case (&optional arg)
- "Does nothing.
+ "Do nothing.
This function can be used for the auto-casing variables in the ada-mode, to
adapt to unusal auto-casing schemes. Since it does nothing, you can for
instance use it for `ada-case-identifier' if you don't want any special
(modify-syntax-entry ?_ "w")))
(defun ada-adjust-case-region (from to)
- "Adjusts the case of all words in the region between FROM and TO.
-Attention: This function might take very long for big regions !"
+ "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)
(defun ada-adjust-case-buffer ()
"Adjusts the case of all words in the whole buffer.
-ATTENTION: This function might take very long for big buffers !"
+ATTENTION: This function might take very long for big buffers!"
(interactive "*")
(ada-adjust-case-region (point-min) (point-max)))
;;--------------------------------------------------------------
(defun ada-format-paramlist ()
- "Reformats the parameter list point is in."
+ "Reformat the parameter list point is in."
(interactive)
(let ((begin nil)
(end nil)
;; check if really inside parameter list
(or (ada-in-paramlist-p)
- (error "not in parameter list"))
+ (error "Not in parameter list"))
;; find start of current parameter-list
(ada-search-ignore-string-comment
(defun ada-scan-paramlist (begin end)
"Scan the parameter list found in between BEGIN and END.
-Returns the equivalent internal parameter list."
+Return the equivalent internal parameter list."
(let ((paramlist (list))
(param (list))
(notend t)
(reverse paramlist)))
(defun ada-insert-paramlist (paramlist)
- "Inserts a formatted PARAMLIST in the buffer."
+ "Insert a formatted PARAMLIST in the buffer."
(let ((i (length paramlist))
(parlen 0)
(typlen 0)
(message "indenting ... done")))
(defun ada-indent-newline-indent ()
- "Indents the current line, inserts a newline and then indents the new line."
+ "Indent the current line, insert a newline and then indent the new line."
(interactive "*")
(ada-indent-current)
(newline)
(defun ada-indent-newline-indent-conditional ()
"Insert a newline and indent it.
The original line is indented first if `ada-indent-after-return' is non-nil.
-This function is intended to be bound to the \C-m and \C-j keys."
+This function is intended to be bound to the C-m and C-j keys."
(interactive "*")
(if ada-indent-after-return (ada-indent-current))
(newline)
(ada-indent-current))
(defun ada-justified-indent-current ()
- "Indent the current line and explains how the calculation was done."
+ "Indent the current line and explain how the calculation was done."
(interactive)
(let ((cur-indent (ada-indent-current)))
- (message nil)
- (if (equal (cdr cur-indent) '(0))
- (message "same indentation")
- (message (mapconcat (lambda(x)
- (cond
- ((symbolp x)
- (symbol-name x))
- ((numberp x)
- (number-to-string x))
- ((listp x)
- (concat "- " (symbol-name (cadr x))))
- ))
- (cdr cur-indent)
- " + ")))
+ (let ((line (save-excursion
+ (goto-char (car cur-indent))
+ (count-lines 1 (point)))))
+
+ (if (equal (cdr cur-indent) '(0))
+ (message (concat "same indentation as line " (number-to-string line)))
+ (message (mapconcat (lambda(x)
+ (cond
+ ((symbolp x)
+ (symbol-name x))
+ ((numberp x)
+ (number-to-string x))
+ ((listp x)
+ (concat "- " (symbol-name (cadr x))))
+ ))
+ (cdr cur-indent)
+ " + "))))
(save-excursion
(goto-char (car cur-indent))
(sit-for 1))))
(kill-emacs 0))
(defsubst ada-goto-previous-word ()
- "Moves point to the beginning of the previous word of Ada code.
-Returns the new position of point or nil if not found."
+ "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.
-Returns the calculation that was done, including the reference point and the
+Return the calculation that was done, including the reference point and the
offset."
(interactive)
(let ((previous-syntax-table (syntax-table))
;; This need to be done here so that the advice is not always
;; activated (this might interact badly with other modes)
- (if ada-xemacs
+ (if (featurep 'xemacs)
(ad-activate 'parse-partial-sexp t))
(save-excursion
;; restore syntax-table
(set-syntax-table previous-syntax-table)
- (if ada-xemacs
+ (if (featurep 'xemacs)
(ad-deactivate 'parse-partial-sexp))
)
;; check if we have something like this (Table_Component_Type =>
;; Source_File_Record)
(save-excursion
- (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)
- (list column 0))))
+
+ ;; 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
;; starting with e
;;---------------------------
- ((= (char-after) ?e)
+ ((= (downcase (char-after)) ?e)
(cond
;; ------- end ------
(if (looking-at ada-named-block-re)
(setq label (- ada-label-indent))))))))
- (list (+ (save-excursion (back-to-indentation) (point)) label) 0))))
+ ;; 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 ----
;; starting with w (when)
;;---------------------------
- ((and (= (char-after) ?w)
+ ((and (= (downcase (char-after)) ?w)
(looking-at "when\\>"))
(save-excursion
(ada-goto-matching-start 1)
;; starting with t (then)
;;---------------------------
- ((and (= (char-after) ?t)
+ ((and (= (downcase (char-after)) ?t)
(looking-at "then\\>"))
(if (save-excursion (ada-goto-previous-word)
(looking-at "and\\>"))
;; starting with l (loop)
;;---------------------------
- ((and (= (char-after) ?l)
+ ((and (= (downcase (char-after)) ?l)
(looking-at "loop\\>"))
(setq pos (point))
(save-excursion
(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 (= (char-after) ?b)
+ ((and (= (downcase (char-after)) ?b)
(looking-at "begin\\>"))
(save-excursion
(if (ada-goto-matching-decl-start t)
;; starting with i (is)
;;---------------------------
- ((and (= (char-after) ?i)
+ ((and (= (downcase (char-after)) ?i)
(looking-at "is\\>"))
(if (and ada-indent-is-separate
(list (progn (back-to-indentation) (point)) 'ada-indent))
(save-excursion
(ada-goto-stmt-start)
- (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent))))
+ (if (looking-at "\\<package\\|procedure\\|function\\>")
+ (list (progn (back-to-indentation) (point)) 0)
+ (list (progn (back-to-indentation) (point)) 'ada-indent)))))
;;---------------------------
- ;; starting with r (record, return, renames)
+ ;; starting with r (return, renames)
;;---------------------------
- ((= (char-after) ?r)
-
- (cond
-
- ;; ----- record ------
-
- ((looking-at "record\\>")
- (save-excursion
- (ada-search-ignore-string-comment
- "\\<\\(type\\|use\\)\\>" t nil)
- (if (looking-at "\\<use\\>")
- (ada-search-ignore-string-comment "for" t nil nil 'word-search-backward))
- (list (progn (back-to-indentation) (point)) 'ada-indent-record-rel-type)))
-
- ;; ----- return or renames ------
-
- ((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
- (= (char-after (car pos)) ?r))
- (goto-char (car pos)))
- (setq var 'ada-indent-renames)))
+ ((and (= (downcase (char-after)) ?r)
+ (looking-at "re\\(turn\\|names\\)\\>"))
- (forward-comment -1000)
- (if (= (char-before) ?\))
- (forward-sexp -1)
- (forward-word -1))
-
- ;; If there is a parameter list, and we have a function declaration
- ;; or a access to subprogram declaration
- (let ((num-back 1))
- (if (and (= (char-after) ?\()
- (save-excursion
- (or (progn
- (backward-word 1)
- (looking-at "function\\>"))
- (progn
- (backward-word 1)
- (setq num-back 2)
- (looking-at "function\\>")))))
-
- ;; The indentation depends of the value of ada-indent-return
- (if (<= (eval var) 0)
- (list (point) (list '- var))
- (list (progn (backward-word num-back) (point))
- var))
-
- ;; Else there is no parameter list, but we have a function
- ;; Only do something special if the user want to indent
- ;; relative to the "function" keyword
- (if (and (> (eval var) 0)
- (save-excursion (forward-word -1)
- (looking-at "function\\>")))
- (list (progn (forward-word -1) (point)) var)
-
- ;; Else...
- (ada-indent-on-previous-lines nil orgpoint orgpoint)))))))
- ))
+ (save-excursion
+ (let ((var 'ada-indent-return))
+ ;; If looking at a renames, skip the 'return' statement too
+ (if (looking-at "renames")
+ (let (pos)
+ (save-excursion
+ (set 'pos (ada-search-ignore-string-comment ";\\|return\\>" t)))
+ (if (and pos
+ (= (downcase (char-after (car pos))) ?r))
+ (goto-char (car pos)))
+ (set 'var 'ada-indent-renames)))
+
+ (forward-comment -1000)
+ (if (= (char-before) ?\))
+ (forward-sexp -1)
+ (forward-word -1))
+
+ ;; If there is a parameter list, and we have a function declaration
+ ;; or a access to subprogram declaration
+ (let ((num-back 1))
+ (if (and (= (following-char) ?\()
+ (save-excursion
+ (or (progn
+ (backward-word 1)
+ (looking-at "\\(function\\|procedure\\)\\>"))
+ (progn
+ (backward-word 1)
+ (set 'num-back 2)
+ (looking-at "\\(function\\|procedure\\)\\>")))))
+
+ ;; The indentation depends of the value of ada-indent-return
+ (if (<= (eval var) 0)
+ (list (point) (list '- var))
+ (list (progn (backward-word num-back) (point))
+ var))
+
+ ;; Else there is no parameter list, but we have a function
+ ;; Only do something special if the user want to indent
+ ;; relative to the "function" keyword
+ (if (and (> (eval var) 0)
+ (save-excursion (forward-word -1)
+ (looking-at "function\\>")))
+ (list (progn (forward-word -1) (point)) var)
+
+ ;; Else...
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)))))))
;;--------------------------------
;; starting with 'o' or 'p'
;; 'private' as statement-start
;;--------------------------------
- ((and (or (= (char-after) ?o)
- (= (char-after) ?p))
+ ((and (or (= (downcase (char-after)) ?o)
+ (= (downcase (char-after)) ?p))
(or (ada-looking-at-semi-or)
(ada-looking-at-semi-private)))
(save-excursion
- (ada-goto-matching-start 1)
- (list (progn (back-to-indentation) (point)) 0)))
+ ;; ??? 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 (= (char-after) ?d)
+ ((and (= (downcase (char-after)) ?d)
(looking-at "do\\>"))
(save-excursion
(ada-goto-stmt-start)
;; package/function/procedure
;;---------------------------------
- ((and (or (= (char-after) ?p) (= (char-after) ?f))
+ ((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
;;
((looking-at "separate\\>")
(ada-get-indent-nochange))
+
+ ;; A label
+ ((looking-at "<<")
+ (list (+ (save-excursion (back-to-indentation) (point))
+ (- ada-label-indent))))
+
;;
((looking-at "with\\>\\|use\\>")
;; Are we still in that statement, or are we in fact looking at
))
(defun ada-get-indent-open-paren ()
- "Calculates the indentation when point is behind an unclosed parenthesis."
+ "Calculate the indentation when point is behind an unclosed parenthesis."
(list (ada-in-open-paren-p) 0))
(defun ada-get-indent-nochange ()
(list (point) 0)))
(defun ada-get-indent-paramlist ()
- "Calculates the indentation when point is inside a parameter list."
+ "Calculate the indentation when point is inside a parameter list."
(save-excursion
(ada-search-ignore-string-comment "[^ \t\n]" t nil t)
(cond
(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)))))
+ (list (point) 0)))))
(defun ada-get-indent-end (orgpoint)
- "Calculates the indentation when point is just before an end_statement.
+ "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))
(setq indent (list (point) 0))
(if (ada-goto-matching-decl-start t)
(list (progn (back-to-indentation) (point)) 0)
- indent)))))
+ indent))
+ (list (progn (back-to-indentation) (point)) 0)
+ )))
;;
;; anything else - should maybe signal an error ?
;;
'ada-broken-indent))))
(defun ada-get-indent-case (orgpoint)
- "Calculates the indentation when point is just before a case statement.
+ "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)))
(save-excursion
(goto-char (car match-cons))
(unless (ada-search-ignore-string-comment "when" t opos)
- (error "missing 'when' between 'case' and '=>'"))
+ (error "Missing 'when' between 'case' and '=>'"))
(list (save-excursion (back-to-indentation) (point)) 'ada-indent)))
;;
;; case..is..when
'ada-broken-indent)))))
(defun ada-get-indent-when (orgpoint)
- "Calculates the indentation when point is just before a when statement.
+ "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-broken-indent))))
(defun ada-get-indent-if (orgpoint)
- "Calculates the indentation when point is just before an if statement.
+ "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))
(while (and (setq match-cons (ada-search-ignore-string-comment
"\\<\\(then\\|and[ \t]*then\\)\\>"
nil orgpoint))
- (= (char-after (car match-cons)) ?a)))
+ (= (downcase (char-after (car match-cons))) ?a)))
;; If "then" was found (we are looking at it)
(if match-cons
(progn
(list cur-indent 'ada-broken-indent))))
(defun ada-get-indent-block-start (orgpoint)
- "Calculates the indentation when point is at the start of a block.
+ "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
(ada-indent-on-previous-lines t orgpoint)))
+ ;; Special case for record types, for instance for:
+ ;; type A is (B : Integer;
+ ;; C : Integer) is record
+ ;; null; -- This is badly indented otherwise
+ ((looking-at "record")
+
+ ;; If record is at the beginning of the line, indent from there
+ (if (save-excursion
+ (beginning-of-line)
+ (looking-at "^[ \t]*\\(record\\|limited record\\)"))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-indent)
+
+ ;; else indent relative to the type command
+ (list (save-excursion
+ (car (ada-search-ignore-string-comment "\\<type\\>" t)))
+ 'ada-indent)))
+
;; nothing follows the block-start
(t
(list (save-excursion (back-to-indentation) (point)) 'ada-indent)))))
(defun ada-get-indent-subprog (orgpoint)
- "Calculates the indentation when point is just before a subprogram.
+ "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)))
(list cur-indent 'ada-broken-indent)))))
(defun ada-get-indent-noindent (orgpoint)
- "Calculates the indentation when point is just before a 'noindent stmt'.
+ "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
'ada-broken-indent)))))))
(defun ada-get-indent-label (orgpoint)
- "Calculates the indentation when before a label or variable declaration.
+ "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))))
(list cur-indent '(- ada-label-indent))))))
(defun ada-get-indent-loop (orgpoint)
- "Calculates the indentation when just before a loop or a for ... use.
+ "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))
"record" nil orgpoint nil 'word-search-forward))
t)))
(if match-cons
- (goto-char (car match-cons)))
- (list (save-excursion (back-to-indentation) (point)) 'ada-indent))
+ (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
;;
'ada-broken-indent))))))
(defun ada-get-indent-type (orgpoint)
- "Calculates the indentation when before a type statement.
+ "Calculate the indentation when before a type statement.
ORGPOINT is the limit position used in the calculation."
(let ((match-dat nil))
(cond
;; -----------------------------------------------------------
(defun ada-goto-stmt-start ()
- "Moves point to the beginning of the statement that point is in or after.
-Returns the new position of point.
+ "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)
(defun ada-search-prev-end-stmt ()
- "Moves point to previous end-statement.
-Returns a cons cell whose car is the beginning and whose cdr the end of the
-match."
+ "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))
(goto-char (car match-dat))
(unless (ada-in-open-paren-p)
- (if (and (looking-at
- "\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>")
- (save-excursion
- (ada-goto-previous-word)
- (looking-at "\\<\\(end\\|or\\|and\\)\\>[ \t]*[^;]")))
- (forward-word -1)
-
- (save-excursion
- (goto-char (cdr match-dat))
- (ada-goto-next-non-ws)
- (looking-at "(")
- ;; words that can go after an 'is'
- (unless (looking-at
- (eval-when-compile
- (concat "\\<"
- (regexp-opt '("separate" "access" "array"
- "abstract" "new") t)
- "\\>\\|(")))
- (setq found t))))
- ))
+ (cond
+
+ ((and (looking-at
+ "\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>")
+ (save-excursion
+ (ada-goto-previous-word)
+ (looking-at "\\<\\(end\\|or\\|and\\)\\>[ \t]*[^;]")))
+ (forward-word -1))
+
+ ((looking-at "is")
+ (setq found
+ (and (save-excursion (ada-goto-previous-word)
+ (ada-goto-previous-word)
+ (not (looking-at "subtype")))
+
+ (save-excursion (goto-char (cdr match-dat))
+ (ada-goto-next-non-ws)
+ ;; words that can go after an 'is'
+ (not (looking-at
+ (eval-when-compile
+ (concat "\\<"
+ (regexp-opt
+ '("separate" "access" "array"
+ "abstract" "new") t)
+ "\\>\\|("))))))))
+
+ (t
+ (setq found t))
+ )))
(if found
match-dat
(defun ada-goto-next-non-ws (&optional limit)
- "Skips white spaces, newlines and comments to next non-ws character.
+ "Skip white spaces, newlines and comments to next non-ws character.
Stop the search at LIMIT.
Do not call this function from within a string."
(unless limit
(defun ada-goto-stmt-end (&optional limit)
- "Moves point to the end of the statement that point is in or before.
-Returns the new position of point or nil if not found.
+ "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)
(defun ada-goto-next-word (&optional backward)
- "Moves point to the beginning of the next word of Ada code.
+ "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.
-Returns the new position of point or nil if not found."
+Return the new position of point or nil if not found."
(let ((match-cons nil)
(orgpoint (point))
(old-syntax (char-to-string (char-syntax ?_))))
(defun ada-check-matching-start (keyword)
- "Signals an error if matching block start is not 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)))
+ (error "Matching start is not '%s'" keyword)))
(defun ada-check-defun-name (defun-name)
- "Checks if the name of the matching defun really is DEFUN-NAME.
-Assumes point to be already positioned by 'ada-goto-matching-start'.
+ "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'
;; should be looking-at the correct name
;;
(unless (looking-at (concat "\\<" defun-name "\\>"))
- (error "matching defun has different name: %s"
+ (error "Matching defun has different name: %s"
(buffer-substring (point)
(progn (forward-sexp 1) (point))))))))
(defun ada-goto-matching-decl-start (&optional noerror recursive)
- "Moves point to the matching declaration start of the current 'begin'.
+ "Move point to the matching declaration start of the current 'begin'.
If NOERROR is non-nil, it only returns nil if no match was found."
(let ((nest-count 1)
+
+ ;; first should be set to t if we should stop at the first
+ ;; "begin" we encounter.
(first (not recursive))
(count-generic nil)
- (stop-at-when nil)
+ (stop-at-when nil)
)
;; Ignore "when" most of the time, except if we are looking at the
t)
(if (looking-at "end")
- (ada-goto-matching-decl-start noerror t)
+ (ada-goto-matching-start 1 noerror t)
+ ;; (ada-goto-matching-decl-start noerror t)
(setq loop-again nil)
(unless (looking-at "begin")
;;
((looking-at "declare\\|generic")
(setq nest-count (1- nest-count))
- (setq first nil))
+ (setq first t))
;;
((looking-at "is")
;; check if it is only a type definition, but not a protected
(skip-chars-backward "a-zA-Z0-9_.'")
(ada-goto-previous-word)
(and
- (looking-at "\\<\\(sub\\)?type\\>")
+ (looking-at "\\<\\(sub\\)?type\\|case\\>")
(save-match-data
(ada-goto-previous-word)
(not (looking-at "\\<protected\\>"))))
(setq nest-count 0))
;;
((looking-at "when")
- (if stop-at-when
- (setq nest-count (1- nest-count)))
- (setq first nil))
+ (save-excursion
+ (forward-word -1)
+ (unless (looking-at "\\<exit[ \t\n]*when\\>")
+ (progn
+ (if stop-at-when
+ (setq nest-count (1- nest-count)))
+ ))))
+ ;;
+ ((looking-at "begin")
+ (setq first nil))
;;
(t
(setq nest-count (1+ nest-count))
(looking-at "declare\\|generic")))
t
(if noerror nil
- (error "no matching proc/func/task/declare/package/protected")))
+ (error "No matching proc/func/task/declare/package/protected")))
))
(defun ada-goto-matching-start (&optional nest-level noerror gotothen)
- "Moves point to the beginning of a block-start.
-Which block depends on the value of NEST-LEVEL, which defaults to zero. If
-NOERROR is non-nil, it only returns nil if no matching start was found.
+ "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)
(ada-goto-previous-word)
(if (looking-at "\\<end\\>[ \t]*[^;]")
;; it ends a block => increase nest depth
- (progn
- (setq nest-count (1+ nest-count))
- (setq pos (point)))
+ (setq nest-count (1+ nest-count)
+ pos (point))
+
;; it starts a block => decrease nest depth
(setq nest-count (1- nest-count))))
(goto-char pos))
(error (concat
"No matching 'is' or 'renames' for 'package' at"
" line "
- (number-to-string (count-lines (point-min)
- (1+ current)))))))
+ (number-to-string (count-lines 1 (1+ current)))))))
(unless (looking-at "renames")
(progn
(forward-word 1)
(ada-goto-next-non-ws)
;; ignore it if it is only a declaration with 'new'
- (if (not (looking-at "\\<\\(new\\|separate\\)\\>"))
+ ;; We could have package Foo is new ....
+ ;; or package Foo is separate;
+ ;; or package Foo is begin null; end Foo
+ ;; for elaboration code (elaboration)
+ (if (not (looking-at "\\<\\(new\\|separate\\|begin\\)\\>"))
(setq nest-count (1- nest-count)))))))
;; found task start => check if it has a body
((looking-at "task")
;;
(setq found (zerop nest-count))))) ; end of loop
- (if found
- ;;
- ;; match found => is there anything else to do ?
- ;;
- (progn
- (cond
- ;;
- ;; found 'if' => skip to 'then', if it's on a separate line
- ;; and GOTOTHEN is non-nil
- ;;
- ((and
- gotothen
- (looking-at "if")
- (save-excursion
- (ada-search-ignore-string-comment "then" nil nil nil
- 'word-search-forward)
- (back-to-indentation)
- (looking-at "\\<then\\>")))
- (goto-char (match-beginning 0)))
- ;;
- ;; found 'do' => skip back to 'accept'
- ;;
- ((looking-at "do")
- (unless (ada-search-ignore-string-comment "accept" t nil nil
- 'word-search-backward)
- (error "missing 'accept' in front of 'do'"))))
- (point))
-
- (if noerror
- nil
- (error "no matching start")))))
+ (if (bobp)
+ (point)
+ (if found
+ ;;
+ ;; match found => is there anything else to do ?
+ ;;
+ (progn
+ (cond
+ ;;
+ ;; found 'if' => skip to 'then', if it's on a separate line
+ ;; and GOTOTHEN is non-nil
+ ;;
+ ((and
+ gotothen
+ (looking-at "if")
+ (save-excursion
+ (ada-search-ignore-string-comment "then" nil nil nil
+ 'word-search-forward)
+ (back-to-indentation)
+ (looking-at "\\<then\\>")))
+ (goto-char (match-beginning 0)))
+
+ ;;
+ ;; found 'do' => skip back to 'accept'
+ ;;
+ ((looking-at "do")
+ (unless (ada-search-ignore-string-comment
+ "accept" t nil nil
+ 'word-search-backward)
+ (error "Missing 'accept' in front of 'do'"))))
+ (point))
+
+ (if noerror
+ nil
+ (error "No matching start"))))))
(defun ada-goto-matching-end (&optional nest-level noerror)
- "Moves point to the end of a block.
+ "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 found no matching start."
- (let ((nest-count (if nest-level nest-level 0))
- (found nil))
+ (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
- (eval-when-compile
- (concat "\\<"
- (regexp-opt '("end" "loop" "select" "begin" "case"
- "if" "task" "package" "record" "do") t)
- "\\>")) nil))
+ (ada-search-ignore-string-comment regex nil))
;;
;; calculate nest-depth
;;
(backward-word 1)
(cond
+ ;; procedures and functions need to be processed recursively, in
+ ;; case they are defined in a declare/begin block, as in:
+ ;; declare -- NL 0 (nested level)
+ ;; A : Boolean;
+ ;; procedure B (C : D) is
+ ;; begin -- NL 1
+ ;; null;
+ ;; end B; -- NL 0, and we would exit
+ ;; begin
+ ;; end; -- we should exit here
+ ;; processing them recursively avoids the need for any special
+ ;; handling.
+ ;; Nothing should be done if we have only the specs or a
+ ;; generic instantion.
+
+ ((and (looking-at "\\<procedure\\|function\\>"))
+ (if first
+ (forward-word 1)
+
+ (setq pos (point))
+ (ada-search-ignore-string-comment "is\\|;")
+ (if (= (char-before) ?s)
+ (progn
+ (ada-goto-next-non-ws)
+ (unless (looking-at "\\<new\\>")
+ (progn
+ (goto-char pos)
+ (ada-goto-matching-end 0 t)))))))
+
;; found block end => decrease nest depth
((looking-at "\\<end\\>")
- (setq nest-count (1- nest-count))
- ;; skip the following keyword
- (if (progn
- (skip-chars-forward "end")
- (ada-goto-next-non-ws)
- (looking-at "\\<\\(loop\\|select\\|record\\|case\\|if\\)\\>"))
- (forward-word 1)))
- ;; found package start => check if it really starts a block
+ (setq nest-count (1- nest-count)
+ found (<= nest-count 0))
+ ;; skip the following keyword
+ (if (progn
+ (skip-chars-forward "end")
+ (ada-goto-next-non-ws)
+ (looking-at "\\<\\(loop\\|select\\|record\\|case\\|if\\)\\>"))
+ (forward-word 1)))
+
+ ;; found package start => check if it really starts a block, and is not
+ ;; in fact a generic instantiation for instance
((looking-at "\\<package\\>")
(ada-search-ignore-string-comment "is" nil nil nil
'word-search-forward)
;; 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))))
+ (setq nest-count (1+ nest-count)
+ found (<= nest-count 0))))
+
;; all the other block starts
(t
- (setq nest-count (1+ nest-count))
+ (if (not first)
+ (setq nest-count (1+ nest-count)))
+ (setq found (<= nest-count 0))
(forward-word 1))) ; end of 'cond'
- ;; match is found, if nest-depth is zero
- ;;
- (setq found (zerop nest-count))) ; end of loop
+ (setq first nil))
(if found
t
(if noerror
nil
- (error "no matching end")))
+ (error "No matching end")))
))
(defun ada-search-ignore-string-comment
(search-re &optional backward limit paramlists search-func)
"Regexp-search for SEARCH-RE, ignoring comments, strings.
-If PARAMLISTS is nil, ignore parameter lists. Returns a cons cell of
+If PARAMLISTS is nil, ignore parameter lists. Returns a cons cell of
begin and end of match data or nil, if not found.
The search is done using SEARCH-FUNC, which should search backward if
-BACKWARD is non-nil, forward otherwise. SEARCH-FUNC can be optimized in case
-we are searching for a constant string.
+BACKWARD is non-nil, forward otherwise. SEARCH-FUNC can be optimized
+in case we are searching for a constant string.
The search stops at pos LIMIT.
-Point is moved at the beginning of the search-re."
+Point is moved at the beginning of the SEARCH-RE."
(let (found
begin
end
;; If inside a string, skip it (and the following comments)
;;
((ada-in-string-p parse-result)
- (if ada-xemacs
+ (if (featurep 'xemacs)
(search-backward "\"" nil t)
(goto-char (nth 8 parse-result)))
(unless backward (forward-sexp 1)))
;; There is a special code for comments at the end of the file
;;
((ada-in-comment-p parse-result)
- (if ada-xemacs
+ (if (featurep 'xemacs)
(progn
(forward-line 1)
(beginning-of-line)
;; -------------------------------------------------------
(defun ada-in-decl-p ()
- "Returns t if point is inside a declarative part.
+ "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
(defun ada-looking-at-semi-or ()
- "Returns t if looking-at an 'or' following a semicolon."
+ "Return t if looking at an 'or' following a semicolon."
(save-excursion
(and (looking-at "\\<or\\>")
(progn
(defun ada-looking-at-semi-private ()
- "Returns t if looking at the start of a private section in a package.
+ "Return t if looking at the start of a private section in a package.
Returns nil if the private is part of the package name, as in
'private package A is...' (this can only happen at top level)."
(save-excursion
;; 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)
- (or (= (char-before) ?\;)
- (and (forward-word -3)
- (looking-at "\\<package\\>")))))))
+ (and (not (bobp))
+ (or (= (char-before) ?\;)
+ (and (forward-word -3)
+ (looking-at "\\<package\\>"))))))))
(defun ada-in-paramlist-p ()
- "Returns t if point is inside a parameter-list."
+ "Return t if point is inside a parameter-list."
(save-excursion
(and
(ada-search-ignore-string-comment "(\\|)" t nil t)
;; subprogram definition: procedure .... (
;; Let's skip back over the first one
(progn
- (skip-syntax-backward " ")
+ (skip-chars-backward " \t\n")
(if (= (char-before) ?\")
(backward-char 3)
(backward-word 1))
result))
(defun ada-in-open-paren-p ()
- "Returns the position of the first non-ws behind the last unclosed
+ "Return the position of the first non-ws behind the last unclosed
parenthesis, or nil."
(save-excursion
(let ((parse (parse-partial-sexp
(if (nth 1 parse)
(progn
(goto-char (1+ (nth 1 parse)))
- (skip-chars-forward " \t")
+
+ ;; Skip blanks, if they are not followed by a comment
+ ;; See:
+ ;; type A is ( Value_0,
+ ;; Value_1);
+ ;; type B is ( -- comment
+ ;; Value_2);
+
+ (if (or (not ada-indent-handle-comment-special)
+ (not (looking-at "[ \t]+--")))
+ (skip-chars-forward " \t"))
+
(point))))))
\f
(defun ada-tab ()
"Do indenting or tabbing according to `ada-tab-policy'.
In Transient Mark mode, if the mark is active, operate on the contents
-of the region. Otherwise, operates only on the current line."
+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)
- ;; transient-mark-mode and mark-active are not defined in XEmacs
- (if (or (and ada-xemacs (funcall (symbol-function 'region-active-p)))
- (and (not ada-xemacs)
- (symbol-value 'transient-mark-mode)
- (symbol-value 'mark-active)))
+ (if (ada-region-selected)
(ada-indent-region (region-beginning) (region-end))
(ada-indent-current)))
- ((eq ada-tab-policy 'always-tab) (error "not implemented"))
+ ((eq ada-tab-policy 'always-tab) (error "Not implemented"))
))
(defun ada-untab (arg)
"Delete leading indenting according to `ada-tab-policy'."
(interactive "P")
(cond ((eq ada-tab-policy 'indent-rigidly) (ada-untab-hard))
- ((eq ada-tab-policy 'indent-auto) (error "not implemented"))
- ((eq ada-tab-policy 'always-tab) (error "not implemented"))
+ ((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."
+ "Ada mode version of the `indent-line-function'."
(interactive "*")
(let ((starting-point (point-marker)))
(beginning-of-line)
(forward-char ada-indent)))
(defun ada-untab-hard ()
- "indent current line to previous tab stop."
+ "Indent current line to previous tab stop."
(interactive)
(let ((bol (save-excursion (progn (beginning-of-line) (point))))
(eol (save-excursion (progn (end-of-line) (point)))))
;; -- 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]*\\([^-]\\)" nil t)
- (replace-match "-- \\1"))
+ (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)
- (replace-match " ("))
+ (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)
- (replace-match "("))
+ (if (not (ada-in-string-or-comment-p))
+ (replace-match "(")))
(goto-char (point-min))
(while (re-search-forward ")[ \t]+)" nil t)
- (replace-match "))"))
+ (if (not (ada-in-string-or-comment-p))
+ (replace-match "))")))
(goto-char (point-min))
(while (re-search-forward "\\>:" nil t)
- (replace-match " :"))
- (goto-char (point-min))
- (while (re-search-forward ",\\<" nil t)
- (replace-match ", "))
+ (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]*\\.\\.[ \t]*" nil t)
- (replace-match " .. "))
+ (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)
- (if (not (ada-in-string-or-comment-p))
+ (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-char -1)
- (cond
- ((looking-at "/=")
- (replace-match " /= "))
- ((looking-at ":=")
- (replace-match ":= "))
- ((not (looking-at "--"))
- (replace-match " \\1 ")))
- (forward-char 2))))
+ (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)))
))
;; -------------------------------------------------------------
(defun ada-move-to-start ()
- "Moves point to the matching start of the current Ada structure."
+ "Move point to the matching start of the current Ada structure."
(interactive)
(let ((pos (point))
(previous-syntax-table (syntax-table)))
(progn
(set-syntax-table ada-mode-symbol-syntax-table)
- (message "searching for block start ...")
(save-excursion
;;
;; do nothing if in string or comment or not on 'end ...;'
(or (looking-at "[ \t]*\\<end\\>")
(backward-word 1))
(or (looking-at "[ \t]*\\<end\\>")
- (error "not on end ...;")))
+ (error "Not on end ...;")))
(ada-goto-matching-start 1)
(setq pos (point))
) ; end of save-excursion
;; now really move to the found position
- (goto-char pos)
- (message "searching for block start ... done"))
+ (goto-char pos))
;; restore syntax-table
(set-syntax-table previous-syntax-table))))
(defun ada-move-to-end ()
- "Moves point to the matching end of the block around point.
+ "Move point to the matching end of the block around point.
Moves to 'begin' if in a declarative part."
(interactive)
(let ((pos (point))
+ decl-start
(previous-syntax-table (syntax-table)))
(unwind-protect
(progn
(set-syntax-table ada-mode-symbol-syntax-table)
- (message "searching for block end ...")
(save-excursion
- (forward-char 1)
(cond
+ ;; Go to the beginning of the current word, and check if we are
;; directly on 'begin'
- ((save-excursion
- (ada-goto-previous-word)
- (looking-at "\\<begin\\>"))
- (ada-goto-matching-end 1))
- ;; on first line of defun declaration
- ((save-excursion
- (and (ada-goto-stmt-start)
- (looking-at "\\<function\\>\\|\\<procedure\\>" )))
- (ada-search-ignore-string-comment "begin" nil nil nil
- 'word-search-forward))
+ ((save-excursion
+ (skip-syntax-backward "w")
+ (looking-at "\\<begin\\>"))
+ (ada-goto-matching-end 1)
+ )
+
+ ;; on first line of subprogram body
+ ;; Do nothing for specs or generic instantion, since these are
+ ;; handled as the general case (find the enclosing block)
+ ;; We also need to make sure that we ignore nested subprograms
+ ((save-excursion
+ (and (skip-syntax-backward "w")
+ (looking-at "\\<function\\>\\|\\<procedure\\>" )
+ (ada-search-ignore-string-comment "is\\|;")
+ (not (= (char-before) ?\;))
+ ))
+ (skip-syntax-backward "w")
+ (ada-goto-matching-end 0 t))
+
;; on first line of task declaration
((save-excursion
(and (ada-goto-stmt-start)
(ada-goto-matching-end 0))
;; package start
((save-excursion
- (and (ada-goto-matching-decl-start t)
-
(looking-at "\\<package\\>")))
+ (setq decl-start (and (ada-goto-matching-decl-start t) (point)))
+
(and decl-start (looking-at "\\<package\\>")))
(ada-goto-matching-end 1))
+
+ ;; On a "declare" keyword
+ ((save-excursion
+ (skip-syntax-backward "w")
+ (looking-at "\\<declare\\>"))
+ (ada-goto-matching-end 0 t))
+
;; inside a 'begin' ... 'end' block
- ((save-excursion
- (ada-goto-matching-decl-start t))
- (ada-search-ignore-string-comment "begin" nil nil nil
- 'word-search-forward))
+ (decl-start
+ (goto-char decl-start)
+ (ada-goto-matching-end 0 t))
+
;; (hopefully ;-) everything else
(t
(ada-goto-matching-end 1)))
)
;; now really move to the position found
- (goto-char pos)
- (message "searching for block end ... done"))
+ (goto-char pos))
;; restore syntax-table
(set-syntax-table previous-syntax-table))))
(defun ada-next-procedure ()
- "Moves point to 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 1))
+ (goto-char (match-beginning 2))
(error "No more functions/procedures/tasks")))
(defun ada-previous-procedure ()
- "Moves point to 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 1))
+ (goto-char (match-beginning 2))
(error "No more functions/procedures/tasks")))
(defun ada-next-package ()
- "Moves point to next package."
+ "Move point to next package."
(interactive)
(end-of-line)
(if (re-search-forward ada-package-start-regexp nil t)
(error "No more packages")))
(defun ada-previous-package ()
- "Moves point to previous package."
+ "Move point to previous package."
(interactive)
(beginning-of-line)
(if (re-search-backward ada-package-start-regexp nil t)
(define-key ada-mode-map "\t" 'ada-tab)
(define-key ada-mode-map "\C-c\t" 'ada-justified-indent-current)
(define-key ada-mode-map "\C-c\C-l" 'ada-indent-region)
- (if ada-xemacs
+ (if (featurep 'xemacs)
(define-key ada-mode-map '(shift tab) 'ada-untab)
- (define-key ada-mode-map [S-tab] 'ada-untab))
+ (define-key ada-mode-map [(shift tab)] 'ada-untab))
(define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist)
;; We don't want to make meta-characters case-specific.
(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
;; Use predefined function of Emacs19 for comments (RE)
(define-key ada-mode-map "\C-c;" 'comment-region)
(define-key ada-mode-map "\C-c:" 'ada-uncomment-region)
+
+ ;; The following keys are bound to functions defined in ada-xref.el or
+ ;; ada-prj,el., However, RMS rightly thinks that the code should be shared,
+ ;; and activated only if the right compiler is used
+ (if (featurep 'xemacs)
+ (progn
+ (define-key ada-mode-map '(shift button3) 'ada-point-and-xref)
+ (define-key ada-mode-map '(control tab) 'ada-complete-identifier))
+ (define-key ada-mode-map [C-tab] 'ada-complete-identifier)
+ (define-key ada-mode-map [S-mouse-3] 'ada-point-and-xref))
+
+ (define-key ada-mode-map "\C-co" 'ff-find-other-file)
+ (define-key ada-mode-map "\C-c5\C-d" 'ada-goto-declaration-other-frame)
+ (define-key ada-mode-map "\C-c\C-d" 'ada-goto-declaration)
+ (define-key ada-mode-map "\C-c\C-s" 'ada-xref-goto-previous-reference)
+ (define-key ada-mode-map "\C-c\C-c" 'ada-compile-application)
+ (define-key ada-mode-map "\C-cc" 'ada-change-prj)
+ (define-key ada-mode-map "\C-cd" 'ada-set-default-project-file)
+ (define-key ada-mode-map "\C-cg" 'ada-gdb-application)
+ (define-key ada-mode-map "\C-cr" 'ada-run-application)
+ (define-key ada-mode-map "\C-c\C-o" 'ada-goto-parent)
+ (define-key ada-mode-map "\C-c\C-r" 'ada-find-references)
+ (define-key ada-mode-map "\C-cl" 'ada-find-local-references)
+ (define-key ada-mode-map "\C-c\C-v" 'ada-check-current)
+ (define-key ada-mode-map "\C-cf" 'ada-find-file)
+
+ (define-key ada-mode-map "\C-cu" 'ada-prj-edit)
+
+ ;; The templates, defined in ada-stmt.el
+
+ (let ((map (make-sparse-keymap)))
+ (define-key map "h" 'ada-header)
+ (define-key map "\C-a" 'ada-array)
+ (define-key map "b" 'ada-exception-block)
+ (define-key map "d" 'ada-declare-block)
+ (define-key map "c" 'ada-case)
+ (define-key map "\C-e" 'ada-elsif)
+ (define-key map "e" 'ada-else)
+ (define-key map "\C-k" 'ada-package-spec)
+ (define-key map "k" 'ada-package-body)
+ (define-key map "\C-p" 'ada-procedure-spec)
+ (define-key map "p" 'ada-subprogram-body)
+ (define-key map "\C-f" 'ada-function-spec)
+ (define-key map "f" 'ada-for-loop)
+ (define-key map "i" 'ada-if)
+ (define-key map "l" 'ada-loop)
+ (define-key map "\C-r" 'ada-record)
+ (define-key map "\C-s" 'ada-subtype)
+ (define-key map "S" 'ada-tabsize)
+ (define-key map "\C-t" 'ada-task-spec)
+ (define-key map "t" 'ada-task-body)
+ (define-key map "\C-y" 'ada-type)
+ (define-key map "\C-v" 'ada-private)
+ (define-key map "u" 'ada-use)
+ (define-key map "\C-u" 'ada-with)
+ (define-key map "\C-w" 'ada-when)
+ (define-key map "w" 'ada-while-loop)
+ (define-key map "\C-x" 'ada-exception)
+ (define-key map "x" 'ada-exit)
+ (define-key ada-mode-map "\C-ct" map))
)
(defun ada-create-menu ()
- "Create the ada menu as shown in the menu bar.
-This function is designed to be extensible, so that each compiler-specific file
-can add its own items."
- ;; Note that the separators must have different length in the submenus
- (autoload 'easy-menu-define "easymenu")
-
- (let ((m '("Ada"
- ("Help" ["Ada Mode" (info "ada-mode") t])))
- (option '(["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]))
- (goto '(["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 '(["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 Buffer" ada-adjust-case-buffer t]
- ["Create Case Exception" ada-create-case-exception t]
- ["Reload Case Exceptions" ada-case-read-exceptions t]
- ["----" nil nil]
- ["Make body for subprogram" ada-make-subprogram-body t]))
-
- )
-
- ;; Option menu present only if in Ada mode
- (setq m (append m (list (append (list "Options"
- (if ada-xemacs :included :visible)
- '(string= mode-name "Ada"))
- option))))
-
- ;; Customize menu always present
- (setq m (append m '(["Customize" (customize-group 'ada)
- (>= emacs-major-version 20)])))
-
- ;; Goto and Edit menus present only if in Ada mode
- (setq m (append m (list (append (list "Goto"
- (if ada-xemacs :included :visible)
- '(string= mode-name "Ada"))
- goto)
- (append (list "Edit"
- (if ada-xemacs :included :visible)
- '(string= mode-name "Ada"))
- edit))))
+ "Create the Ada menu as shown in the menu bar."
+ (let ((m '("Ada"
+ ("Help"
+ ["Ada Mode" (info "ada-mode") t]
+ ["GNAT User's Guide" (info "gnat_ugn")
+ (eq ada-which-compiler 'gnat)]
+ ["GNAT Reference Manual" (info "gnat_rm")
+ (eq ada-which-compiler 'gnat)]
+ ["Gcc Documentation" (info "gcc")
+ (eq ada-which-compiler 'gnat)]
+ ["Gdb Documentation" (info "gdb")
+ (eq ada-which-compiler 'gnat)]
+ ["Ada95 Reference Manual" (info "arm95")
+ (eq ada-which-compiler 'gnat)])
+ ("Options" :included (eq major-mode 'ada-mode)
+ ["Auto Casing" (setq ada-auto-case (not ada-auto-case))
+ :style toggle :selected ada-auto-case]
+ ["Auto Indent After Return"
+ (setq ada-indent-after-return (not ada-indent-after-return))
+ :style toggle :selected ada-indent-after-return]
+ ["Automatically Recompile For Cross-references"
+ (setq ada-xref-create-ali (not ada-xref-create-ali))
+ :style toggle :selected ada-xref-create-ali
+ :included (eq ada-which-compiler 'gnat)]
+ ["Confirm Commands"
+ (setq ada-xref-confirm-compile (not ada-xref-confirm-compile))
+ :style toggle :selected ada-xref-confirm-compile
+ :included (eq ada-which-compiler 'gnat)]
+ ["Show Cross-references In Other Buffer"
+ (setq ada-xref-other-buffer (not ada-xref-other-buffer))
+ :style toggle :selected ada-xref-other-buffer
+ :included (eq ada-which-compiler 'gnat)]
+ ["Tight Integration With GNU Visual Debugger"
+ (setq ada-tight-gvd-integration (not ada-tight-gvd-integration))
+ :style toggle :selected ada-tight-gvd-integration
+ :included (string-match "gvd" ada-prj-default-debugger)])
+ ["Customize" (customize-group 'ada)
+ :included (fboundp 'customize-group)]
+ ["Check file" ada-check-current (eq ada-which-compiler 'gnat)]
+ ["Compile file" ada-compile-current (eq ada-which-compiler 'gnat)]
+ ["Build" ada-compile-application
+ (eq ada-which-compiler 'gnat)]
+ ["Run" ada-run-application t]
+ ["Debug" ada-gdb-application (eq ada-which-compiler 'gnat)]
+ ["------" nil nil]
+ ("Project"
+ :included (eq ada-which-compiler 'gnat)
+ ["Load..." ada-set-default-project-file t]
+ ["New..." ada-prj-new t]
+ ["Edit..." ada-prj-edit t])
+ ("Goto" :included (eq major-mode 'ada-mode)
+ ["Goto Declaration/Body" ada-goto-declaration
+ (eq ada-which-compiler 'gnat)]
+ ["Goto Body" ada-goto-body
+ (eq ada-which-compiler 'gnat)]
+ ["Goto Declaration Other Frame"
+ ada-goto-declaration-other-frame
+ (eq ada-which-compiler 'gnat)]
+ ["Goto Previous Reference" ada-xref-goto-previous-reference
+ (eq ada-which-compiler 'gnat)]
+ ["List Local References" ada-find-local-references
+ (eq ada-which-compiler 'gnat)]
+ ["List References" ada-find-references
+ (eq ada-which-compiler 'gnat)]
+ ["Goto Reference To Any Entity" ada-find-any-references
+ (eq ada-which-compiler 'gnat)]
+ ["Goto Parent Unit" ada-goto-parent
+ (eq ada-which-compiler 'gnat)]
+ ["--" nil nil]
+ ["Next compilation error" next-error t]
+ ["Previous Package" ada-previous-package t]
+ ["Next Package" ada-next-package t]
+ ["Previous Procedure" ada-previous-procedure t]
+ ["Next Procedure" ada-next-procedure t]
+ ["Goto Start Of Statement" ada-move-to-start t]
+ ["Goto End Of Statement" ada-move-to-end t]
+ ["-" nil nil]
+ ["Other File" ff-find-other-file t]
+ ["Other File Other Window" ada-ff-other-window t])
+ ("Edit" :included (eq major-mode 'ada-mode)
+ ["Search File On Source Path" ada-find-file t]
+ ["------" nil nil]
+ ["Complete Identifier" ada-complete-identifier t]
+ ["-----" nil nil]
+ ["Indent Line" ada-indent-current-function t]
+ ["Justify Current Indentation" ada-justified-indent-current t]
+ ["Indent Lines in Selection" ada-indent-region t]
+ ["Indent Lines in File"
+ (ada-indent-region (point-min) (point-max)) t]
+ ["Format Parameter List" ada-format-paramlist t]
+ ["-" nil nil]
+ ["Comment Selection" comment-region t]
+ ["Uncomment Selection" ada-uncomment-region t]
+ ["--" nil nil]
+ ["Fill Comment Paragraph" fill-paragraph t]
+ ["Fill Comment Paragraph Justify"
+ ada-fill-comment-paragraph-justify t]
+ ["Fill Comment Paragraph Postfix"
+ ada-fill-comment-paragraph-postfix t]
+ ["---" nil nil]
+ ["Adjust Case Selection" ada-adjust-case-region t]
+ ["Adjust Case in File" ada-adjust-case-buffer t]
+ ["Create Case Exception" ada-create-case-exception t]
+ ["Create Case Exception Substring"
+ ada-create-case-exception-substring t]
+ ["Reload Case Exceptions" ada-case-read-exceptions t]
+ ["----" nil nil]
+ ["Make body for subprogram" ada-make-subprogram-body t]
+ ["-----" nil nil]
+ ["Narrow to subprogram" ada-narrow-to-defun t])
+ ("Templates"
+ :included (eq major-mode 'ada-mode)
+ ["Header" ada-header t]
+ ["-" nil nil]
+ ["Package Body" ada-package-body t]
+ ["Package Spec" ada-package-spec t]
+ ["Function Spec" ada-function-spec t]
+ ["Procedure Spec" ada-procedure-spec t]
+ ["Proc/func Body" ada-subprogram-body t]
+ ["Task Body" ada-task-body t]
+ ["Task Spec" ada-task-spec t]
+ ["Declare Block" ada-declare-block t]
+ ["Exception Block" ada-exception-block t]
+ ["--" nil nil]
+ ["Entry" ada-entry t]
+ ["Entry family" ada-entry-family t]
+ ["Select" ada-select t]
+ ["Accept" ada-accept t]
+ ["Or accept" ada-or-accep t]
+ ["Or delay" ada-or-delay t]
+ ["Or terminate" ada-or-terminate t]
+ ["---" nil nil]
+ ["Type" ada-type t]
+ ["Private" ada-private t]
+ ["Subtype" ada-subtype t]
+ ["Record" ada-record t]
+ ["Array" ada-array t]
+ ["----" nil nil]
+ ["If" ada-if t]
+ ["Else" ada-else t]
+ ["Elsif" ada-elsif t]
+ ["Case" ada-case t]
+ ["-----" nil nil]
+ ["While Loop" ada-while-loop t]
+ ["For Loop" ada-for-loop t]
+ ["Loop" ada-loop t]
+ ["------" nil nil]
+ ["Exception" ada-exception t]
+ ["Exit" ada-exit t]
+ ["When" ada-when t])
+ )))
(easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode" m)
- (if ada-xemacs
- (progn
- (easy-menu-add ada-mode-menu ada-mode-map)
- (define-key ada-mode-map [menu-bar] ada-mode-menu)
- (setq mode-popup-menu (cons "Ada mode" ada-mode-menu)))
- )
- ))
+ (if (featurep 'xemacs)
+ (progn
+ (define-key ada-mode-map [menu-bar] ada-mode-menu)
+ (set 'mode-popup-menu (cons "Ada mode" ada-mode-menu))))))
\f
;; -------------------------------------------------------
;; function for justifying the comments.
;; -------------------------------------------------------
-(defadvice comment-region (before ada-uncomment-anywhere)
+(defadvice comment-region (before ada-uncomment-anywhere disable)
(if (and arg
- (< arg 0)
+ (listp arg) ;; a prefix with \C-u is of the form '(4), whereas
+ ;; \C-u 2 sets arg to '2' (fixed by S.Leake)
(string= mode-name "Ada"))
(save-excursion
(let ((cs (concat "^[ \t]*" (regexp-quote comment-start))))
;; 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) (boundp 'running-xemacs))
+ (if (or (<= emacs-major-version 20) (featurep 'xemacs))
(progn
(ad-activate 'comment-region)
- (comment-region beg end (- (or arg 1)))
+ (comment-region beg end (- (or arg 2)))
(ad-deactivate 'comment-region))
- (comment-region beg end (list (- (or arg 1))))))
+ (comment-region beg end (list (- (or arg 2))))
+ (ada-indent-region beg end)))
(defun ada-fill-comment-paragraph-justify ()
- "Fills current comment paragraph and justifies each line as well."
+ "Fill current comment paragraph and justify each line as well."
(interactive)
(ada-fill-comment-paragraph 'full))
(defun ada-fill-comment-paragraph-postfix ()
- "Fills current comment paragraph and justifies each line as well.
+ "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)
- "Fills the current comment paragraph.
+ "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 filled and justified line.
+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"))
+ (error "Not inside comment"))
- (let* ((indent)
- (from)
- (to)
- (opos (point-marker))
+ (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
;; Find end of paragraph
(back-to-indentation)
- (while (and (not (eobp)) (looking-at "--[ \t]*[^ \t\n]"))
+ (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 (eolp)
+ (if (eobp)
(insert "\n")
(back-to-indentation)))
(beginning-of-line)
;; Find beginning of paragraph
(back-to-indentation)
- (while (and (not (bobp)) (looking-at "--[ \t]*[^ \t\n]"))
+ (while (and (not (bobp)) (looking-at ".*--[ \t]*[^ \t\n]"))
(forward-line -1)
(back-to-indentation))
- ;; We want one line to above the first one, unless we are at the beginning
+ ;; We want one line above the first one, unless we are at the beginning
;; of the buffer
(unless (bobp)
(forward-line 1))
(while (re-search-forward "--\n" to t)
(replace-match "\n"))
- ;; Remove the old prefixes (so that the number of spaces after -- is not
- ;; relevant), except on the first one since `fill-region-as-paragraph'
- ;; would not put it back on the first line.
- (goto-char (+ from 2))
- (while (re-search-forward "^-- *" to t)
- (replace-match " "))
-
(goto-char (1- to))
(setq to (point-marker))
;; In Emacs <= 20.2 and XEmacs <=20.4, there is a bug, and a newline is
;; inserted at the end. Delete it
- (if (or ada-xemacs
+ (if (or (featurep 'xemacs)
(<= emacs-major-version 19)
(and (= emacs-major-version 20)
(<= emacs-minor-version 2)))
(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."
+The name returned is the body if `current-buffer' is the spec,
+or the spec otherwise."
(let ((is-spec nil)
(is-body nil)
(setq is-spec name)
(while suffixes
- (if (file-exists-p (concat name (car suffixes)))
- (setq is-spec (concat name (car suffixes))))
+
+ ;; If we are using project file, search for the other file in all
+ ;; the possible src directories.
+
+ (if (fboundp 'ada-find-src-file-in-dir)
+ (let ((other
+ (ada-find-src-file-in-dir
+ (file-name-nondirectory (concat name (car suffixes))))))
+ (if other
+ (set 'is-spec other)))
+
+ ;; Else search in the current directory
+ (if (file-exists-p (concat name (car suffixes)))
+ (setq is-spec (concat name (car suffixes)))))
(setq suffixes (cdr suffixes)))
is-spec)))
(defvar ada-last-which-function-line -1
- "Last on which ada-which-function was called")
+ "Last on which `ada-which-function' was called.")
(defvar ada-last-which-function-subprog 0
- "Last subprogram name returned by ada-which-function")
+ "Last subprogram name returned by `ada-which-function'.")
(make-variable-buffer-local 'ada-last-which-function-subprog)
(make-variable-buffer-local 'ada-last-which-function-line)
(defun ada-which-function ()
- "Returns the name of the function whose body the point is in.
+ "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.
-Note that this function expects subprogram bodies to be terminated by
-'end <name>;', not 'end;'.
+standard Emacs function `which-function' does not.
Since the search can be long, the results are cached."
- (let ((line (count-lines (point-min) (point)))
+ (let ((line (count-lines 1 (point)))
(pos (point))
end-pos
- func-name
+ func-name indent
found)
;; If this is the same line as before, simply return the same result
(save-excursion
;; In case the current line is also the beginning of the body
(end-of-line)
- (while (and (ada-in-paramlist-p)
- (= (forward-line 1) 0))
- (end-of-line))
+
+ ;; Are we looking at "function Foo\n (paramlist)"
+ (skip-chars-forward " \t\n(")
+
+ (condition-case nil
+ (up-list 1)
+ (error nil))
+
+ (skip-chars-forward " \t\n")
+ (if (looking-at "return")
+ (progn
+ (forward-word 1)
+ (skip-chars-forward " \t\n")
+ (skip-chars-forward "a-zA-Z0-9_'")))
;; Can't simply do forward-word, in case the "is" is not on the
;; same line as the closing parenthesis
(skip-chars-forward "is \t\n")
;; No look for the closest subprogram body that has not ended yet.
- ;; Not that we expect all the bodies to be finished by "end <name",
- ;; not simply "end"
+ ;; 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))
- (setq func-name (match-string 2))
+
+ ;; Get the function name, but not the properties, or this changes
+ ;; the face in the modeline on Emacs 21
+ (setq func-name (match-string-no-properties 2))
(if (and (not (ada-in-comment-p))
(not (save-excursion
(goto-char (match-end 0))
(looking-at "[ \t\n]*new"))))
(save-excursion
+ (back-to-indentation)
+ (setq indent (current-column))
(if (ada-search-ignore-string-comment
- (concat "end[ \t]+" func-name "[ \t]*;"))
+ (concat "end[ \t]+" func-name "[ \t]*;\\|^"
+ (make-string indent ? ) "end;"))
(setq end-pos (point))
(setq end-pos (point-max)))
(if (>= end-pos pos)
(goto-char (point-min))))))
(defun ada-get-body-name (&optional spec-name)
- "Returns the file name for the body of SPEC-NAME.
-If SPEC-NAME is nil, returns the body for the current package.
+ "Return the file name for the body of SPEC-NAME.
+If SPEC-NAME is nil, return the body for the current package.
Returns nil if no body was found."
(interactive)
(unless spec-name (setq spec-name (buffer-file-name)))
+ ;; Remove the spec extension. We can not simply remove the file extension,
+ ;; but we need to take into account the specific non-GNAT extensions that the
+ ;; user might have specified.
+
+ (let ((suffixes ada-spec-suffixes)
+ end)
+ (while suffixes
+ (setq end (- (length spec-name) (length (car suffixes))))
+ (if (string-equal (car suffixes) (substring spec-name end))
+ (setq spec-name (substring spec-name 0 end)))
+ (setq suffixes (cdr suffixes))))
+
;; If find-file.el was available, use its functions
- (if (functionp 'ff-get-file)
- (ff-get-file-name ada-search-directories
+ (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)))
;; a string
;; This sets the properties of the characters, so that ada-in-string-p
;; correctly handles '"' too...
- '(("\\('\\)[^'\n]\\('\\)" (1 (7 . ?')) (2 (7 . ?')))
+ '(("[^a-zA-Z0-9)]\\('\\)[^'\n]\\('\\)" (1 (7 . ?')) (2 (7 . ?')))
("^[ \t]*\\(#\\(if\\|else\\|elsif\\|end\\)\\)" (1 (11 . ?\n)))
))
;;
;; Optional keywords followed by a type name.
(list (concat ; ":[ \t]*"
- "\\<\\(access[ \t]+all\\|access\\|constant\\|in[ \t]+out\\|in\\|out\\)\\>"
+ "\\<\\(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))
"null" "or" "others" "private" "protected" "raise"
"range" "record" "rem" "renames" "requeue" "return" "reverse"
"select" "separate" "tagged" "task" "terminate" "then" "until"
- "when" "while" "xor") t)
+ "when" "while" "with" "xor") t)
"\\>")
;;
;; Anything following end and not already fontified is a body name.
font-lock-type-face) nil t))
;;
;; Keywords followed by a (comma separated list of) reference.
- (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)\\>" ; "when" removed
- "[ \t\n]*\\(\\(\\sw\\|[_.|, \t\n]\\)+\\)\\W")
+ ;; Note that font-lock only works on single lines, thus we can not
+ ;; correctly highlight a with_clause that spans multiple lines.
+ (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)"
+ "[ \t]+\\([a-zA-Z0-9_., \t]+\\)\\W")
'(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t))
+
;;
;; Goto tags.
'("<<\\(\\sw+\\)>>" 1 font-lock-reference-face)
+
+ ;; Highlight based-numbers (R. Reagan <robin-reply@reagans.org>)
+ (list "\\([0-9]+#[0-9a-fA-F_]+#\\)" '(1 font-lock-constant-face t))
+
+ ;; Ada unnamed numerical constants
+ (list "\\W\\([-+]?[0-9._]+\\)\\>" '(1 font-lock-constant-face))
+
))
"Default expressions to highlight in Ada mode.")
;; ---------------------------------------------------------
(defun ada-outline-level ()
- "This is so that `current-column` DTRT in otherwise-hidden text"
+ "This is so that `current-column' DTRT in otherwise-hidden text."
;; patch from Dave Love <fx@gnu.org>
(let (buffer-invisibility-spec)
(save-excursion
(back-to-indentation)
(current-column))))
+;; ---------------------------------------------------------
+;; Support for narrow-to-region
+;; ---------------------------------------------------------
+
+(defun ada-narrow-to-defun (&optional arg)
+ "Make text outside current subprogram invisible.
+The subprogram visible is the one that contains or follow point.
+Optional ARG is ignored.
+Use `M-x widen' to go back to the full visibility for the buffer."
+
+ (interactive)
+ (save-excursion
+ (let (end)
+ (widen)
+ (forward-line 1)
+ (ada-previous-procedure)
+
+ (save-excursion
+ (beginning-of-line)
+ (setq end (point)))
+
+ (ada-move-to-end)
+ (end-of-line)
+ (narrow-to-region end (point))
+ (message
+ "Use M-x widen to get back to full visibility in the buffer"))))
+
;; ---------------------------------------------------------
;; Automatic generation of code
;; The Ada-mode has a set of function to automatically generate a subprogram
(defun ada-gen-treat-proc (match)
"Make dummy body of a procedure/function specification.
-MATCH is a cons cell containing the start and end location of the last search
-for ada-procedure-start-regexp."
+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
(setq body-file (ada-get-body-name))
(if body-file
(find-file body-file)
- (error "No body found for the package. Create it first."))
+ (error "No body found for the package. Create it first"))
(save-restriction
(widen)
;; Read the special cases for exceptions
(ada-case-read-exceptions)
-;; include the other ada-mode files
+;; Setup auto-loading of the other ada-mode files.
(if (equal ada-which-compiler 'gnat)
(progn
- ;; The order here is important: ada-xref defines the Project
- ;; submenu, and ada-prj adds to it.
- (require 'ada-xref)
- (condition-case nil (require 'ada-prj) (error nil))
+ (autoload 'ada-change-prj "ada-xref" nil t)
+ (autoload 'ada-check-current "ada-xref" nil t)
+ (autoload 'ada-compile-application "ada-xref" nil t)
+ (autoload 'ada-compile-current "ada-xref" nil t)
+ (autoload 'ada-complete-identifier "ada-xref" nil t)
+ (autoload 'ada-find-file "ada-xref" nil t)
+ (autoload 'ada-find-any-references "ada-xref" nil t)
+ (autoload 'ada-find-src-file-in-dir "ada-xref" nil t)
+ (autoload 'ada-find-local-references "ada-xref" nil t)
+ (autoload 'ada-find-references "ada-xref" nil t)
+ (autoload 'ada-gdb-application "ada-xref" nil t)
+ (autoload 'ada-goto-declaration "ada-xref" nil t)
+ (autoload 'ada-goto-declaration-other-frame "ada-xref" nil t)
+ (autoload 'ada-goto-parent "ada-xref" nil t)
+ (autoload 'ada-make-body-gnatstub "ada-xref" nil t)
+ (autoload 'ada-point-and-xref "ada-xref" nil t)
+ (autoload 'ada-reread-prj-file "ada-xref" nil t)
+ (autoload 'ada-run-application "ada-xref" nil t)
+ (autoload 'ada-set-default-project-file "ada-xref" nil nil)
+ (autoload 'ada-set-default-project-file "ada-xref" nil t)
+ (autoload 'ada-xref-goto-previous-reference "ada-xref" nil t)
+
+ (autoload 'ada-customize "ada-prj" nil t)
+ (autoload 'ada-prj-edit "ada-prj" nil t)
+ (autoload 'ada-prj-new "ada-prj" nil t)
+ (autoload 'ada-prj-save "ada-prj" nil t)
))
-(condition-case nil (require 'ada-stmt) (error nil))
+
+(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)
+;;; arch-tag: 1b7d45ec-1698-43b5-8d4a-e479ea023270
;;; ada-mode.el ends here