-;;; ada-mode.el --- An Emacs major-mode for editing Ada source.
+;; @(#) ada-mode.el --- major-mode for editing Ada source.
-;; Copyright (C) 1994, 1995, 1997 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1999 Free Software Foundation, Inc.
-;; Authors: Rolf Ebert <re@waporo.muc.de>
-;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
-;; Maintainer: Emmanual Briot <briot@gnat.com>
-;; Keywords: languages oop ada
-;; Rolf Ebert's version: 2.27
+;; 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.70 $
+;; Keywords: languages ada
-;; This file is part of GNU Emacs.
+;; This file is not part of GNU Emacs
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
-;; GNU Emacs is distributed in the hope that it will be useful,
+;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; This mode is a complete rewrite of a major mode for editing Ada 83
-;;; and Ada 95 source code under Emacs-19. It contains completely new
-;;; indenting code and support for code browsing (see ada-xref).
-
-
-;;; USAGE
-;;; =====
-;;; Emacs should enter Ada mode when you load an Ada source (*.ad[abs]).
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, 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
+;;; completly independant from the GNU Ada compiler Gnat, distributed
+;;; by Ada Core Technologies. All the other files rely heavily on
+;;; features provides only by Gnat.
;;;
-;;; When you have entered ada-mode, you may get more info by pressing
-;;; C-h m. You may also get online help describing various functions by:
-;;; C-h d <Name of function you want described>
-
+;;; Note: this mode will not work with Emacs 19. If you are on a VMS
+;;; system, where the latest version of Emacs is 19.28, you will need
+;;; another file, called ada-vms.el, that provides some required
+;;; functions.
+
+;;; Usage:
+;;; Emacs should enter Ada mode automatically when you load an Ada file.
+;;; By default, the valid extensions for Ada files are .ads, .adb or .ada
+;;; If the ada-mode does not start automatically, then simply type the
+;;; following command :
+;;; M-x ada-mode
+;;;
+;;; By default, ada-mode is configured to take full advantage of the GNAT
+;;; compiler (the menus will include the cross-referencing features,...).
+;;; If you are using another compiler, you might want to set the following
+;;; variable in your .emacs (Note: do not set this in the ada-mode-hook, it
+;;; won't work) :
+;;; (setq ada-which-compiler 'generic)
+;;;
+;;; This mode requires find-file.el to be present on your system.
-;;; HISTORY
-;;; =======
+;;; History:
;;; The first Ada mode for GNU Emacs was written by V. Broman in
;;; 1985. He based his work on the already existing Modula-2 mode.
;;; This was distributed as ada.el in versions of Emacs prior to 19.29.
;;; Gosling Emacs. L. Slater based his development on ada.el and
;;; electric-ada.el.
;;;
-;;; The current Ada mode is a complete rewrite by M. Heritsch and
-;;; R. Ebert. Some ideas from the Ada mode mailing list have been
+;;; A complete rewrite by M. Heritsch and R. Ebert has been done.
+;;; Some ideas from the Ada mode mailing list have been
;;; added. Some of the functionality of L. Slater's mode has not
;;; (yet) been recoded in this new mode. Perhaps you prefer sticking
;;; to his version.
-
-
-;;; KNOWN BUGS
-;;; ==========
;;;
-;;; In the presence of comments and/or incorrect syntax
-;;; ada-format-paramlist produces weird results.
-;;; -------------------
-;;; Character constants with otherwise syntactic relevant characters
-;;; like `(' or `"' throw indentation off the track. Fontification
-;;; should work now in Emacs-19.35
-;;; C : constant Character := Character'('"');
-;;; -------------------
-
-
-;;; TODO
-;;; ====
-;;;
-;;; o bodify-single-subprogram
-;;; o make a function "separate" and put it in the corresponding file.
-
-
-
-;;; CREDITS
-;;; =======
-;;;
-;;; Many thanks to
-;;; Philippe Waroquiers (PW) <philippe@cfmu.eurocontrol.be> in particular,
-;;; woodruff@stc.llnl.gov (John Woodruff)
-;;; jj@ddci.dk (Jesper Joergensen)
-;;; gse@ocsystems.com (Scott Evans)
-;;; comar@LANG8.CS.NYU.EDU (Cyrille Comar)
+;;; A complete rewrite for Emacs-20 / Gnat-3.11 has been done by Ada Core
+;;; Technologies. Please send bugs to briot@gnat.com
+
+;;; Credits:
+;;; Many thanks to John McCabe <john@assen.demon.co.uk> for sending so
+;;; many patches included in this package.
+;;; Christian Egli <Christian.Egli@hcsd.hac.com>:
+;;; ada-imenu-generic-expression
+;;; Many thanks also to the following persons that have contributed one day
+;;; to the ada-mode
+;;; Philippe Waroquiers (PW) <philippe@cfmu.eurocontrol.be> in particular,
+;;; woodruff@stc.llnl.gov (John Woodruff)
+;;; jj@ddci.dk (Jesper Joergensen)
+;;; gse@ocsystems.com (Scott Evans)
+;;; comar@gnat.com (Cyrille Comar)
+;;; stephen.leake@gsfc.nasa.gov (Stephen Leake)
;;; and others for their valuable hints.
-\f
-;;;--------------------
-;;; USER OPTIONS
-;;;--------------------
+;;; Code:
+;;; Note: Every function is this package is compiler-independent.
+;;; The names start with ada-
+;;; The variables that the user can edit can all be modified throught
+;;; the customize mode. They are sorted in alphabetical order in this
+;;; file.
+
+
+;; this function is needed at compile time
+(eval-and-compile
+ (defun ada-check-emacs-version (major minor &optional is_xemacs)
+ "Returns t if Emacs's version is greater or equal to major.minor.
+if IS_XEMACS is non-nil, check for XEmacs instead of Emacs"
+ (let ((xemacs_running (or (string-match "Lucid" emacs-version)
+ (string-match "XEmacs" emacs-version))))
+ (and (or (and is_xemacs xemacs_running)
+ (not (or is_xemacs xemacs_running)))
+ (or (> emacs-major-version major)
+ (and (= emacs-major-version major)
+ (>= emacs-minor-version minor)))))))
+
+
+;; We create a constant for that, for efficiency only
+;; This should not be evaluated at compile time, only a runtime
+(defconst ada-xemacs (boundp '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)
-;; ---- customize support
+(defvar ada-mode-hook nil
+ "*List of functions to call when Ada mode is invoked.
+This hook is automatically executed after the ada-mode is
+fully loaded.
+This is a good place to add Ada environment specific bindings.")
(defgroup ada nil
"Major mode for editing Ada source in Emacs"
:group 'languages)
-;; ---- configure indentation
+(defcustom ada-auto-case t
+ "*Non-nil means automatically change case of preceding word while typing.
+Casing is done according to `ada-case-keyword', `ada-case-identifier'
+and `ada-case-attribute'."
+ :type 'boolean :group 'ada)
-(defcustom ada-indent 3
- "*Defines the size of Ada indentation."
- :type 'integer
- :group 'ada)
+(defcustom ada-broken-decl-indent 0
+ "*Number of columns to indent a broken declaration.
+
+An example is :
+ declare
+ A,
+ >>>>>B : Integer; -- from ada-broken-decl-indent"
+ :type 'integer :group 'ada)
(defcustom ada-broken-indent 2
- "*# of columns to indent the continuation of a broken line."
- :type 'integer
- :group 'ada)
+ "*Number of columns to indent the continuation of a broken line.
-(defcustom ada-label-indent -4
- "*# of columns to indent a label."
- :type 'integer
- :group 'ada)
+An example is :
+ My_Var : My_Type := (Field1 =>
+ >>>>>>>>>Value); -- from ada-broken-indent"
+ :type 'integer :group 'ada)
-(defcustom ada-stmt-end-indent 0
- "*# of columns to indent a statement end keyword in a separate line.
-Examples are 'is', 'loop', 'record', ..."
- :type 'integer
+(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' or
+`ada-capitalize-word'."
+ :type '(choice (const downcase-word)
+ (const upcase-word)
+ (const ada-capitalize-word)
+ (const ada-loose-case-word))
:group 'ada)
-(defcustom ada-when-indent 3
- "*Defines the indentation for 'when' relative to 'exception' or 'case'."
- :type 'integer
- :group 'ada)
+(defcustom ada-case-exception-file "~/.emacs_case_exceptions"
+ "*Name of the file that contains the list of special casing
+exceptions for identifiers.
+This file should contain one word per line, that gives the casing
+to be used for that words in Ada files"
+ :type 'file :group 'ada)
-(defcustom ada-indent-record-rel-type 3
- "*Defines the indentation for 'record' relative to 'type' or 'use'."
- :type 'integer
+(defcustom ada-case-keyword 'downcase-word
+ "*Function to call to adjust the case of Ada keywords.
+It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
+`ada-capitalize-word'."
+ :type '(choice (const downcase-word)
+ (const upcase-word)
+ (const ada-capitalize-word)
+ (const ada-loose-case-word))
:group 'ada)
-(defcustom ada-indent-comment-as-code t
- "*If non-nil, comment-lines get indented as Ada code."
- :type 'boolean
+(defcustom ada-case-identifier 'ada-loose-case-word
+ "*Function to call to adjust the case of an Ada identifier.
+It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
+`ada-capitalize-word'."
+ :type '(choice (const downcase-word)
+ (const upcase-word)
+ (const ada-capitalize-word)
+ (const ada-loose-case-word))
:group 'ada)
-(defcustom ada-indent-is-separate t
- "*If non-nil, 'is separate' or 'is abstract' on a single line are indented."
- :type 'boolean
- :group 'ada)
+(defcustom ada-clean-buffer-before-saving t
+ "*Non-nil means `remove-trailing-spaces' and `untabify' buffer before saving."
+ :type 'boolean :group 'ada)
-(defcustom ada-indent-to-open-paren t
- "*If non-nil, indent according to the innermost open parenthesis."
- :type 'boolean
- :group 'ada)
+(defcustom ada-indent 3
+ "*Size of Ada indentation.
-(defcustom ada-search-paren-char-count-limit 3000
- "*Search that many characters for an open parenthesis."
- :type 'integer
- :group 'ada)
+An example is :
+procedure Foo is
+begin
+>>>>>>>>>>null; -- from ada-indent"
+ :type 'integer :group 'ada)
+(defcustom ada-indent-after-return t
+ "*Non-nil means automatically indent after RET or LFD."
+ :type 'boolean :group 'ada)
-;; ---- other user options
+(defcustom ada-indent-comment-as-code t
+ "*Non-nil means indent comment lines as code"
+ :type 'boolean :group 'ada)
-(defcustom ada-tab-policy 'indent-auto
- "*Control behaviour of the TAB key.
-Must be one of `indent-rigidly', `indent-auto', `gei', `indent-af'
-or `always-tab'.
+(defcustom ada-indent-is-separate t
+ "*Non-nil means indent 'is separate' or 'is abstract' if on a single line."
+ :type 'boolean :group 'ada)
-`indent-rigidly' : always adds ada-indent blanks at the beginning of the line.
-`indent-auto' : use indentation functions in this file.
-`gei' : use David Kågedal's Generic Indentation Engine.
-`indent-af' : use Gary E. Barnes' ada-format.el
-`always-tab' : do indent-relative."
- :type '(choice (const indent-auto)
- (const indent-rigidly)
- (const gei)
- (const indent-af)
- (const always-tab))
- :group 'ada)
+(defcustom ada-indent-record-rel-type 3
+ "*Indentation for 'record' relative to 'type' or 'use'.
-(defcustom ada-move-to-declaration nil
- "*If non-nil, `ada-move-to-start' moves point to the subprog declaration,
-not to 'begin'."
- :type 'boolean
- :group 'ada)
+An example is:
+ type A is
+ >>>>>>>>>>>record -- from ada-indent-record-rel-type"
+ :type 'integer :group 'ada)
-(defcustom ada-spec-suffix ".ads"
- "*Suffix of Ada specification files."
- :type 'string
- :group 'ada)
+(defcustom ada-indent-return 0
+ "*Indentation for 'return' relative to the matching 'function' statement.
+If ada-indent-return is null or negative, the indentation is done relative to
+the open parenthesis (if there is no parenthesis, ada-broken-indent is used)
-(defcustom ada-body-suffix ".adb"
- "*Suffix of Ada body files."
- :type 'string
- :group 'ada)
+An example is:
+ function A (B : Integer)
+ >>>>>return C; -- from ada-indent-return"
+ :type 'integer :group 'ada)
-(defcustom ada-spec-suffix-as-regexp "\\.ads$"
- "*Regexp to find Ada specification files."
- :type 'string
- :group 'ada)
+(defcustom ada-indent-to-open-paren t
+ "*Non-nil means indent according to the innermost open parenthesis."
+ :type 'boolean :group 'ada)
-(defcustom ada-body-suffix-as-regexp "\\.adb$"
- "*Regexp to find Ada body files."
- :type 'string
- :group 'ada)
+(defcustom ada-fill-comment-prefix "-- "
+ "*Text inserted in the first columns when filling a comment paragraph.
+Note: if you modify this variable, you will have to restart the ada-mode to
+reread this variable."
+ :type 'string :group 'ada)
-(defvar ada-other-file-alist
- (list
- (list ada-spec-suffix-as-regexp (list ada-body-suffix))
- (list ada-body-suffix-as-regexp (list ada-spec-suffix))
- )
- "*Alist of extensions to find given the current file's extension.
+(defcustom ada-fill-comment-postfix " --"
+ "*Text inserted at the end of each line when filling a comment paragraph.
+with `ada-fill-comment-paragraph-postfix'."
+ :type 'string :group 'ada)
-This list should contain the most used extensions before the others,
-since the search algorithm searches sequentially through each directory
-specified in `ada-search-directories'. If a file is not found, a new one
-is created with the first matching extension (`.adb' yields `.ads').")
+(defcustom ada-label-indent -4
+ "*Number of columns to indent a label.
-(defcustom ada-search-directories
- '("." "/usr/adainclude" "/usr/local/adainclude" "/opt/gnu/adainclude")
- "*List of directories to search for Ada files.
-See the description for the `ff-search-directories' variable."
- :type '(repeat (choice :tag "Directory"
- (const :tag "default" nil)
- (directory :format "%v")))
- :group 'ada)
+An example is:
+procedure Foo is
+begin
+>>>>>>>>>>>>Label: -- from ada-label-indent"
+ :type 'integer :group 'ada)
(defcustom ada-language-version 'ada95
"*Do we program in `ada83' or `ada95'?"
- :type '(choice (const ada83)
- (const ada95))
- :group 'ada)
+ :type '(choice (const ada83) (const ada95)) :group 'ada)
-(defcustom ada-case-keyword 'downcase-word
- "*Function to call to adjust the case of Ada keywords.
-It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
-`capitalize-word'."
- :type '(choice (const downcase-word)
- (const upcase-word)
- (const capitalize-word)
- (const ada-loose-case-word))
- :group 'ada)
-
-(defcustom ada-case-identifier 'ada-loose-case-word
- "*Function to call to adjust the case of an Ada identifier.
-It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
-`capitalize-word'."
- :type '(choice (const downcase-word)
- (const upcase-word)
- (const capitalize-word)
- (const ada-loose-case-word))
- :group 'ada)
-
-(defcustom ada-case-attribute 'capitalize-word
- "*Function to call to adjust the case of Ada attributes.
-It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
-`capitalize-word'."
- :type '(choice (const downcase-word)
- (const upcase-word)
- (const capitalize-word)
- (const ada-loose-case-word))
- :group 'ada)
-
-(defcustom ada-auto-case t
- "*Non-nil automatically changes case of preceding word while typing.
-Casing is done according to `ada-case-keyword', `ada-case-identifier'
-and `ada-case-attribute'."
- :type 'boolean
- :group 'ada)
-
-(defcustom ada-clean-buffer-before-saving t
- "*If non-nil, `remove-trailing-spaces' and `untabify' buffer before saving."
- :type 'boolean
- :group 'ada)
-
-(defvar ada-mode-hook nil
- "*List of functions to call when Ada mode is invoked.
-This is a good place to add Ada environment specific bindings.")
-
-(defcustom ada-external-pretty-print-program "aimap"
- "*External pretty printer to call from within Ada mode."
- :type 'string
- :group 'ada)
-
-(defcustom ada-tmp-directory temporary-file-directory
- "*Directory to store the temporary file for the Ada pretty printer."
- :type 'string
- :group 'ada)
+(defcustom ada-move-to-declaration nil
+ "*Non-nil means `ada-move-to-start' moves point to the subprog declaration,
+not to 'begin'."
+ :type 'boolean :group 'ada)
-(defcustom ada-compile-options "-c"
- "*Buffer local options passed to the Ada compiler.
-These options are used when the compiler is invoked on the current buffer."
- :type 'string
- :group 'ada)
-(make-variable-buffer-local 'ada-compile-options)
+(defcustom ada-popup-key '[down-mouse-3]
+ "*Key used for binding the contextual menu.
+if nil, no contextual menu is available")
-(defcustom ada-make-options "-c"
- "*Buffer local options passed to `ada-compiler-make' (usually `gnatmake').
-These options are used when `gnatmake' is invoked on the current buffer."
- :type 'string
+(defcustom ada-search-directories
+ '("." "$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."
+ :type '(repeat (choice :tag "Directory"
+ (const :tag "default" nil)
+ (directory :format "%v")))
:group 'ada)
-(make-variable-buffer-local 'ada-make-options)
-(defcustom ada-compiler-syntax-check "gcc -c -gnats"
- "*Compiler command with options for syntax checking."
- :type 'string
- :group 'ada)
+(defcustom ada-stmt-end-indent 0
+ "*Number of columns to indent a statement end keyword on a separate line.
-(defcustom ada-compiler-make "gnatmake"
- "*The `make' command for the given compiler."
- :type 'string
- :group 'ada)
+An example is:
+ if A = B
+ >>>>>>>>>>>then -- from ada-stmt-end-indent"
+ :type 'integer :group 'ada)
-(defcustom ada-fill-comment-prefix "-- "
- "*This is inserted in the first columns when filling a comment paragraph."
- :type 'string
+(defcustom ada-tab-policy 'indent-auto
+ "*Control the behaviour of the TAB key.
+This is used only in the ada-tab and ada-untab functions.
+Must be one of :
+`indent-rigidly' : always adds ada-indent blanks at the beginning of the line.
+`indent-auto' : use indentation functions in this file.
+`always-tab' : do indent-relative."
+ :type '(choice (const indent-auto)
+ (const indent-rigidly)
+ (const always-tab))
:group 'ada)
-(defcustom ada-fill-comment-postfix " --"
- "*This is inserted at the end of each line when filling a comment paragraph.
-with `ada-fill-comment-paragraph-postfix'."
- :type 'string
+(defcustom ada-when-indent 3
+ "*Indentation for 'when' relative to 'exception' or 'case'.
+
+An example is:
+ case A is
+ >>>>>>>>when B => -- from ada-when-indentx"
+ :type 'integer :group 'ada)
+
+(defcustom ada-which-compiler 'gnat
+ "*Name of the compiler we use. This will determine what features are
+made available through the ada-mode. The possible choices are :
+
+`gnat': Use Ada Core Technologies' Gnat compiler. Add some cross-referencing
+ features
+`generic': Use a generic compiler"
+ :type '(choice (const gnat)
+ (const generic))
:group 'ada)
-(defcustom ada-krunch-args "0"
- "*Argument of gnatkr, a string containing the max number of characters.
-Set to 0, if you don't use crunched filenames."
- :type 'string
- :group 'ada)
;;; ---- end of user configurable variables
\f
-(defvar ada-mode-abbrev-table nil
- "Abbrev table used in Ada mode.")
-(define-abbrev-table 'ada-mode-abbrev-table ())
+(defvar ada-body-suffixes '(".adb")
+ "List of possible suffixes for Ada body files. The extensions should
+include a `.' if needed")
+
+(defvar ada-spec-suffixes '(".ads")
+ "List of possible suffixes for Ada spec files. The extensions should
+include a `.' if needed")
+
+(defvar ada-mode-menu (make-sparse-keymap)
+ "Menu for ada-mode")
-(defvar ada-mode-map ()
+(defvar ada-mode-map (make-sparse-keymap)
"Local keymap used for Ada mode.")
(defvar ada-mode-syntax-table nil
(defvar ada-mode-symbol-syntax-table nil
"Syntax table for Ada, where `_' is a word constituent.")
+(eval-when-compile
+ (defconst ada-83-string-keywords
+ '("abort" "abs" "accept" "access" "all" "and" "array" "at" "begin"
+ "body" "case" "constant" "declare" "delay" "delta" "digits" "do"
+ "else" "elsif" "end" "entry" "exception" "exit" "for" "function"
+ "generic" "goto" "if" "in" "is" "limited" "loop" "mod" "new"
+ "not" "null" "of" "or" "others" "out" "package" "pragma" "private"
+ "procedure" "raise" "range" "record" "rem" "renames" "return"
+ "reverse" "select" "separate" "subtype" "task" "terminate" "then"
+ "type" "use" "when" "while" "with" "xor")
+ "List of ada keywords -- This variable is not used instead to define
+ada-83-keywords and ada-95-keywords"))
+
+(defvar ada-ret-binding nil
+ "Variable to save key binding of RET when casing is activated.")
+
+(defvar ada-case-exception '()
+ "Alist of words (entities) that have special casing, and should not
+be reindented according to the function `ada-case-identifier'.
+Its value is read from the file `ada-case-exception-file'")
+
+(defvar ada-lfd-binding nil
+ "Variable to save key binding of LFD when casing is activated.")
+
+(defvar ada-other-file-alist nil
+ "Variable used by find-file to find the name of the other package.
+See `ff-other-file-alist'"
+ )
+
+;;; ---- Below are the regexp used in this package for parsing
+
(defconst ada-83-keywords
- "\\<\\(abort\\|abs\\|accept\\|access\\|all\\|and\\|array\\|\
-at\\|begin\\|body\\|case\\|constant\\|declare\\|delay\\|delta\\|\
-digits\\|do\\|else\\|elsif\\|end\\|entry\\|exception\\|exit\\|for\\|\
-function\\|generic\\|goto\\|if\\|in\\|is\\|limited\\|loop\\|mod\\|\
-new\\|not\\|null\\|of\\|or\\|others\\|out\\|package\\|pragma\\|\
-private\\|procedure\\|raise\\|range\\|record\\|rem\\|renames\\|\
-return\\|reverse\\|select\\|separate\\|subtype\\|task\\|terminate\\|\
-then\\|type\\|use\\|when\\|while\\|with\\|xor\\)\\>"
-; "\\<\\(a\\(b\\(ort\\|s\\)\\|cce\\(pt\\|ss\\)\\|ll\\|nd\\|rray\\|t\\)\\|\
-;b\\(egin\\|ody\\)\\|c\\(ase\\|onstant\\)\\|\
-;d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|\
-;e\\(ls\\(e\\|if\\)\\|n\\(d\\|try\\)\\|x\\(ception\\|it\\)\\)\\|\
-;f\\(or\\|unction\\)\\|g\\(eneric\\|oto\\)\\|i[fns]\\|l\\(imited\\|oop\\)\\|\
-;mod\\|n\\(ew\\|ot\\|ull\\)\\|o\\([fr]\\|thers\\|ut\\)\\|\
-;p\\(ackage\\|r\\(agma\\|ivate\\|ocedure\\)\\)\\|\
-;r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|turn\\|verse\\)\\)\\|\
-;s\\(e\\(lect\\|parate\\)\\|ubtype\\)\\|use\\|
-;t\\(ask\\|erminate\\|hen\\|ype\\)\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\|xor\\)\\>"
+ (eval-when-compile
+ (concat "\\<" (regexp-opt ada-83-string-keywords t) "\\>"))
"Regular expression for looking at Ada83 keywords.")
(defconst ada-95-keywords
- "\\<\\(abort\\|abs\\|abstract\\|accept\\|access\\|aliased\\|\
-all\\|and\\|array\\|at\\|begin\\|body\\|case\\|constant\\|declare\\|\
-delay\\|delta\\|digits\\|do\\|else\\|elsif\\|end\\|entry\\|\
-exception\\|exit\\|for\\|function\\|generic\\|goto\\|if\\|in\\|\
-is\\|limited\\|loop\\|mod\\|new\\|not\\|null\\|of\\|or\\|others\\|\
-out\\|package\\|pragma\\|private\\|procedure\\|protected\\|raise\\|\
-range\\|record\\|rem\\|renames\\|requeue\\|return\\|reverse\\|\
-select\\|separate\\|subtype\\|tagged\\|task\\|terminate\\|then\\|\
-type\\|until\\|use\\|when\\|while\\|with\\|xor\\)\\>"
+ (eval-when-compile
+ (concat "\\<" (regexp-opt
+ (append
+ '("abstract" "aliased" "protected" "requeue"
+ "tagged" "until")
+ ada-83-string-keywords) t) "\\>"))
"Regular expression for looking at Ada95 keywords.")
(defvar ada-keywords ada-95-keywords
"Regular expression for looking at Ada keywords.")
-(defvar ada-ret-binding nil
- "Variable to save key binding of RET when casing is activated.")
-
-(defvar ada-lfd-binding nil
- "Variable to save key binding of LFD when casing is activated.")
-
-;;; ---- Regexps to find procedures/functions/packages
-
-(defconst ada-ident-re
- "[a-zA-Z0-9_\\.]+"
+(defconst ada-ident-re
+ "\\(\\sw\\|[_.]\\)+"
"Regexp matching Ada (qualified) identifiers.")
(defvar ada-procedure-start-regexp
- "^[ \t]*\\(procedure\\|function\\|task\\)[ \t\n]+\\([a-zA-Z0-9_\\.]+\\)"
+ "^[ \t]*\\(procedure\\|function\\|task\\)[ \t\n]+\\(\\(\\sw\\|[_.]\\)+\\)"
"Regexp used to find Ada procedures/functions.")
(defvar ada-package-start-regexp
;;; ---- regexps for indentation functions
(defvar ada-block-start-re
- "\\<\\(begin\\|select\\|declare\\|private\\|or\\|generic\\|\
-exception\\|loop\\|else\\|\
-\\(\\(limited\\|abstract\\|tagged\\)[ \t]+\\)*record\\)\\>"
+ (eval-when-compile
+ (concat "\\<\\(" (regexp-opt '("begin" "declare" "else"
+ "exception" "generic" "loop" "or"
+ "private" "select" ))
+ "\\|\\(\\(limited\\|abstract\\|tagged\\)[ \t\n]+\\)*record\\)\\>"))
"Regexp for keywords starting Ada blocks.")
(defvar ada-end-stmt-re
- "\\(;\\|=>\\|^[ \t]*separate[ \t]+([a-zA-Z0-9_\\.]+)\\|\
-\\<\\(begin\\|else\\|record\\|loop\\|select\\|do\\|then\\|\
-declare\\|generic\\|private\\)\\>\\|\
-^[ \t]*\\(package\\|procedure\\|function\\)\\>[ \ta-zA-Z0-9_\\.]+\\<is\\>\\|\
-^[ \t]*exception\\>\\)"
+ (eval-when-compile
+ (concat "\\("
+ ";" "\\|"
+ "=>[ \t]*$" "\\|"
+ "^[ \t]*separate[ \t]*(\\(\\sw\\|[_.]\\)+)" "\\|"
+ "\\<" (regexp-opt '("begin" "declare" "is" "do" "else" "generic" "loop"
+ "private" "record" "select" "then") t) "\\>" "\\|"
+ "^[ \t]*" (regexp-opt '("function" "package" "procedure")
+ t) "\\>\\(\\sw\\|[ \t_.]\\)+\\<is\\>" "\\|"
+ "^[ \t]*exception\\>"
+ "\\)") )
"Regexp of possible ends for a non-broken statement.
A new statement starts after these.")
+(defvar ada-matching-start-re
+ (eval-when-compile
+ (concat "\\<"
+ (regexp-opt
+ '("end" "loop" "select" "begin" "case" "do"
+ "if" "task" "package" "record" "protected") t)
+ "\\>"))
+ "Regexp used in ada-goto-matching-start")
+
+(defvar ada-matching-decl-start-re
+ (eval-when-compile
+ (concat "\\<"
+ (regexp-opt
+ '("is" "separate" "end" "declare" "if" "new" "begin" "generic") t)
+ "\\>"))
+ "Regexp used in ada-goto-matching-decl-start")
+
+
(defvar ada-loop-start-re
"\\<\\(for\\|while\\|loop\\)\\>"
"Regexp for the start of a loop.")
(defvar ada-subprog-start-re
- "\\<\\(procedure\\|protected\\|package\\|function\\|\
-task\\|accept\\|entry\\)\\>"
+ (eval-when-compile
+ (concat "\\<" (regexp-opt '("accept" "entry" "function" "package" "procedure"
+ "protected" "task") t) "\\>"))
"Regexp for the start of a subprogram.")
(defvar ada-named-block-re
- "[ \t]*[a-zA-Z_0-9]+ *:[^=]"
+ "[ \t]*\\(\\sw\\|_\\)+[ \t]*:[^=]"
"Regexp of the name of a block or loop.")
+
\f
-;; Written by Christian Egli <Christian.Egli@hcsd.hac.com>
-;;
+;;------------------------------------------------------------------
+;; Support for imenu (see imenu.el)
+;;------------------------------------------------------------------
+
(defvar ada-imenu-generic-expression
- '((nil "^\\s-*\\(procedure\\|function\\)\\s-+\\([A-Za-z0-9_]+\\)" 2)
- ("Type Defs" "^\\s-*\\(sub\\)?type\\s-+\\([A-Za-z0-9_]+\\)" 2))
+ (list
+ '(nil "^[ \t]*\\(procedure\\|function\\)[ \t\n]+\\(\\(\\sw\\|_\\)+\\)[ \t\n]*\\([ \t\n]\\|([^)]+)\\)[ \t\n]*\\(return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?is[ \t\n]" 2)
+ (list "*Specs*"
+ (concat
+ "^[ \t]*\\(procedure\\|function\\)[ \t\n]+\\(\\(\\sw\\|_\\)+\\)"
+ "\\("
+ "\\([ \t\n]+\\|[ \t\n]*([^)]+)\\)";; parameter list or simple space
+ "\\([ \t\n]*return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?"
+ "\\)?;") 2)
+ '("*Tasks*" "^[ \t]*task[ \t]+\\(\\(body\\|type\\)[ \t]+\\)?\\(\\(\\sw\\|_\\)+\\)" 3)
+ '("*Type Defs*" "^[ \t]*\\(sub\\)?type[ \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.")
- "Imenu generic expression for Ada mode. See `imenu-generic-expression'.")
\f
+
+;;------------------------------------------------------------
+;; Supporte for compile.el
+;;------------------------------------------------------------
+
+(defun ada-compile-mouse-goto-error ()
+ "mouse interface for ada-compile-goto-error"
+ (interactive)
+ (mouse-set-point last-input-event)
+ (ada-compile-goto-error (point))
+ )
+
+(defun ada-compile-goto-error (pos)
+ "replaces compile-goto-error from compile.el: if point is on an 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: missing argument for parameter set in call to size declared at foo.ads:11
+both file locations can be clicked on and jumped to"
+ (interactive "d")
+ (goto-char pos)
+
+ (skip-chars-backward "-a-zA-Z0-9_:./\\")
+ (cond
+ ;; special case: looking at a filename:line not at the beginning of a line
+ ((and (not (bolp))
+ (looking-at
+ "\\(\\(\\sw\\|[_-.]\\)+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?"))
+ (let ((line (match-string 3))
+ (error-pos (point-marker))
+ source)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (set-buffer (compilation-find-file (point-marker) (match-string 1)
+ "./"))
+ (if (stringp line)
+ (goto-line (string-to-number line)))
+ (set 'source (point-marker))))
+ (compilation-goto-locus (cons source error-pos))
+ ))
+
+ ;; otherwise, default behavior
+ (t
+ (compile-goto-error))
+ )
+ (recenter))
+
;;;-------------
;;; functions
;;;-------------
-(defun ada-xemacs ()
- (or (string-match "Lucid" emacs-version)
- (string-match "XEmacs" emacs-version)))
-
(defun ada-create-syntax-table ()
"Create the syntax table for Ada mode."
;; There are two different syntax-tables. The standard one declares
- ;; `_' as a symbol constituent, in the second one, it is a word
- ;; constituent. For some search and replacing routines we
+ ;; `_' as a symbol constituant, in the second one, it is a word
+ ;; constituant. For some search and replacing routines we
;; temporarily switch between the two.
- (setq ada-mode-syntax-table (make-syntax-table))
+ (interactive)
+ (set 'ada-mode-syntax-table (make-syntax-table))
(set-syntax-table ada-mode-syntax-table)
;; define string brackets (`%' is alternative string bracket, but
(modify-syntax-entry ?% "$" ada-mode-syntax-table)
(modify-syntax-entry ?\" "\"" ada-mode-syntax-table)
- (modify-syntax-entry ?\# "$" ada-mode-syntax-table)
-
(modify-syntax-entry ?: "." ada-mode-syntax-table)
(modify-syntax-entry ?\; "." ada-mode-syntax-table)
(modify-syntax-entry ?& "." ada-mode-syntax-table)
;; a single hyphen is punctuation, but a double hyphen starts a comment
(modify-syntax-entry ?- ". 12" ada-mode-syntax-table)
+ ;; # is set to be a matched-pair, since it is used for based numbers,
+ ;; as in 16#3f#. The syntax class will be modifed later when it
+ ;; appears at the beginning of a line for gnatprep statements.
+ ;; For Emacs, the modification is done in font-lock-syntactic-keywords
+ ;; or ada-after-change-function.
+ ;; For XEmacs, this is not done correctly for now, based numbers won't
+ ;; be handled correctly.
+ (if ada-xemacs
+ (modify-syntax-entry ?# "<" ada-mode-syntax-table)
+ (modify-syntax-entry ?# "$" ada-mode-syntax-table))
+
;; and \f and \n end a comment
(modify-syntax-entry ?\f "> " ada-mode-syntax-table)
(modify-syntax-entry ?\n "> " ada-mode-syntax-table)
(modify-syntax-entry ?\( "()" ada-mode-syntax-table)
(modify-syntax-entry ?\) ")(" ada-mode-syntax-table)
- (setq ada-mode-symbol-syntax-table (copy-syntax-table ada-mode-syntax-table))
+ (set 'ada-mode-symbol-syntax-table (copy-syntax-table ada-mode-syntax-table))
(modify-syntax-entry ?_ "w" ada-mode-symbol-syntax-table)
)
+;;
+;; This is to support XEmacs, which does not have the syntax-table attribute
+;; as used in ada-after-change-function
+;; When executing parse-partial-sexp, we simply modify the strings before and
+;; after, so that the special constants '"', '(' and ')' do not interact
+;; with parse-partial-sexp.
+
+(if ada-xemacs
+ (defadvice parse-partial-sexp (around parse-partial-sexp-protect-constants)
+ (let (change)
+ (if (< to from)
+ (let ((tmp from))
+ (setq from to to tmp)))
+ (save-excursion
+ (goto-char from)
+ (while (re-search-forward "'\\([(\")#]\\)'" to t)
+ (set 'change (cons (list (match-beginning 1)
+ 1
+ (match-string 1))
+ change))
+ (replace-match "'A'"))
+ (goto-char from)
+ (while (re-search-forward "\\(#[0-9a-fA-F]*#\\)" to t)
+ (set 'change (cons (list (match-beginning 1)
+ (length (match-string 1))
+ (match-string 1))
+ change))
+ (replace-match (make-string (length (match-string 1)) ?@))))
+ ad-do-it
+ (save-excursion
+ (while change
+ (goto-char (caar change))
+ (delete-char (cadar change))
+ (insert (caddar change))
+ (set 'change (cdr change)))))))
+
+;;
+;; The following three functions handle the text properties in the buffer:
+;; the problem in Ada is that ' can be both a constant character delimiter
+;; and an attribute delimiter. To handle this easily (and allowing us to
+;; use the standard Emacs functions for sexp... as in ada-in-string-p), we
+;; change locally the syntax table every time we see a character constant.
+;; The three characters are then said to be part of a string.
+;; This handles nicely the '"' case (" is simply ignored in that case)
+;;
+;; The idea for this code was borrowed from font-lock.el, which actually
+;; does the same job thanks to ada-font-lock-syntactic-keywords. No need
+;; to duplicate the work if we already use font-lock
+;;
+;; This code is not executed for XEmacs, since the syntax-table attribute is
+;; not known
+
+(defun ada-deactivate-properties ()
+ "Deactivate ada-mode's properties handling, since this would be
+a duplicate of font-lock"
+ (remove-hook 'after-change-functions 'ada-after-change-function t))
+
+(defun ada-initialize-properties ()
+ "Initialize some special text properties in the whole buffer.
+In particular, character constants that contain string delimiters are said
+to be strings.
+We also treat #..# as numbers, instead of gnatprep comments
+"
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (re-search-forward "'.'" nil t)
+ (add-text-properties (match-beginning 0) (match-end 0)
+ '(syntax-table ("'" . ?\"))))
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]*#" nil t)
+ (add-text-properties (match-beginning 0) (match-end 0)
+ '(syntax-table (11 . 10))))
+ (set-buffer-modified-p nil)
+
+ ;; Setting this only if font-lock is not set won't work
+ ;; if the user activates or deactivates font-lock-mode,
+ ;; but will make things faster most of the time
+ (make-local-hook 'after-change-functions)
+ (add-hook 'after-change-functions 'ada-after-change-function nil t)
+ )))
+
+(defun ada-after-change-function (beg end old-len)
+ "Called every time a character is changed in the buffer"
+ ;; borrowed from font-lock.el
+ (let ((inhibit-point-motion-hooks t)
+ (eol (point)))
+ (save-excursion
+ (save-match-data
+ (beginning-of-line)
+ (remove-text-properties (point) eol '(syntax-table nil))
+ (while (re-search-forward "'.'" eol t)
+ (add-text-properties (match-beginning 0) (match-end 0)
+ '(syntax-table ("'" . ?\"))))
+ (beginning-of-line)
+ (if (looking-at "^[ \t]*#")
+ (add-text-properties (match-beginning 0) (match-end 0)
+ '(syntax-table (11 . 10))))
+ ))))
+
+
+(defvar ada-contextual-menu-on-identifier nil)
+
+(defvar ada-contextual-menu
+ (if ada-xemacs
+ '("Ada"
+ ["Goto Declaration/Body" ada-goto-declaration
+ :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]
+ ["-" 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"
+ ada-point-and-xref
+ :visible ada-contextual-menu-on-identifier
+ ) t)
+ (define-key-after map [Prev]
+ '("Goto Previous Reference" .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)))
+
+(defun ada-popup-menu (position)
+ "Pops up a contextual menu, depending on where the user clicked"
+ (interactive "e")
+ (mouse-set-point last-input-event)
+
+ (setq ada-contextual-menu-on-identifier
+ (and (or (= (char-syntax (char-after)) ?w)
+ (= (char-after) ?_))
+ (not (ada-in-string-or-comment-p))
+ (save-excursion (skip-syntax-forward "w")
+ (not (ada-after-keyword-p)))
+ ))
+ (let (choice)
+ (if ada-xemacs
+ (set 'choice (popup-menu ada-contextual-menu))
+ (set 'choice (x-popup-menu position ada-contextual-menu)))
+ (if choice
+ (funcall (lookup-key ada-contextual-menu (vector (car choice)))))))
+
+;;;###autoload
+(defun ada-add-extensions (spec body)
+ "Add a new set of extensions to the ones recognized by ada-mode.
+The addition is done so that `goto-other-file' works as expected"
+
+ (let* ((reg (concat (regexp-quote body) "$"))
+ (tmp (assoc reg ada-other-file-alist)))
+ (if tmp
+ (setcdr tmp (list (cons spec (cadr tmp))))
+ (add-to-list 'ada-other-file-alist (list reg (list spec)))))
+
+ (let* ((reg (concat (regexp-quote spec) "$"))
+ (tmp (assoc reg ada-other-file-alist)))
+ (if tmp
+ (setcdr tmp (list (cons body (cadr tmp))))
+ (add-to-list 'ada-other-file-alist (list reg (list body)))))
+
+ (add-to-list 'auto-mode-alist (cons spec 'ada-mode))
+ (add-to-list 'auto-mode-alist (cons 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
+ (progn
+ (require 'speedbar)
+ (speedbar-add-supported-extension spec)
+ (speedbar-add-supported-extension body)))
+ )
+
+
;;;###autoload
(defun ada-mode ()
Re-format the parameter-list point is in '\\[ada-format-paramlist]'
Indent all lines in region '\\[ada-indent-region]'
- Call external pretty printer program '\\[ada-call-pretty-printer]'
Adjust case of identifiers and keywords in region '\\[ada-adjust-case-region]'
Adjust case of identifiers and keywords in buffer '\\[ada-adjust-case-buffer]'
- Call EXTERNAL pretty printer (if you have one) '\\[ada-call-pretty-printer]'
-
- Fill comment paragraph '\\[ada-fill-comment-paragraph]'
- Fill comment paragraph and justify each line '\\[ada-fill-comment-paragraph-justify]'
- Fill comment paragraph, justify and append postfix '\\[ada-fill-comment-paragraph-postfix]'
+ Fill comment paragraph, justify and append postfix '\\[fill-paragraph]'
Next func/proc/task '\\[ada-next-procedure]' Previous func/proc/task '\\[ada-previous-procedure]'
Next package '\\[ada-next-package]' Previous package '\\[ada-previous-package]'
or '\\[ff-mouse-find-other-file]
Switch to other file in other window '\\[ada-ff-other-window]'
or '\\[ff-mouse-find-other-file-other-window]
- If you use this function in a spec and no body is available, it gets created
- with body stubs.
+ If you use this function in a spec and no body is available, it gets created with body stubs.
If you use ada-xref.el:
Goto declaration: '\\[ada-point-and-xref]' on the identifier
or '\\[ada-goto-declaration]' with point on the identifier
- Complete identifier: '\\[ada-complete-identifier]'
- Execute Gnatf: '\\[ada-gnatf-current]'"
+ Complete identifier: '\\[ada-complete-identifier]'"
(interactive)
(kill-all-local-variables)
- (make-local-variable 'require-final-newline)
- (setq require-final-newline t)
+ (set (make-local-variable 'require-final-newline) t)
(make-local-variable 'comment-start)
- (setq comment-start "-- ")
+ (if ada-fill-comment-prefix
+ (set 'comment-start ada-fill-comment-prefix)
+ (set 'comment-start "-- "))
+
+ ;; Set the paragraph delimiters so that one can select a whole block
+ ;; simply with M-h
+ (set (make-local-variable 'paragraph-start) "[ \t\n\f]*$")
+ (set (make-local-variable 'paragraph-separate) "[ \t\n\f]*$")
;; comment end must be set because it may hold a wrong value if
;; this buffer had been in another mode before. RE
- (make-local-variable 'comment-end)
- (setq comment-end "")
-
- (make-local-variable 'comment-start-skip) ;; used by autofill
- (setq comment-start-skip "--+[ \t]*")
-
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'ada-indent-current-function)
-
- (make-local-variable 'fill-column)
- (setq fill-column 75)
-
- (make-local-variable 'comment-column)
- (setq comment-column 40)
-
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments t)
-
- (make-local-variable 'case-fold-search)
- (setq case-fold-search t)
-
- (make-local-variable 'outline-regexp)
- (setq outline-regexp "[^\n\^M]")
- (make-local-variable 'outline-level)
- (setq outline-level 'ada-outline-level)
-
- (make-local-variable 'fill-paragraph-function)
- (setq fill-paragraph-function 'ada-fill-comment-paragraph)
- ;;(make-local-variable 'adaptive-fill-regexp)
-
- (make-local-variable 'imenu-generic-expression)
- (setq imenu-generic-expression ada-imenu-generic-expression)
- (setq imenu-case-fold-search t)
-
- (if (ada-xemacs) nil ; XEmacs uses properties
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults
- '((ada-font-lock-keywords
- ada-font-lock-keywords-1 ada-font-lock-keywords-2)
- nil t
- ((?\_ . "w")(?\. . "w"))
- beginning-of-line
- (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords)))
-
- ;; Set up support for find-file.el.
- (make-variable-buffer-local 'ff-other-file-alist)
- (make-variable-buffer-local 'ff-search-directories)
- (setq ff-other-file-alist 'ada-other-file-alist
- ff-search-directories 'ada-search-directories
- ff-pre-load-hooks 'ff-which-function-are-we-in
- ff-post-load-hooks 'ff-set-point-accordingly
- ff-file-created-hooks 'ada-make-body))
-
- (setq major-mode 'ada-mode)
- (setq mode-name "Ada")
+ (set (make-local-variable 'comment-end) "")
+
+ ;; used by autofill and indent-new-comment-line
+ (set (make-local-variable 'comment-start-skip) "---*[ \t]*")
+
+ ;; used by autofill to break a comment line and continue it on another line.
+ ;; The reason we need this one is that the default behavior does not work
+ ;; correctly with the definition of paragraph-start above when the comment
+ ;; is right after a multiline subprogram declaration (the comments are
+ ;; aligned under the latest parameter, not under the declaration start).
+ (set (make-local-variable 'comment-line-break-function)
+ (lambda (&optional soft) (let ((fill-prefix nil))
+ (indent-new-comment-line soft))))
+
+ (set (make-local-variable 'indent-line-function)
+ 'ada-indent-current-function)
+
+ (set (make-local-variable 'comment-column) 40)
+
+ ;; Emacs 20.3 defines a comment-padding to insert spaces between
+ ;; the comment and the text. We do not want any, this is already
+ ;; included in comment-start
+ (unless ada-xemacs
+ (progn
+ (if (ada-check-emacs-version 20 3)
+ (progn
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (set (make-local-variable 'comment-padding) 0)))
+ (set (make-local-variable 'parse-sexp-lookup-properties) t)
+ ))
+
+ (set 'case-fold-search t)
+ (if (boundp 'imenu-case-fold-search)
+ (set 'imenu-case-fold-search t))
+
+ (set (make-local-variable 'fill-paragraph-function)
+ 'ada-fill-comment-paragraph)
+
+ (set (make-local-variable 'imenu-generic-expression)
+ ada-imenu-generic-expression)
+
+ ;; Support for compile.el
+ ;; We just substitute our own functions to go to the error.
+ (add-hook 'compilation-mode-hook
+ '(lambda()
+ (set 'compile-auto-highlight 40)
+ (define-key compilation-minor-mode-map [mouse-2]
+ 'ada-compile-mouse-goto-error)
+ (define-key compilation-minor-mode-map "\C-c\C-c"
+ 'ada-compile-goto-error)
+ (define-key compilation-minor-mode-map "\C-m"
+ 'ada-compile-goto-error)
+ ))
+
+ ;; font-lock support :
+ ;; We need to set some properties for Xemacs, and define some variables
+ ;; for Emacs
+
+ (if ada-xemacs
+ ;; XEmacs
+ (put 'ada-mode 'font-lock-defaults
+ '(ada-font-lock-keywords
+ nil t ((?\_ . "w") (?# . ".")) beginning-of-line))
+ ;; Emacs
+ (set (make-local-variable 'font-lock-defaults)
+ '(ada-font-lock-keywords
+ nil t
+ ((?\_ . "w") (?# . "."))
+ beginning-of-line
+ (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords)))
+ )
+
+ ;; Set up support for find-file.el.
+ (set (make-variable-buffer-local '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)
+
+ ;; Some special constructs for find-file.el
+ ;; We do not need to add the construction for 'with', which is in the
+ ;; standard find-file.el
+ ;; Go to the parent package :
+ (make-local-variable 'ff-special-constructs)
+ (add-to-list 'ff-special-constructs
+ (cons (eval-when-compile
+ (concat "^\\(private[ \t]\\)?[ \t]*package[ \t]+"
+ "\\(body[ \t]+\\)?"
+ "\\(\\(\\sw\\|[_.]\\)+\\)\\.\\(\\sw\\|_\\)+[ \t\n]+is"))
+ '(lambda ()
+ (set 'fname (ff-get-file
+ ff-search-directories
+ (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 ()
+ (set 'fname (ff-get-file
+ ff-search-directories
+ (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
+ (add-to-list 'ff-special-constructs
+ (cons "^with[ \t]+\\([a-zA-Z0-9_\\.]+\\)"
+ '(lambda ()
+ (set 'fname (ff-get-file
+ ff-search-directories
+ (ada-make-filename-from-adaname
+ (match-string 1))
+ ada-spec-suffixes)))))
+
+ ;; Support for outline-minor-mode
+ (set (make-local-variable 'outline-regexp)
+ "\\([ \t]*\\(procedure\\|function\\|package\\|with\\|use\\)\\|--\\|end\\)")
+ (set (make-local-variable 'outline-level) 'ada-outline-level)
+
+ ;; Support for imenu : We want a sorted index
+ (set 'imenu-sort-function 'imenu--sort-by-name)
+
+ ;; Set up the contextual menu
+ (if ada-popup-key
+ (define-key ada-mode-map ada-popup-key 'ada-popup-menu))
+
+ ;; Support for indent-new-comment-line (Especially for XEmacs)
+ (set 'comment-multi-line nil)
+ (defconst comment-indent-function (lambda () comment-column))
+
+ (set 'major-mode 'ada-mode)
+ (set 'mode-name "Ada")
(use-local-map ada-mode-map)
- (if ada-mode-syntax-table
- (set-syntax-table ada-mode-syntax-table)
- (ada-create-syntax-table))
+ (if ada-xemacs
+ (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 'ada-remove-trailing-spaces)
- ;; convert all tabs to the correct number of spaces.
- (add-hook 'local-write-file-hooks 'ada-untabify-buffer)))
+ ;; remove all spaces at the end of lines in the whole buffer.
+ (add-hook 'local-write-file-hooks 'ada-remove-trailing-spaces)
+ ;; convert all tabs to the correct number of spaces.
+ (add-hook 'local-write-file-hooks
+ '(lambda () (untabify (point-min) (point-max))))))
+ (run-hooks 'ada-mode-hook)
- ;; add menu 'Ada' to the menu bar
- (ada-add-ada-menu)
+ ;; Run this after the hook to give the users a chance to activate
+ ;; font-lock-mode
- (run-hooks 'ada-mode-hook)
+ (unless ada-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
;; because users might want to set the values of these variable
;; inside the hook (MH)
+ ;; Note that we add the new elements at the end of ada-other-file-alist
+ ;; since some user might want to give priority to some other extensions
+ ;; first (for instance, a .adb file could be associated with a .ads
+ ;; or a .ads.gp (gnatprep)).
+ ;; This is why we can't use add-to-list here.
(cond ((eq ada-language-version 'ada83)
- (setq ada-keywords ada-83-keywords))
+ (set 'ada-keywords ada-83-keywords))
((eq ada-language-version 'ada95)
- (setq ada-keywords ada-95-keywords)))
+ (set 'ada-keywords ada-95-keywords)))
(if ada-auto-case
(ada-activate-keys-for-case)))
\f
-;;;--------------------------
-;;; Compile support
-;;;--------------------------
-(defun ada-check-syntax ()
- "Check syntax of the current buffer.
-Uses the function `compile' to execute `ada-compiler-syntax-check'."
- (interactive)
- (let ((old-compile-command compile-command))
- (setq compile-command (concat ada-compiler-syntax-check
- (if (eq ada-language-version 'ada83)
- "-gnat83 ")
- " " ada-compile-options " "
- (buffer-name)))
- (setq compile-command (read-from-minibuffer
- "enter command for syntax check: "
- compile-command))
- (compile compile-command)
- ;; restore old compile-command
- (setq compile-command old-compile-command)))
-
-(defun ada-make-local ()
- "Bring current Ada unit up-to-date.
-Uses the function `compile' to execute `ada-compile-make'."
- (interactive)
- (let ((old-compile-command compile-command))
- (setq compile-command (concat ada-compiler-make
- " " ada-make-options " "
- (buffer-name)))
- (setq compile-command (read-from-minibuffer
- "enter command for local make: "
- compile-command))
- (compile compile-command)
- ;; restore old compile-command
- (setq compile-command old-compile-command)))
+;;;--------------------------------------------------------
+;;; auto-casing
+;;;--------------------------------------------------------
-
-\f
-;;;--------------------------
-;;; Fill Comment Paragraph
-;;;--------------------------
-
-(defun ada-fill-comment-paragraph-justify ()
- "Fills current comment paragraph and justifies each line as well."
+(defun ada-create-case-exception (&optional word)
+ "Defines WORD as an exception for the casing system. If WORD
+is not given, then the current word in the buffer is used instead.
+Every time the ada-mode will see the same word, the same casing will
+be used.
+The new words is added to the file `ada-case-exception-file'"
(interactive)
- (ada-fill-comment-paragraph t))
-
-
-(defun ada-fill-comment-paragraph-postfix ()
- "Fills current comment paragraph and justifies each line as well.
-Prompts for a postfix to be appended to each line."
- (interactive)
- (ada-fill-comment-paragraph t t))
-
-
-(defun ada-fill-comment-paragraph (&optional justify postfix)
- "Fills the current comment paragraph.
-If JUSTIFY is non-nil, each line is justified as well.
-If POSTFIX and JUSTIFY are non-nil, `ada-fill-comment-postfix' is appended
-to each filled and justified line.
-If `ada-indent-comment-as-code' is non-nil, the paragraph is idented."
- (interactive "P")
- (let ((opos (point-marker))
- (begin nil)
- (end nil)
- (end-2 nil)
- (indent nil)
- (ada-fill-comment-old-postfix "")
- (fill-prefix nil))
-
- ;; check if inside comment
- (if (not (ada-in-comment-p))
- (error "not inside comment"))
-
- ;; prompt for postfix if wanted
- (if (and justify
- postfix)
- (setq ada-fill-comment-postfix
- (read-from-minibuffer "enter new postfix string: "
- ada-fill-comment-postfix)))
-
- ;; prompt for old postfix to remove if necessary
- (if (and justify
- postfix)
- (setq ada-fill-comment-old-postfix
- (read-from-minibuffer "enter already existing postfix string: "
- ada-fill-comment-postfix)))
-
- ;;
- ;; find limits of paragraph
- ;;
- (message "filling comment paragraph ...")
- (save-excursion
- (back-to-indentation)
- ;; find end of paragraph
- (while (and (looking-at "--.*$")
- (not (looking-at "--[ \t]*$")))
- (forward-line 1)
- (back-to-indentation))
- (beginning-of-line)
- (setq end (point-marker))
- (goto-char opos)
- ;; find begin of paragraph
- (back-to-indentation)
- (while (and (looking-at "--.*$")
- (not (looking-at "--[ \t]*$")))
- (forward-line -1)
- (back-to-indentation))
- (forward-line 1)
- ;; get indentation to calculate width for filling
- (ada-indent-current)
- (back-to-indentation)
- (setq indent (current-column))
- (setq begin (point-marker)))
-
- ;; delete old postfix if necessary
- (if (and justify
- postfix)
- (save-excursion
- (goto-char begin)
- (while (re-search-forward (concat ada-fill-comment-old-postfix
- "\n")
- end t)
- (replace-match "\n"))))
-
- ;; delete leading whitespace and uncomment
- (save-excursion
- (goto-char begin)
- (beginning-of-line)
- (while (re-search-forward "^[ \t]*--[ \t]*" end t)
- (replace-match "")))
-
- ;; calculate fill width
- (setq fill-column (- fill-column indent
- (length ada-fill-comment-prefix)
- (if postfix
- (length ada-fill-comment-postfix)
- 0)))
- ;; fill paragraph
- (fill-region begin (1- end) justify)
- (setq fill-column (+ fill-column indent
- (length ada-fill-comment-prefix)
- (if postfix
- (length ada-fill-comment-postfix)
- 0)))
- ;; find end of second last line
- (save-excursion
- (goto-char end)
- (forward-line -2)
- (end-of-line)
- (setq end-2 (point-marker)))
-
- ;; re-comment and re-indent region
- (save-excursion
- (goto-char begin)
- (indent-to indent)
- (insert ada-fill-comment-prefix)
- (while (re-search-forward "\n" (1- end-2) t)
- (replace-match (concat "\n" ada-fill-comment-prefix))
- (beginning-of-line)
- (indent-to indent)))
-
- ;; append postfix if wanted
- (if (and justify
- postfix
- ada-fill-comment-postfix)
- (progn
- ;; append postfix up to there
- (save-excursion
- (goto-char begin)
- (while (re-search-forward "\n" (1- end-2) t)
- (replace-match (concat ada-fill-comment-postfix "\n")))
-
- ;; fill last line and append postfix
- (end-of-line)
- (insert-char ?
- (- fill-column
- (current-column)
- (length ada-fill-comment-postfix)))
- (insert ada-fill-comment-postfix))))
-
- ;; delete the extra line that gets inserted somehow(??)
- (save-excursion
- (goto-char (1- end))
- (end-of-line)
- (delete-char 1))
+ (let ((previous-syntax-table (syntax-table))
+ (exception-list '()))
+ (set-syntax-table ada-mode-symbol-syntax-table)
+ (unless word
+ (save-excursion
+ (skip-syntax-backward "w")
+ (set 'word (buffer-substring-no-properties
+ (point) (save-excursion (forward-word 1) (point))))))
+
+ ;; 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 ada-case-exception-file))
+ (let ((buffer (current-buffer)))
+ (find-file (expand-file-name ada-case-exception-file))
+ (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)))
+
+ ;; 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))
+ )
- (message "filling comment paragraph ... done")
- (goto-char opos))
- t)
+ (if (and (not (equal ada-case-exception '()))
+ (assoc-ignore-case word ada-case-exception))
+ (setcar (assoc-ignore-case word ada-case-exception)
+ word)
+ (add-to-list 'ada-case-exception (cons word t))
+ )
-\f
-;;;--------------------------------;;;
-;;; Call External Pretty Printer ;;;
-;;;--------------------------------;;;
-
-(defun ada-call-pretty-printer ()
- "Calls the external Pretty Printer.
-The name is specified in `ada-external-pretty-print-program'. Saves the
-current buffer in a directory specified by `ada-tmp-directory',
-starts the pretty printer as external process on that file and then
-reloads the beautified program in the buffer and cleans up
-`ada-tmp-directory'."
+ ;; Save the list in the file
+ (find-file (expand-file-name ada-case-exception-file))
+ (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)
+ ))
+
+(defun ada-case-read-exceptions ()
+ "Read the file `ada-case-exception-file' for the list of identifiers that
+have special casing"
(interactive)
- (let ((filename-with-path buffer-file-name)
- (curbuf (current-buffer))
- (orgpos (point))
- (mesgbuf nil) ;; for byte-compiling
- (file-path (file-name-directory buffer-file-name))
- (filename-without-path (file-name-nondirectory buffer-file-name))
- (tmp-file-with-directory
- (concat ada-tmp-directory
- (file-name-nondirectory buffer-file-name))))
- ;;
- ;; save buffer in temporary file
- ;;
- (message "saving current buffer to temporary file ...")
- (write-file tmp-file-with-directory)
- (auto-save-mode nil)
- (message "saving current buffer to temporary file ... done")
- ;;
- ;; call external pretty printer program
- ;;
+ (set 'ada-case-exception '())
+ (if (file-readable-p (expand-file-name ada-case-exception-file))
+ (let ((buffer (current-buffer)))
+ (find-file (expand-file-name ada-case-exception-file))
+ (set-syntax-table ada-mode-symbol-syntax-table)
+ (widen)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (add-to-list 'ada-case-exception
+ (cons
+ (buffer-substring-no-properties
+ (point) (save-excursion (forward-word 1) (point)))
+ t))
+ (forward-line 1))
+ (kill-buffer nil)
+ (set-buffer buffer)
+ )))
+
+(defun ada-adjust-case-identifier ()
+ "Adjust case of the previous identifier. The auto-casing is
+done according to the value of `ada-case-identifier' and the
+exceptions defined in `ada-case-exception'"
+
+ (if (or (equal ada-case-exception '())
+ (equal (char-after) ?_))
+ (funcall ada-case-identifier -1)
- (message "running external pretty printer ...")
- ;; create a temporary buffer for messages of pretty printer
- (setq mesgbuf (get-buffer-create "Pretty Printer Messages"))
- ;; execute pretty printer on temporary file
- (call-process ada-external-pretty-print-program
- nil mesgbuf t
- tmp-file-with-directory)
- ;; display messages if there are some
- (if (buffer-modified-p mesgbuf)
- ;; show the message buffer
- (display-buffer mesgbuf t)
- ;; kill the message buffer
- (kill-buffer mesgbuf))
- (message "running external pretty printer ... done")
- ;;
- ;; kill current buffer and load pretty printer output
- ;; or restore old buffer
- ;;
- (if (y-or-n-p
- "Really replace current buffer with pretty printer output ? ")
- (progn
- (set-buffer-modified-p nil)
- (kill-buffer curbuf)
- (find-file tmp-file-with-directory))
- (message "old buffer contents restored"))
- ;;
- ;; delete temporary file and restore information of current buffer
- ;;
- (delete-file tmp-file-with-directory)
- (set-visited-file-name filename-with-path)
- (auto-save-mode t)
- (goto-char orgpos)))
+ (progn
+ (let ((end (point))
+ (start (save-excursion (skip-syntax-backward "w")
+ (point)))
+ match)
+ ;; If we have an exception, replace the word by the correct casing
+ (if (set 'match (assoc-ignore-case (buffer-substring start end)
+ ada-case-exception))
-\f
-;;;---------------
-;;; auto-casing
-;;;---------------
+ (progn
+ (delete-region start end)
+ (insert (car match)))
-;; from Philippe Waroquiers <philippe@cfmu.eurocontrol.be>
-;; modified by RE and MH
+ ;; Else simply recase the word
+ (funcall ada-case-identifier -1))))))
(defun ada-after-keyword-p ()
;; returns t if cursor is after a keyword.
(save-excursion
(forward-word -1)
- (and (save-excursion
- (or
- (= (point) (point-min))
- (backward-char 1))
- (not (looking-at "_"))) ; (MH)
- (looking-at (concat ada-keywords "[^_]")))))
-
-(defun ada-in-char-const-p ()
- ;; Returns t if point is inside a character constant.
- ;; We assume to be in a constant if the previous and the next character
- ;; are "'".
- (save-excursion
- (if (> (point) 1)
- (and
- (progn
- (forward-char 1)
- (looking-at "'"))
- (progn
- (forward-char -2)
- (looking-at "'")))
- nil)))
-
+ (and (not (and (char-before) (= (char-before) ?_)));; unless we have a _
+ (looking-at (concat ada-keywords "[^_]")))))
(defun ada-adjust-case (&optional force-identifier)
"Adjust the case of the word before the just typed character.
-Respect options `ada-case-keyword', `ada-case-identifier', and
+Respect options `ada-case-keyword', `ada-case-identifier', and
`ada-case-attribute'.
If FORCE-IDENTIFIER is non-nil then also adjust keyword as identifier." ; (MH)
- (forward-char -1)
- (if (and (> (point) 1) (not (or (ada-in-string-p)
- (ada-in-comment-p)
- (ada-in-char-const-p))))
- (if (eq (char-syntax (char-after (1- (point)))) ?w)
- (if (save-excursion
- (forward-word -1)
- (or (= (point) (point-min))
- (backward-char 1))
- (looking-at "'"))
- (funcall ada-case-attribute -1)
- (if (and
- (not force-identifier) ; (MH)
- (ada-after-keyword-p))
- (funcall ada-case-keyword -1)
- (funcall ada-case-identifier -1)))))
- (forward-char 1))
-
+ (let ((previous-syntax-table (syntax-table)))
+ (set-syntax-table ada-mode-symbol-syntax-table)
+
+ (forward-char -1)
+
+ ;; Do nothing in some cases
+ (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)
+ (set-syntax-table previous-syntax-table)
+ )
+ )
(defun ada-adjust-case-interactive (arg)
(interactive "P")
(defun ada-activate-keys-for-case ()
+ (interactive)
;; save original keybindings to allow swapping ret/lfd
;; when casing is activated
;; the 'or ...' is there to be sure that the value will not
;; be changed again when Ada mode is called more than once (MH)
(or ada-ret-binding
- (setq ada-ret-binding (key-binding "\C-M")))
+ (set 'ada-ret-binding (key-binding "\C-M")))
(or ada-lfd-binding
- (setq ada-lfd-binding (key-binding "\C-j")))
+ (set 'ada-lfd-binding (key-binding "\C-j")))
;; call case modifying function after certain keys.
(mapcar (function (lambda(key) (define-key
ada-mode-map
(char-to-string key)
'ada-adjust-case-interactive)))
'( ?` ?~ ?! ?@ ?# ?$ ?% ?^ ?& ?* ?( ?) ?- ?= ?+ ?[ ?{ ?] ?}
- ?_ ?\\ ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?? ?/ ?\n 32 ?\r )))
-;; deleted ?\t from above list
+ ?\\ ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?? ?/ ?\n 32 ?\r )))
;;
;; added by MH
;;
(defun ada-loose-case-word (&optional arg)
- "Capitalizes the first letter and the letters following `_'.
-ARG is ignored, it's there to fit the standard casing functions' style."
+ "Capitalizes the first letter and the letters following `_' for the following
+word. Ignores Arg (its there to conform to capitalize-word parameters)
+Does not change other letters"
+ (interactive)
(let ((pos (point))
(first t))
- (skip-chars-backward "a-zA-Z0-9_")
+ (skip-syntax-backward "w")
(while (or first
(search-forward "_" pos t))
(and first
- (setq first nil))
+ (set 'first nil))
(insert-char (upcase (following-char)) 1)
(delete-char 1))
(goto-char pos)))
+(defun ada-capitalize-word (&optional arg)
+ "Capitalizes the first letter and the letters following '_', and
+lower case other letters"
+ (interactive)
+ (let ((pos (point)))
+ (skip-syntax-backward "w")
+ (modify-syntax-entry ?_ "_")
+ (capitalize-region (point) pos)
+ (goto-char pos)
+ (modify-syntax-entry ?_ "w")))
;;
;; added by MH
(let ((begin nil)
(end nil)
(keywordp nil)
- (attribp nil))
+ (attribp nil)
+ (previous-syntax-table (syntax-table)))
+ (message "Adjusting case ...")
(unwind-protect
- (save-excursion
- (set-syntax-table ada-mode-symbol-syntax-table)
- (goto-char to)
- ;;
- ;; loop: look for all identifiers, keywords, and attributes
- ;;
- (while (re-search-backward
- "[^a-zA-Z0-9_]\\([a-zA-Z0-9_]+\\)[^a-zA-Z0-9_]"
- from
- t)
- ;;
- ;; print status message
- ;;
- (message "adjusting case ... %5d characters left" (- (point) from))
- (setq attribp (looking-at "'[a-zA-Z0-9_]+[^']"))
- (forward-char 1)
- (or
- ;; do nothing if it is a string or comment
- (ada-in-string-or-comment-p)
- (progn
- ;;
- ;; get the identifier or keyword or attribute
- ;;
- (setq begin (point))
- (setq keywordp (looking-at (concat ada-keywords "[^_]")))
- (skip-chars-forward "a-zA-Z0-9_")
- ;;
- ;; casing according to user-option
- ;;
- (if keywordp
- (funcall ada-case-keyword -1)
- (if attribp
- (funcall ada-case-attribute -1)
- (funcall ada-case-identifier -1)))
- (goto-char begin))))
- (message "adjusting case ... done"))
- (set-syntax-table ada-mode-syntax-table))))
+ (save-excursion
+ (set-syntax-table ada-mode-symbol-syntax-table)
+ (goto-char to)
+ ;;
+ ;; loop: look for all identifiers, keywords, and attributes
+ ;;
+ (while (re-search-backward "\\<\\(\\sw+\\)\\>" from t)
+ (set 'end (match-end 1))
+ (set 'attribp
+ (and (> (point) from)
+ (save-excursion
+ (forward-char -1)
+ (set 'attribp (looking-at "'.[^']")))))
+ (or
+ ;; do nothing if it is a string or comment
+ (ada-in-string-or-comment-p)
+ (progn
+ ;;
+ ;; get the identifier or keyword or attribute
+ ;;
+ (set 'begin (point))
+ (set 'keywordp (looking-at ada-keywords))
+ (goto-char end)
+ ;;
+ ;; casing according to user-option
+ ;;
+ (if attribp
+ (funcall ada-case-attribute -1)
+ (if keywordp
+ (funcall ada-case-keyword -1)
+ (ada-adjust-case-identifier)))
+ (goto-char begin))))
+ (message "Adjusting case ... Done"))
+ (set-syntax-table previous-syntax-table))))
;;
;;;------------------------;;;
;;; Format Parameter Lists ;;;
;;;------------------------;;;
-
(defun ada-format-paramlist ()
"Reformats a parameter list.
ATTENTION: 1) Comments inside the list are killed !
(let ((begin nil)
(end nil)
(delend nil)
- (paramlist nil))
+ (paramlist nil)
+ (previous-syntax-table (syntax-table)))
(unwind-protect
- (progn
- (set-syntax-table ada-mode-symbol-syntax-table)
+ (progn
+ (set-syntax-table ada-mode-symbol-syntax-table)
- ;; check if really inside parameter list
- (or (ada-in-paramlist-p)
- (error "not in parameter list"))
- ;;
- ;; find start of current parameter-list
- ;;
- (ada-search-ignore-string-comment
+ ;; check if really inside parameter list
+ (or (ada-in-paramlist-p)
+ (error "not in parameter list"))
+ ;;
+ ;; find start of current parameter-list
+ ;;
+ (ada-search-ignore-string-comment
(concat ada-subprog-start-re "\\|\\<body\\>" ) t nil)
- (ada-search-ignore-string-comment "(" nil nil t)
- (backward-char 1)
- (setq begin (point))
+ (down-list 1)
+ (backward-char 1)
+ (set 'begin (point))
- ;;
- ;; find end of parameter-list
- ;;
- (forward-sexp 1)
- (setq delend (point))
- (delete-char -1)
+ ;;
+ ;; find end of parameter-list
+ ;;
+ (forward-sexp 1)
+ (set 'delend (point))
+ (delete-char -1)
- ;;
- ;; find end of last parameter-declaration
- ;;
- (ada-search-ignore-string-comment "[^ \t\n]" t nil t)
- (forward-char 1)
- (setq end (point))
+ ;;
+ ;; find end of last parameter-declaration
+ ;;
+ (forward-comment -1000)
+ (set 'end (point))
- ;;
- ;; build a list of all elements of the parameter-list
- ;;
- (setq paramlist (ada-scan-paramlist (1+ begin) end))
+ ;;
+ ;; build a list of all elements of the parameter-list
+ ;;
+ (set 'paramlist (ada-scan-paramlist (1+ begin) end))
- ;;
- ;; delete the original parameter-list
- ;;
- (delete-region begin (1- delend))
+ ;;
+ ;; delete the original parameter-list
+ ;;
+ (delete-region begin (1- delend))
- ;;
- ;; insert the new parameter-list
- ;;
- (goto-char begin)
- (ada-insert-paramlist paramlist))
+ ;;
+ ;; insert the new parameter-list
+ ;;
+ (goto-char begin)
+ (ada-insert-paramlist paramlist))
;;
;; restore syntax-table
;;
- (set-syntax-table ada-mode-syntax-table)
+ (set-syntax-table previous-syntax-table)
)))
;; find first character of parameter-declaration
;;
(ada-goto-next-non-ws)
- (setq apos (point))
+ (set 'apos (point))
;;
;; find last character of parameter-declaration
;;
- (if (setq match-cons
- (ada-search-ignore-string-comment "[ \t\n]*;" nil end t))
+ (if (set 'match-cons
+ (ada-search-ignore-string-comment "[ \t\n]*;" nil end t))
(progn
- (setq epos (car match-cons))
- (setq semipos (cdr match-cons)))
- (setq epos end))
+ (set 'epos (car match-cons))
+ (set 'semipos (cdr match-cons)))
+ (set 'epos end))
;;
;; read name(s) of parameter(s)
;;
(goto-char apos)
- (looking-at "\\([a-zA-Z0-9_, \t\n]*[a-zA-Z0-9_]\\)[ \t\n]*:[^=]")
+ (looking-at "\\(\\(\\sw\\|[_, \t\n]\\)*\\(\\sw\\|_\\)\\)[ \t\n]*:[^=]")
- (setq param (list (buffer-substring (match-beginning 1)
- (match-end 1))))
- (ada-search-ignore-string-comment ":" nil epos t)
+ (set 'param (list (match-string 1)))
+ (ada-search-ignore-string-comment ":" nil epos t 'search-forward)
;;
;; look for 'in'
;;
- (setq apos (point))
- (setq param
- (append param
- (list
- (consp
- (ada-search-ignore-string-comment "\\<in\\>"
- nil
- epos
- t)))))
+ (set 'apos (point))
+ (set 'param
+ (append param
+ (list
+ (consp
+ (ada-search-ignore-string-comment
+ "in" nil epos t 'word-search-forward)))))
;;
;; look for 'out'
;;
(goto-char apos)
- (setq param
- (append param
- (list
- (consp
- (ada-search-ignore-string-comment "\\<out\\>"
- nil
- epos
- t)))))
+ (set 'param
+ (append param
+ (list
+ (consp
+ (ada-search-ignore-string-comment
+ "out" nil epos t 'word-search-forward)))))
;;
;; look for 'access'
;;
(goto-char apos)
- (setq param
- (append param
- (list
- (consp
- (ada-search-ignore-string-comment "\\<access\\>"
- nil
- epos
- t)))))
+ (set 'param
+ (append param
+ (list
+ (consp
+ (ada-search-ignore-string-comment
+ "access" nil epos t 'word-search-forward)))))
;;
;; skip 'in'/'out'/'access'
(ada-goto-next-non-ws))
;;
- ;; read type of parameter
+ ;; read type of parameter
;;
- (looking-at "\\<[a-zA-Z0-9_\\.\\']+\\>")
- (setq param
- (append param
- (list
- (buffer-substring (match-beginning 0)
- (match-end 0)))))
+ (looking-at "\\<\\(\\sw\\|[_.']\\)+\\>")
+ (set 'param
+ (append param
+ (list (match-string 0))))
;;
;; read default-expression, if there is one
;;
- (goto-char (setq apos (match-end 0)))
- (setq param
- (append param
- (list
- (if (setq match-cons
- (ada-search-ignore-string-comment ":="
- nil
- epos
- t))
- (buffer-substring (car match-cons)
- epos)
- nil))))
+ (goto-char (set 'apos (match-end 0)))
+ (set 'param
+ (append param
+ (list
+ (if (set 'match-cons
+ (ada-search-ignore-string-comment
+ ":=" nil epos t 'search-forward))
+ (buffer-substring (car match-cons) epos)
+ nil))))
;;
;; add this parameter-declaration to the list
;;
- (setq paramlist (append paramlist (list param)))
+ (set 'paramlist (append paramlist (list param)))
;;
;; check if it was the last parameter
;;
(if (eq epos end)
- (setq notend nil)
+ (set 'notend nil)
(goto-char semipos))
- ) ; end of loop
+ ) ; end of loop
(reverse paramlist)))
(outp nil)
(accessp nil)
(column nil)
- (orgpoint 0)
(firstcol nil))
;;
;; loop until last parameter
;;
(while (not (zerop i))
- (setq i (1- i))
+ (set 'i (1- i))
;;
;; get max length of parameter-name
;;
- (setq parlen
- (if (<= parlen (setq temp
- (length (nth 0 (nth i paramlist)))))
- temp
- parlen))
+ (set 'parlen
+ (if (<= parlen (set 'temp
+ (length (nth 0 (nth i paramlist)))))
+ temp
+ parlen))
;;
;; get max length of type-name
;;
- (setq typlen
- (if (<= typlen (setq temp
- (length (nth 4 (nth i paramlist)))))
- temp
- typlen))
+ (set 'typlen
+ (if (<= typlen (set 'temp
+ (length (nth 4 (nth i paramlist)))))
+ temp
+ typlen))
;;
;; is there any 'in' ?
;;
- (setq inp
- (or inp
- (nth 1 (nth i paramlist))))
+ (set 'inp
+ (or inp
+ (nth 1 (nth i paramlist))))
;;
;; is there any 'out' ?
;;
- (setq outp
- (or outp
- (nth 2 (nth i paramlist))))
+ (set 'outp
+ (or outp
+ (nth 2 (nth i paramlist))))
;;
;; is there any 'access' ?
;;
- (setq accessp
- (or accessp
- (nth 3 (nth i paramlist))))) ; end of loop
+ (set 'accessp
+ (or accessp
+ (nth 3 (nth i paramlist))))) ; end of loop
;;
;; does paramlist already start on a separate line ?
(re-search-backward "^.\\|[^ \t]" nil t)
(looking-at "^."))
;; yes => re-indent it
- (ada-indent-current)
+ (progn
+ (ada-indent-current)
+ (save-excursion
+ (if (looking-at "\\(is\\|return\\)")
+ (replace-match " \\1"))))
;;
- ;; no => insert newline and indent it
+ ;; no => insert it where we are after removing any whitespace
;;
- (progn
- (ada-indent-current)
- (newline)
- (delete-horizontal-space)
- (setq orgpoint (point))
- (setq column (save-excursion
- (funcall (ada-indent-function) orgpoint)))
- (indent-to column)
- ))
+ (fixup-whitespace)
+ (save-excursion
+ (cond
+ ((looking-at "[ \t]*\\(\n\\|;\\)")
+ (replace-match "\\1"))
+ ((looking-at "[ \t]*\\(is\\|return\\)")
+ (replace-match " \\1"))))
+ (insert " "))
(insert "(")
+ (ada-indent-current)
- (setq firstcol (current-column))
- (setq i (length paramlist))
+ (set 'firstcol (current-column))
+ (set 'i (length paramlist))
;;
;; loop until last parameter
;;
(while (not (zerop i))
- (setq i (1- i))
- (setq column firstcol)
+ (set 'i (1- i))
+ (set 'column firstcol)
;;
;; insert parameter-name, space and colon
(insert (nth 0 (nth i paramlist)))
(indent-to (+ column parlen 1))
(insert ": ")
- (setq column (current-column))
+ (set 'column (current-column))
;;
;; insert 'in' or space
(if (nth 3 (nth i paramlist))
(insert "access "))
- (setq column (current-column))
+ (set 'column (current-column))
;;
;; insert type-name and, if necessary, space and default-expression
;;
;; check if it was the last parameter
;;
- (if (not (zerop i))
- ;; no => insert ';' and newline and indent
- (progn
- (insert ";")
- (newline)
- (indent-to firstcol))
- ;; yes
- (insert ")"))
-
- ) ; end of loop
+ (if (zerop i)
+ (insert ")")
+ ;; no => insert ';' and newline and indent
+ (insert ";")
+ (newline)
+ (indent-to firstcol))
+ ) ; end of loop
;;
- ;; if anything follows, except semicolon:
+ ;; if anything follows, except semicolon, newline, is or return
;; put it in a new line and indent it
;;
- (if (not (looking-at "[ \t]*[;\n]"))
- (ada-indent-newline-indent))
+ (unless (looking-at "[ \t]*\\(;\\|\n\\|is\\|return\\)")
+ (ada-indent-newline-indent))
))
;;;----------------------------;;;
;;; Move To Matching Start/End ;;;
;;;----------------------------;;;
-
(defun ada-move-to-start ()
"Moves point to the matching start of the current Ada structure."
(interactive)
- (let ((pos (point)))
+ (let ((pos (point))
+ (previous-syntax-table (syntax-table)))
(unwind-protect
- (progn
- (set-syntax-table ada-mode-symbol-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 if an error occurs during processing
- ;;
- (or
- (ada-in-string-or-comment-p)
- (and (progn
- (or (looking-at "[ \t]*\\<end\\>")
- (backward-word 1))
- (or (looking-at "[ \t]*\\<end\\>")
- (backward-word 1))
- (or (looking-at "[ \t]*\\<end\\>")
- (error "not on end ...;")))
- (ada-goto-matching-start 1)
- (setq pos (point))
-
- ;;
- ;; on 'begin' => go on, according to user option
- ;;
- ada-move-to-declaration
- (looking-at "\\<begin\\>")
- (ada-goto-matching-decl-start)
- (setq pos (point))))
-
- ) ; end of save-excursion
-
- ;; now really move to the found position
- (goto-char pos)
- (message "searching for block start ... done"))
+ (message "searching for block start ...")
+ (save-excursion
+ ;;
+ ;; do nothing if in string or comment or not on 'end ...;'
+ ;; or if an error occurs during processing
+ ;;
+ (or
+ (ada-in-string-or-comment-p)
+ (and (progn
+ (or (looking-at "[ \t]*\\<end\\>")
+ (backward-word 1))
+ (or (looking-at "[ \t]*\\<end\\>")
+ (backward-word 1))
+ (or (looking-at "[ \t]*\\<end\\>")
+ (error "not on end ...;")))
+ (ada-goto-matching-start 1)
+ (set 'pos (point))
+
+ ;;
+ ;; on 'begin' => go on, according to user option
+ ;;
+ ada-move-to-declaration
+ (looking-at "\\<begin\\>")
+ (ada-goto-matching-decl-start)
+ (set 'pos (point))))
+
+ ) ; end of save-excursion
+
+ ;; now really move to the found position
+ (goto-char pos)
+ (message "searching for block start ... done"))
;;
;; restore syntax-table
;;
- (set-syntax-table ada-mode-syntax-table))))
-
+ (set-syntax-table previous-syntax-table))))
(defun ada-move-to-end ()
"Moves point to the matching end of the current block around point.
Moves to 'begin' if in a declarative part."
(interactive)
(let ((pos (point))
- (decstart nil)
- (packdecl nil))
+ (previous-syntax-table (syntax-table)))
(unwind-protect
- (progn
- (set-syntax-table ada-mode-symbol-syntax-table)
-
- (message "searching for block end ...")
- (save-excursion
+ (progn
+ (set-syntax-table ada-mode-symbol-syntax-table)
- (forward-char 1)
- (cond
- ;; directly on 'begin'
- ((save-excursion
- (ada-goto-previous-word)
- (looking-at "\\<begin\\>"))
- (ada-goto-matching-end 1))
- ;; on first line of defun declaration
- ((save-excursion
- (and (ada-goto-stmt-start)
- (looking-at "\\<function\\>\\|\\<procedure\\>" )))
- (ada-search-ignore-string-comment "\\<begin\\>"))
- ;; on first line of task declaration
- ((save-excursion
- (and (ada-goto-stmt-start)
- (looking-at "\\<task\\>" )
- (forward-word 1)
- (ada-search-ignore-string-comment "[^ \n\t]")
- (not (backward-char 1))
- (looking-at "\\<body\\>")))
- (ada-search-ignore-string-comment "\\<begin\\>"))
- ;; accept block start
- ((save-excursion
- (and (ada-goto-stmt-start)
- (looking-at "\\<accept\\>" )))
- (ada-goto-matching-end 0))
- ;; package start
- ((save-excursion
- (and (ada-goto-matching-decl-start t)
- (looking-at "\\<package\\>")))
- (ada-goto-matching-end 1))
- ;; inside a 'begin' ... 'end' block
- ((save-excursion
- (ada-goto-matching-decl-start t))
- (ada-search-ignore-string-comment "\\<begin\\>"))
- ;; (hopefully ;-) everything else
- (t
- (ada-goto-matching-end 1)))
- (setq pos (point))
+ (message "searching for block end ...")
+ (save-excursion
- ) ; end of save-excursion
+ (forward-char 1)
+ (cond
+ ;; directly on 'begin'
+ ((save-excursion
+ (ada-goto-previous-word)
+ (looking-at "\\<begin\\>"))
+ (ada-goto-matching-end 1))
+ ;; on first line of defun declaration
+ ((save-excursion
+ (and (ada-goto-stmt-start)
+ (looking-at "\\<function\\>\\|\\<procedure\\>" )))
+ (ada-search-ignore-string-comment "begin" nil nil nil 'word-search-forward))
+ ;; on first line of task declaration
+ ((save-excursion
+ (and (ada-goto-stmt-start)
+ (looking-at "\\<task\\>" )
+ (forward-word 1)
+ (ada-goto-next-non-ws)
+ (looking-at "\\<body\\>")))
+ (ada-search-ignore-string-comment "begin" nil nil nil 'word-search-forward))
+ ;; accept block start
+ ((save-excursion
+ (and (ada-goto-stmt-start)
+ (looking-at "\\<accept\\>" )))
+ (ada-goto-matching-end 0))
+ ;; package start
+ ((save-excursion
+ (and (ada-goto-matching-decl-start t)
+ (looking-at "\\<package\\>")))
+ (ada-goto-matching-end 1))
+ ;; inside a 'begin' ... 'end' block
+ ((save-excursion
+ (ada-goto-matching-decl-start t))
+ (ada-search-ignore-string-comment "begin" nil nil nil 'word-search-forward))
+ ;; (hopefully ;-) everything else
+ (t
+ (ada-goto-matching-end 1)))
+ (set 'pos (point))
+
+ ) ; end of save-excursion
+
+ ;; now really move to the found position
+ (goto-char pos)
+ (message "searching for block end ... done"))
- ;; now really move to the found position
- (goto-char pos)
- (message "searching for block end ... done"))
-
;;
;; restore syntax-table
;;
- (set-syntax-table ada-mode-syntax-table))))
+ (set-syntax-table previous-syntax-table))))
\f
;;;-----------------------------;;;
;;;-----------------------------;;;
;; ---- main functions for indentation
-
(defun ada-indent-region (beg end)
"Indents the region using `ada-indent-current' on each line."
(interactive "*r")
(goto-char beg)
(let ((block-done 0)
- (lines-remaining (count-lines beg end))
- (msg (format "indenting %4d lines %%4d lines remaining ..."
- (count-lines beg end)))
+ (lines-remaining (count-lines beg end))
+ (msg (format "indenting %4d lines %%4d lines remaining ..."
+ (count-lines beg end)))
(endmark (copy-marker end)))
;; catch errors while indenting
- (condition-case err
- (while (< (point) endmark)
- (if (> block-done 9)
- (progn (message msg lines-remaining)
- (setq block-done 0)))
- (if (looking-at "^$") nil
- (ada-indent-current))
- (forward-line 1)
- (setq block-done (1+ block-done))
- (setq lines-remaining (1- lines-remaining)))
- ;; show line number where the error occurred
- (error
- (error "line %d: %s" (1+ (count-lines (point-min) (point))) err) nil))
+ (while (< (point) endmark)
+ (if (> block-done 39)
+ (progn (message msg lines-remaining)
+ (set 'block-done 0)))
+ (if (looking-at "^$") nil
+ (ada-indent-current))
+ (forward-line 1)
+ (set 'block-done (1+ block-done))
+ (set 'lines-remaining (1- lines-remaining)))
(message "indenting ... done")))
-
(defun ada-indent-newline-indent ()
"Indents the current line, inserts a newline and then indents the new line."
(interactive "*")
(newline)
(ada-indent-current))
+(defun ada-indent-newline-indent-conditional ()
+ "If `ada-indent-after-return' is non-nil, then indents the current line,
+insert a newline and indents the newline.
+If `ada-indent-after-return' is nil then inserts a newline and indents the
+newline.
+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 it was chosen"
+ (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)
+ " + ")))
+ (save-excursion
+ (goto-char (car cur-indent))
+ (sit-for 1))))
(defun ada-indent-current ()
"Indents current line as Ada code.
-This works by two steps:
- 1) It moves point to the end of the previous code line.
- Then it calls the function to calculate the indentation for the
- following line as if a newline would be inserted there.
- The calculated column # is saved and the old position of point
- is restored.
- 2) Then another function is called to calculate the indentation for
- the current line, based on the previously calculated column #."
+Each of these steps returns a two element list:
+ - position of reference in the buffer
+ - offset to indent from this position (can also be a symbol or a list
+ that are evaluated"
(interactive)
+ (let ((previous-syntax-table (syntax-table))
+ (orgpoint (point-marker))
+ cur-indent tmp-indent
+ prev-indent)
+
+ (set-syntax-table ada-mode-symbol-syntax-table)
+
+ ;; This need to be done here so that the advice is not always activated
+ ;; (this might interact badly with other modes)
+ (if ada-xemacs
+ (ad-activate 'parse-partial-sexp t))
- (unwind-protect
- (progn
- (set-syntax-table ada-mode-symbol-syntax-table)
-
- (let ((line-end)
- (orgpoint (point-marker))
- (cur-indent)
- (prev-indent)
- (prevline t))
+ (unwind-protect
+ (progn
+ (save-excursion
+ (set 'cur-indent
+ ;; Not First line in the buffer ?
+
+ (if (save-excursion (zerop (forward-line -1)))
+ (progn
+ (back-to-indentation)
+ (ada-get-current-indent))
+
+ ;; first line in the buffer
+ (list (point-min) 0))))
+
+ ;; Evaluate the list to get the column to indent to
+ ;; prev-indent contains the column to indent to
+ (set 'prev-indent (save-excursion (goto-char (car cur-indent)) (current-column)))
+ (set 'tmp-indent (cdr cur-indent))
+ (while (not (null tmp-indent))
+ (cond
+ ((numberp (car tmp-indent))
+ (set 'prev-indent (+ prev-indent (car tmp-indent))))
+ (t
+ (set 'prev-indent (+ prev-indent (eval (car tmp-indent)))))
+ )
+ (set 'tmp-indent (cdr tmp-indent)))
+
+ ;; only reindent if indentation is different then the current
+ (if (= (save-excursion (back-to-indentation) (current-column)) prev-indent)
+ nil
+ (beginning-of-line)
+ (delete-horizontal-space)
+ (indent-to prev-indent))
;;
- ;; first step
+ ;; restore position of point
;;
- (save-excursion
- (if (ada-goto-prev-nonblank-line t)
- ;;
- ;; we are not in the first accessible line in the buffer
- ;;
- (progn
- ;;(end-of-line)
- ;;(forward-char 1)
- ;; we are already at the BOL
- (forward-line 1)
- (setq line-end (point))
- (setq prev-indent
- (save-excursion
- (funcall (ada-indent-function) line-end))))
- (progn ; first line of buffer -> set indent
- (beginning-of-line) ; to 0
- (delete-horizontal-space)
- (setq prevline nil))))
-
- (if prevline
- ;;
- ;; we are not in the first accessible line in the buffer
- ;;
- (progn
- ;;
- ;; second step
- ;;
- (back-to-indentation)
- (setq cur-indent (ada-get-current-indent prev-indent))
- ;; only reindent if indentation is different then the current
- (if (= (current-column) cur-indent)
- nil
- (delete-horizontal-space)
- (indent-to cur-indent))
- ;;
- ;; restore position of point
- ;;
- (goto-char orgpoint)
- (if (< (current-column) (current-indentation))
- (back-to-indentation))))))
-
+ (goto-char orgpoint)
+ (if (< (current-column) (current-indentation))
+ (back-to-indentation))))
;;
;; restore syntax-table
;;
- (set-syntax-table ada-mode-syntax-table)))
+ (if ada-xemacs
+ (ad-deactivate 'parse-partial-sexp))
+ (set-syntax-table previous-syntax-table)
+ cur-indent
+ ))
-(defun ada-get-current-indent (prev-indent)
- ;; Returns the column # to indent the current line to.
- ;; PREV-INDENT is the indentation resulting from the previous lines.
- (let ((column nil)
- (pos nil)
- (match-cons nil))
+(defun ada-get-current-indent ()
+ "Returns the column number to indent the current line to.
+
+Returns a list of two elements (same as prev-indent):
+ - Position in the cursor that is used as a reference (its columns
+ is used)
+ - variable used to calculate the indentation from position"
+ (let (column
+ pos
+ match-cons
+ (orgpoint (save-excursion
+ (beginning-of-line)
+ (forward-comment -10000)
+ (forward-line 1)
+ (point))))
(cond
+ ;;
+ ;; preprocessor line (gnatprep)
+ ;;
+ ((and (equal ada-which-compiler 'gnat)
+ (looking-at "#[ \t]*\\(if\\|else\\|elsif\\|end[ \t]*if\\)"))
+ (list (save-excursion (beginning-of-line) (point)) 0))
+
;;
;; in open parenthesis, but not in parameter-list
;;
((and
ada-indent-to-open-paren
(not (ada-in-paramlist-p))
- (setq column (ada-in-open-paren-p)))
+ (set 'column (ada-in-open-paren-p)))
;; check if we have something like this (Table_Component_Type =>
- ;; Source_File_Record,)
+ ;; Source_File_Record)
(save-excursion
- (if (and (ada-search-ignore-string-comment "[^ \t]" t nil)
- (looking-at "\n")
- (ada-search-ignore-string-comment "[^ \t\n]" t nil)
- (looking-at ">"))
- (setq column (+ ada-broken-indent column))))
- column)
+ (if (and (skip-chars-backward " \t")
+ (= (char-before) ?\n)
+ (not (forward-comment -10000))
+ (= (char-before) ?>))
+ (list column 'ada-broken-indent);; ??? Could use a different variable
+ (list column 0))))
;;
;; end
;; found 'loop' => skip back to 'while' or 'for'
;; if 'loop' is not on a separate line
;;
- (if (and
- (looking-at "\\<loop\\>")
- (save-excursion
- (back-to-indentation)
- (not (looking-at "\\<loop\\>"))))
+ (if (save-excursion
+ (beginning-of-line)
+ (looking-at ".+\\<loop\\>"))
(if (save-excursion
(and
- (setq match-cons
- (ada-search-ignore-string-comment
- ada-loop-start-re t nil))
+ (set 'match-cons
+ (ada-search-ignore-string-comment ada-loop-start-re t))
(not (looking-at "\\<loop\\>"))))
(progn
(goto-char (car match-cons))
(save-excursion
(beginning-of-line)
(if (looking-at ada-named-block-re)
- (setq label (- ada-label-indent)))))))
+ (set 'label (- ada-label-indent)))))))
- (+ (current-indentation) label))))
+ (list (+ (save-excursion (back-to-indentation) (point)) label) 0))))
;;
;; exception
;;
((looking-at "\\<exception\\>")
(save-excursion
(ada-goto-matching-start 1)
- (current-indentation)))
+ (list (save-excursion (back-to-indentation) (point)) 0)))
;;
;; when
;;
((looking-at "\\<when\\>")
(save-excursion
(ada-goto-matching-start 1)
- (+ (current-indentation) ada-when-indent)))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-when-indent)))
;;
;; else
;;
((looking-at "\\<else\\>")
- (if (save-excursion
- (ada-goto-previous-word)
- (looking-at "\\<or\\>"))
- prev-indent
+ (if (save-excursion (ada-goto-previous-word)
+ (looking-at "\\<or\\>"))
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)
(save-excursion
(ada-goto-matching-start 1 nil t)
- (current-indentation))))
+ (list (progn (back-to-indentation) (point)) 0))))
;;
;; elsif
;;
((looking-at "\\<elsif\\>")
(save-excursion
(ada-goto-matching-start 1 nil t)
- (current-indentation)))
+ (list (progn (back-to-indentation) (point)) 0)))
;;
;; then
;;
((looking-at "\\<then\\>")
- (if (save-excursion
- (ada-goto-previous-word)
- (looking-at "\\<and\\>"))
- prev-indent
+ (if (save-excursion (ada-goto-previous-word)
+ (looking-at "\\<and\\>"))
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)
(save-excursion
- (ada-search-ignore-string-comment "\\<elsif\\>\\|\\<if\\>" t nil)
- (+ (current-indentation) ada-stmt-end-indent))))
+ ;; Select has been added for the statement: "select ... then abort"
+ (ada-search-ignore-string-comment "\\<\\(elsif\\|if\\|select\\)\\>" t nil)
+ (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent))))
;;
;; loop
;;
((looking-at "\\<loop\\>")
- (setq pos (point))
+ (set 'pos (point))
(save-excursion
(goto-char (match-end 0))
(ada-goto-stmt-start)
- (if (looking-at "\\<loop\\>\\|\\<if\\>")
- prev-indent
- (progn
- (if (not (looking-at ada-loop-start-re))
- (ada-search-ignore-string-comment ada-loop-start-re
- nil pos))
- (if (looking-at "\\<loop\\>")
- prev-indent
- (+ (current-indentation) ada-stmt-end-indent))))))
+ (if (looking-at "\\<\\(loop\\|if\\)\\>")
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)
+ (unless (looking-at ada-loop-start-re)
+ (ada-search-ignore-string-comment ada-loop-start-re
+ nil pos))
+ (if (looking-at "\\<loop\\>")
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)
+ (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent)))))
;;
;; begin
;;
((looking-at "\\<begin\\>")
(save-excursion
(if (ada-goto-matching-decl-start t)
- (current-indentation)
- prev-indent)))
+ (list (progn (back-to-indentation) (point)) 0)
+ (ada-indent-on-previous-lines nil orgpoint orgpoint))))
;;
;; is
;;
((looking-at "\\<is\\>")
- (if (and
- ada-indent-is-separate
- (save-excursion
- (goto-char (match-end 0))
- (ada-goto-next-non-ws (save-excursion
- (end-of-line)
- (point)))
- (looking-at "\\<abstract\\>\\|\\<separate\\>")))
+ (if (and ada-indent-is-separate
+ (save-excursion
+ (goto-char (match-end 0))
+ (ada-goto-next-non-ws (save-excursion (end-of-line)
+ (point)))
+ (looking-at "\\<abstract\\>\\|\\<separate\\>")))
(save-excursion
(ada-goto-stmt-start)
- (+ (current-indentation) ada-indent))
+ (list (progn (back-to-indentation) (point)) 'ada-indent))
(save-excursion
(ada-goto-stmt-start)
- (+ (current-indentation) ada-stmt-end-indent))))
+ (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent))))
;;
;; record
;;
(ada-search-ignore-string-comment
"\\<\\(type\\|use\\)\\>" t nil)
(if (looking-at "\\<use\\>")
- (ada-search-ignore-string-comment "\\<for\\>" t nil))
- (+ (current-indentation) ada-indent-record-rel-type)))
+ (ada-search-ignore-string-comment "for" t nil nil 'word-search-backward))
+ (list (progn (back-to-indentation) (point)) 'ada-indent-record-rel-type)))
;;
- ;; or as statement-start
+ ;; 'or' as statement-start
+ ;; 'private' as statement-start
;;
- ((ada-looking-at-semi-or)
+ ((or (ada-looking-at-semi-or)
+ (ada-looking-at-semi-private))
(save-excursion
(ada-goto-matching-start 1)
- (current-indentation)))
- ;;
- ;; private as statement-start
- ;;
- ((ada-looking-at-semi-private)
- (save-excursion
- (ada-goto-matching-decl-start)
- (current-indentation)))
+ (list (progn (back-to-indentation) (point)) 0)))
;;
;; new/abstract/separate
;;
((looking-at "\\<\\(new\\|abstract\\|separate\\)\\>")
- (- prev-indent ada-indent (- ada-broken-indent)))
+ (ada-indent-on-previous-lines nil orgpoint orgpoint))
;;
;; return
;;
((looking-at "\\<return\\>")
(save-excursion
- (forward-sexp -1)
- (if (and (looking-at "(")
+ (forward-comment -1000)
+ (if (= (char-before) ?\))
+ (forward-sexp -1)
+ (forward-word -1))
+
+ ;; If there is a parameter list, and we have a function declaration
+ (if (and (= (char-after) ?\()
(save-excursion
(backward-sexp 2)
(looking-at "\\<function\\>")))
- (1+ (current-column))
- prev-indent)))
+
+ ;; The indentation depends of the value of ada-indent-return
+ (if (<= ada-indent-return 0)
+ (list (point) (- ada-indent-return))
+ (list (progn (backward-sexp 2) (point)) ada-indent-return))
+
+ ;; 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 (> ada-indent-return 0)
+ (save-excursion (forward-word -1)
+ (looking-at "\\<function\\>")))
+ (list (progn (forward-word -1) (point)) ada-indent-return)
+
+ ;; Else...
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)))))
;;
;; do
;;
((looking-at "\\<do\\>")
(save-excursion
(ada-goto-stmt-start)
- (+ (current-indentation) ada-stmt-end-indent)))
+ (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent)))
;;
;; package/function/procedure
;;
;; look for 'generic'
(if (and (ada-goto-matching-decl-start t)
(looking-at "generic"))
- (current-column)
- prev-indent)))
+ (list (progn (back-to-indentation) (point)) 0)
+ (ada-indent-on-previous-lines nil orgpoint orgpoint))))
;;
;; label
;;
- ((looking-at "\\<[a-zA-Z0-9_]+[ \t\n]*:[^=]")
+ ((looking-at "\\<\\(\\sw\\|_\\)+[ \t\n]*:[^=]")
(if (ada-in-decl-p)
- prev-indent
- (+ prev-indent ada-label-indent)))
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)
+ (set 'pos (ada-indent-on-previous-lines nil orgpoint orgpoint))
+ (list (car pos)
+ (cadr pos)
+ 'ada-label-indent)))
;;
;; identifier and other noindent-statements
;;
- ((looking-at "\\<[a-zA-Z0-9_]+[ \t\n]*")
- prev-indent)
+ ((looking-at "\\<\\(\\sw\\|_\\)+[ \t\n]*")
+ (ada-indent-on-previous-lines nil orgpoint orgpoint))
;;
;; beginning of a parameter list
;;
- ((looking-at "(")
- prev-indent)
+ ((and (not (eobp)) (= (char-after) ?\())
+ (ada-indent-on-previous-lines nil orgpoint orgpoint))
;;
;; end of a parameter list
;;
- ((looking-at ")")
+ ((and (not (eobp)) (= (char-after) ?\)))
(save-excursion
(forward-char 1)
(backward-sexp 1)
- (current-column)))
+ (list (point) 0)))
;;
;; comment
;;
((looking-at "--")
(if ada-indent-comment-as-code
- prev-indent
- (current-indentation)))
+ ;; If previous line is a comment, indent likewise
+ (save-excursion
+ (forward-line -1)
+ (beginning-of-line)
+ (if (looking-at "[ \t]*--")
+ (list (progn (back-to-indentation) (point)) 0)
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)))
+ (list (save-excursion (back-to-indentation) (point)) 0)))
;;
;; unknown syntax - maybe this should signal an error ?
;;
(t
- prev-indent))))
-
-
-(defun ada-indent-function (&optional nomove)
- ;; Returns the function to calculate the indentation for the current
- ;; line according to the previous statement, ignoring the contents
- ;; of the current line after point. Moves point to the beginning of
- ;; the current statement, if NOMOVE is nil.
-
- (let ((orgpoint (point))
- (func nil))
+ (ada-indent-on-previous-lines nil orgpoint orgpoint)))))
+
+(defun ada-indent-on-previous-lines (&optional nomove orgpoint initial-pos)
+ "Calculate the indentation of the current line, based on the previous lines
+in the buffer. This function does not pay any attention to the current line,
+since this is the role of the second step in the indentation
+ (see ada-get-current-indent).
+
+Returns a two element list:
+ - position of reference in the buffer
+ - offset to indent from this position (can also be a symbol or a list
+ that are evaluated)
+Moves point to the beginning of the current statement, if NOMOVE is nil."
+ (if initial-pos
+ (goto-char initial-pos))
+ (let ((oldpoint (point))
+ result)
;;
- ;; inside a parameter-list
+ ;; Is inside a parameter-list ?
;;
(if (ada-in-paramlist-p)
- (setq func 'ada-get-indent-paramlist)
- (progn
- ;;
- ;; move to beginning of current statement
- ;;
- (if (not nomove)
- (ada-goto-stmt-start))
- ;;
- ;; no beginning found => don't change indentation
- ;;
- (if (and
- (eq orgpoint (point))
- (not nomove))
- (setq func 'ada-get-indent-nochange)
+ (set 'result (ada-get-indent-paramlist orgpoint))
- (cond
- ;;
- ((and
- ada-indent-to-open-paren
- (ada-in-open-paren-p))
- (setq func 'ada-get-indent-open-paren))
- ;;
- ((looking-at "\\<end\\>")
- (setq func 'ada-get-indent-end))
- ;;
- ((looking-at ada-loop-start-re)
- (setq func 'ada-get-indent-loop))
- ;;
- ((looking-at ada-subprog-start-re)
- (setq func 'ada-get-indent-subprog))
- ;;
- ((looking-at ada-block-start-re)
- (setq func 'ada-get-indent-block-start))
- ;;
- ((looking-at "\\<type\\>")
- (setq func 'ada-get-indent-type))
- ;;
- ((looking-at "\\<\\(els\\)?if\\>")
- (setq func 'ada-get-indent-if))
- ;;
- ((looking-at "\\<case\\>")
- (setq func 'ada-get-indent-case))
- ;;
- ((looking-at "\\<when\\>")
- (setq func 'ada-get-indent-when))
- ;;
- ((looking-at "--")
- (setq func 'ada-get-indent-comment))
- ;;
- ((looking-at "[a-zA-Z0-9_]+[ \t\n]*:[^=]")
- (setq func 'ada-get-indent-label))
- ;;
- ((looking-at "\\<separate\\>")
- (setq func 'ada-get-indent-nochange))
- (t
- (setq func 'ada-get-indent-noindent))))))
+ ;;
+ ;; move to beginning of current statement
+ ;;
+ (unless nomove
+ (ada-goto-stmt-start))
- func))
+ (unless result
+ (progn
+ ;;
+ ;; no beginning found => don't change indentation
+ ;;
+ (if (and (eq oldpoint (point))
+ (not nomove))
+ (set 'result (ada-get-indent-nochange orgpoint))
+
+ (cond
+ ;;
+ ((and
+ ada-indent-to-open-paren
+ (ada-in-open-paren-p))
+ (set 'result (ada-get-indent-open-paren orgpoint)))
+ ;;
+ ((looking-at "end\\>")
+ (set 'result (ada-get-indent-end orgpoint)))
+ ;;
+ ((looking-at ada-loop-start-re)
+ (set 'result (ada-get-indent-loop orgpoint)))
+ ;;
+ ((looking-at ada-subprog-start-re)
+ (set 'result (ada-get-indent-subprog orgpoint)))
+ ;;
+ ((looking-at ada-block-start-re)
+ (set 'result (ada-get-indent-block-start orgpoint)))
+ ;;
+ ((looking-at "\\(sub\\)?type\\>")
+ (set 'result (ada-get-indent-type orgpoint)))
+ ;;
+ ((looking-at "\\(els\\)?if\\>")
+ (set 'result (ada-get-indent-if orgpoint)))
+ ;;
+ ((looking-at "case\\>")
+ (set 'result (ada-get-indent-case orgpoint)))
+ ;;
+ ((looking-at "when\\>")
+ (set 'result (ada-get-indent-when orgpoint)))
+ ;;
+ ((looking-at "\\(\\sw\\|_\\)+[ \t\n]*:[^=]")
+ (set 'result (ada-get-indent-label orgpoint)))
+ ;;
+ ((looking-at "separate\\>")
+ (set 'result (ada-get-indent-nochange orgpoint)))
+ (t
+ (set 'result (ada-get-indent-noindent orgpoint))))))))
+
+ result))
;; ---- functions to return indentation for special cases
(defun ada-get-indent-open-paren (orgpoint)
- ;; Returns the indentation (column #) for the new line after ORGPOINT.
- ;; Assumes point to be behind an open parenthesis not yet closed.
- (ada-in-open-paren-p))
+ "Returns the two element list for the indentation, when point is
+behind an open parenthesis not yet closed"
+ (list (ada-in-open-paren-p) 0))
(defun ada-get-indent-nochange (orgpoint)
- ;; Returns the indentation (column #) of the current line.
+ "Returns the two element list for the indentation of the current line"
(save-excursion
(forward-line -1)
- (current-indentation)))
+ (list (progn (back-to-indentation) (point)) 0)))
(defun ada-get-indent-paramlist (orgpoint)
- ;; Returns the indentation (column #) for the new line after ORGPOINT.
- ;; Assumes point to be inside a parameter-list.
+ "Returns the classical two position list for indentation for the new line
+after ORGPOINT.
+Assumes point to be inside a parameter list"
(save-excursion
(ada-search-ignore-string-comment "[^ \t\n]" t nil t)
(cond
;;
;; in front of the first parameter
;;
- ((looking-at "(")
+ ((= (char-after) ?\()
(goto-char (match-end 0))
- (current-column))
+ (list (point) 0))
;;
;; in front of another parameter
;;
- ((looking-at ";")
+ ((= (char-after) ?\;)
(goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t)))
(ada-goto-next-non-ws)
- (current-column))
+ (list (point) 0))
;;
;; inside a parameter declaration
;;
(t
(goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t)))
(ada-goto-next-non-ws)
- (+ (current-column) ada-broken-indent)))))
+ (list (point) 'ada-broken-indent)))))
-(defun ada-get-indent-end (orgpoint)
+(defun ada-get-indent-end (orgpoint &optional do-not-check-start)
;; Returns the indentation (column #) for the new line after ORGPOINT.
;; Assumes point to be at the beginning of an end-statement.
;; Therefore it has to find the corresponding start. This can be a little
;; is the line already terminated by ';' ?
;;
(if (save-excursion
- (ada-search-ignore-string-comment ";" nil orgpoint))
+ (ada-search-ignore-string-comment ";" nil orgpoint nil 'search-forward))
;;
;; yes, look what's following 'end'
;;
(forward-word 1)
(ada-goto-next-non-ws)
(cond
+ ((looking-at "\\<\\(loop\\|select\\|if\\|case\\)\\>")
+ (unless do-not-check-start
+ (save-excursion (ada-check-matching-start (match-string 0))))
+ (list (save-excursion (back-to-indentation) (point)) 0))
+
;;
;; loop/select/if/case/record/select
;;
- ((looking-at "\\<\\(loop\\|select\\|if\\|case\\|record\\)\\>")
+ ((looking-at "\\<record\\>")
(save-excursion
- (ada-check-matching-start
- (buffer-substring (match-beginning 0)
- (match-end 0)))
- (if (looking-at "\\<\\(loop\\|record\\)\\>")
- (progn
- (forward-word 1)
- (ada-goto-stmt-start)))
- ;; a label ? => skip it
- (if (looking-at ada-named-block-re)
- (progn
- (setq label (- ada-label-indent))
- (goto-char (match-end 0))
- (ada-goto-next-non-ws)))
- ;; really looking-at the right thing ?
- (or (looking-at (concat "\\<\\("
- "loop\\|select\\|if\\|case\\|"
- "record\\|while\\|type\\)\\>"))
- (progn
- (ada-search-ignore-string-comment
- (concat "\\<\\("
- "loop\\|select\\|if\\|case\\|"
- "record\\|while\\|type\\)\\>")))
- (backward-word 1))
- (+ (current-indentation) label)))
+ (ada-check-matching-start (match-string 0))
+ ;; we are now looking at the matching "record" statement
+ (forward-word 1)
+ (ada-goto-stmt-start)
+ ;; now on the matching type declaration, or use clause
+ (unless (looking-at "\\(for\\|type\\)\\>")
+ (ada-search-ignore-string-comment "\\<type\\>" t))
+ (list (progn (back-to-indentation) (point)) 0)))
;;
;; a named block end
;;
((looking-at ada-ident-re)
- (setq defun-name (buffer-substring (match-beginning 0)
- (match-end 0)))
- (save-excursion
- (ada-goto-matching-start 0)
- (ada-check-defun-name defun-name)
- (current-indentation)))
+ (unless do-not-check-start
+ (progn
+ (set 'defun-name (match-string 0))
+ (save-excursion
+ (ada-goto-matching-start 0)
+ (ada-check-defun-name defun-name))))
+ (list (progn (back-to-indentation) (point)) 0))
;;
;; a block-end without name
;;
- ((looking-at ";")
- (save-excursion
- (ada-goto-matching-start 0)
- (if (looking-at "\\<begin\\>")
- (progn
- (setq indent (current-column))
- (if (ada-goto-matching-decl-start t)
- (current-indentation)
- indent)))))
+ ((= (char-after) ?\;)
+ (unless do-not-check-start
+ (save-excursion
+ (ada-goto-matching-start 0)
+ (if (looking-at "\\<begin\\>")
+ (progn
+ (set 'indent (list (point) 0))
+ (if (ada-goto-matching-decl-start t)
+ (list (progn (back-to-indentation) (point)) 0)
+ indent))))
+ (list (progn (back-to-indentation) (point)) 0)))
;;
;; anything else - should maybe signal an error ?
;;
(t
- (+ (current-indentation) ada-broken-indent))))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent))))
- (+ (current-indentation) ada-broken-indent))))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent))))
(defun ada-get-indent-case (orgpoint)
;; Returns the indentation (column #) for the new line after ORGPOINT.
;; Assumes point to be at the beginning of a case-statement.
- (let ((cur-indent (current-indentation))
- (match-cons nil)
+ (let ((match-cons nil)
(opos (point)))
(cond
;;
;; case..is..when..=>
;;
((save-excursion
- (setq match-cons (and
+ (set 'match-cons (and
;; the `=>' must be after the keyword `is'.
(ada-search-ignore-string-comment
- "\\<is\\>" nil orgpoint)
+ "is" nil orgpoint nil 'word-search-forward)
(ada-search-ignore-string-comment
"[ \t\n]+=>" nil orgpoint))))
(save-excursion
(goto-char (car match-cons))
- (if (not (ada-search-ignore-string-comment "\\<when\\>" t opos))
- (error "missing 'when' between 'case' and '=>'"))
- (+ (current-indentation) ada-indent)))
+ (unless (ada-search-ignore-string-comment "when" t opos)
+ (error "missing 'when' between 'case' and '=>'"))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-indent)))
;;
;; case..is..when
;;
((save-excursion
- (setq match-cons (ada-search-ignore-string-comment
- "\\<when\\>" nil orgpoint)))
+ (set 'match-cons (ada-search-ignore-string-comment
+ "when" nil orgpoint nil 'word-search-forward)))
(goto-char (cdr match-cons))
- (+ (current-indentation) ada-broken-indent))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent))
;;
;; case..is
;;
((save-excursion
- (setq match-cons (ada-search-ignore-string-comment
- "\\<is\\>" nil orgpoint)))
- (+ (current-indentation) ada-when-indent))
+ (set 'match-cons (ada-search-ignore-string-comment
+ "is" nil orgpoint nil 'word-search-forward)))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-when-indent))
;;
;; incomplete case
;;
(t
- (+ (current-indentation) ada-broken-indent)))))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent)))))
(defun ada-get-indent-when (orgpoint)
;; Returns the indentation (column #) for the new line after ORGPOINT.
;; Assumes point to be at the beginning of an when-statement.
- (let ((cur-indent (current-indentation)))
+ (let ((cur-indent (save-excursion (back-to-indentation) (point))))
(if (ada-search-ignore-string-comment
- "[ \t\n]+=>" nil orgpoint)
- (+ cur-indent ada-indent)
- (+ cur-indent ada-broken-indent))))
+ "[ \t\n]*=>" nil orgpoint)
+ (list cur-indent 'ada-indent)
+ (list cur-indent 'ada-broken-indent))))
(defun ada-get-indent-if (orgpoint)
;; Returns the indentation (column #) for the new line after ORGPOINT.
;; Assumes point to be at the beginning of an if-statement.
- (let ((cur-indent (current-indentation))
+ (let ((cur-indent (save-excursion (back-to-indentation) (point)))
(match-cons nil))
;;
- ;; if..then ?
+ ;; Move to the correct then (ignore all "and then")
;;
- (if (ada-search-but-not
- "\\<then\\>" "\\<and\\>[ \t\n]+\\<then\\>" nil orgpoint)
-
+ (while (and (set 'match-cons (ada-search-ignore-string-comment
+ "\\<\\(then\\|and[ \t]*then\\)\\>"
+ nil orgpoint))
+ (= (char-after (car match-cons)) ?a)))
+ ;; If "then" was found (we are looking at it)
+ (if match-cons
(progn
;;
;; 'then' first in separate line ?
- ;; => indent according to 'then'
+ ;; => indent according to 'then',
+ ;; => else indent according to 'if'
;;
(if (save-excursion
(back-to-indentation)
(looking-at "\\<then\\>"))
- (setq cur-indent (current-indentation)))
+ (set 'cur-indent (save-excursion (back-to-indentation) (point))))
+ ;; skip 'then'
(forward-word 1)
- ;;
- ;; something follows 'then' ?
- ;;
- (if (setq match-cons
- (ada-search-ignore-string-comment
- "[^ \t\n]" nil orgpoint))
- (progn
- (goto-char (car match-cons))
- (+ ada-indent
- (- cur-indent (current-indentation))
- (funcall (ada-indent-function t) orgpoint)))
+ (list cur-indent 'ada-indent))
- (+ cur-indent ada-indent)))
-
- (+ cur-indent ada-broken-indent))))
+ (list cur-indent 'ada-broken-indent))))
(defun ada-get-indent-block-start (orgpoint)
;; Returns the indentation (column #) for the new line after
;; ORGPOINT. Assumes point to be at the beginning of a block start
;; keyword.
- (let ((cur-indent (current-indentation))
- (pos nil))
+ (let ((pos nil))
(cond
((save-excursion
(forward-word 1)
- (setq pos (car (ada-search-ignore-string-comment
- "[^ \t\n]" nil orgpoint))))
+ (set 'pos (ada-goto-next-non-ws orgpoint)))
(goto-char pos)
(save-excursion
- (funcall (ada-indent-function t) orgpoint)))
+ (ada-indent-on-previous-lines t orgpoint)))
;;
;; nothing follows the block-start
;;
(t
- (+ (current-indentation) ada-indent)))))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-indent)))))
(defun ada-get-indent-subprog (orgpoint)
;; Returns the indentation (column #) for the new line after ORGPOINT.
;; Assumes point to be at the beginning of a subprog-/package-declaration.
(let ((match-cons nil)
- (cur-indent (current-indentation))
- (foundis nil)
- (addind 0)
- (fstart (point)))
+ (cur-indent (save-excursion (back-to-indentation) (point)))
+ (foundis nil))
;;
;; is there an 'is' in front of point ?
;;
(if (save-excursion
- (setq match-cons
- (ada-search-ignore-string-comment
- "\\<\\(is\\|do\\)\\>" nil orgpoint)))
+ (set 'match-cons
+ (ada-search-ignore-string-comment
+ "\\<\\(is\\|do\\)\\>" nil orgpoint)))
;;
;; yes, then skip to its end
;;
(progn
- (setq foundis t)
+ (set 'foundis t)
(goto-char (cdr match-cons)))
;;
;; no, then goto next non-ws, if there is one in front of point
;;
(progn
- (if (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint)
- (ada-goto-next-non-ws)
+ (unless (ada-goto-next-non-ws orgpoint)
(goto-char orgpoint))))
(cond
(save-excursion
(not (ada-search-ignore-string-comment
"[^ \t\n]" nil orgpoint t))))
- (+ cur-indent ada-indent))
+ (list cur-indent 'ada-indent))
;;
;; is abstract/separate/new ...
;;
((and
foundis
(save-excursion
- (setq match-cons
- (ada-search-ignore-string-comment
- "\\<\\(separate\\|new\\|abstract\\)\\>"
- nil orgpoint))))
+ (set 'match-cons
+ (ada-search-ignore-string-comment
+ "\\<\\(separate\\|new\\|abstract\\)\\>"
+ nil orgpoint))))
(goto-char (car match-cons))
(ada-search-ignore-string-comment ada-subprog-start-re t)
(ada-get-indent-noindent orgpoint))
;;
((and
foundis
- (save-excursion
- (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint))
- (ada-goto-next-non-ws)
- (funcall (ada-indent-function t) orgpoint)))
+ (save-excursion (set 'match-cons (ada-goto-next-non-ws orgpoint)))
+ (goto-char match-cons)
+ (ada-indent-on-previous-lines t orgpoint)))
;;
;; no 'is' but ';'
;;
((save-excursion
- (ada-search-ignore-string-comment ";" nil orgpoint))
- cur-indent)
+ (ada-search-ignore-string-comment ";" nil orgpoint nil 'search-forward))
+ (list cur-indent 0))
;;
;; no 'is' or ';'
;;
(t
- (+ cur-indent ada-broken-indent)))))
+ (list cur-indent 'ada-broken-indent)))))
(defun ada-get-indent-noindent (orgpoint)
(let ((label 0))
(save-excursion
(beginning-of-line)
- (if (looking-at ada-named-block-re)
- (setq label (- ada-label-indent))))
- (if (save-excursion
- (ada-search-ignore-string-comment ";" nil orgpoint))
- (+ (current-indentation) label)
- (+ (current-indentation) ada-broken-indent label))))
+ (cond
+
+ ;; This one is called when indenting a line preceded by a multiline
+ ;; subprogram declaration (in that case, we are at this point inside
+ ;; the parameter declaration list)
+ ((ada-in-paramlist-p)
+ (ada-previous-procedure)
+ (list (save-excursion (back-to-indentation) (point)) 0))
+
+ ;; This one is called when indenting the second line of a multiline
+ ;; declaration section, in a declare block or a record declaration
+ ((looking-at "[ \t]*\\(\\sw\\|_\\)*[ \t]*,[ \t]*$")
+ (list (save-excursion (back-to-indentation) (point))
+ 'ada-broken-decl-indent))
+
+ ;; This one is called in every over case when indenting a line at the
+ ;; top level
+ (t
+ (if (looking-at ada-named-block-re)
+ (set 'label (- ada-label-indent))
+
+ ;; "with private" or "null record" cases
+ (if (or (and (re-search-forward "\\<private\\>" orgpoint t)
+ (save-excursion (forward-char -7);; skip back "private"
+ (ada-goto-previous-word)
+ (looking-at "with")))
+ (and (re-search-forward "\\<record\\>" orgpoint t)
+ (save-excursion (forward-char -6);; skip back "record"
+ (ada-goto-previous-word)
+ (looking-at "null"))))
+ (progn
+ (re-search-backward "\\<\\(type\\|subtype\\)\\>" nil t)
+ (list (save-excursion (back-to-indentation) (point)) 0))))
+ (if (save-excursion
+ (ada-search-ignore-string-comment ";" nil orgpoint nil 'search-forward))
+ (list (+ (save-excursion (back-to-indentation) (point)) label) 0)
+ (list (+ (save-excursion (back-to-indentation) (point)) label)
+ 'ada-broken-indent)))))))
(defun ada-get-indent-label (orgpoint)
;; Returns the indentation (column #) for the new line after ORGPOINT.
;; Checks the context to decide if it's a label or a variable declaration.
;; This check might be a bit slow.
(let ((match-cons nil)
- (cur-indent (current-indentation)))
- (goto-char (cdr (ada-search-ignore-string-comment ":")))
+ (cur-indent (save-excursion (back-to-indentation) (point))))
+ (ada-search-ignore-string-comment ":" nil)
(cond
- ;;
;; loop label
- ;;
((save-excursion
- (setq match-cons (ada-search-ignore-string-comment
- ada-loop-start-re nil orgpoint)))
+ (set 'match-cons (ada-search-ignore-string-comment ada-loop-start-re nil orgpoint)))
(goto-char (car match-cons))
(ada-get-indent-loop orgpoint))
- ;;
+
;; declare label
- ;;
- ((save-excursion
- (setq match-cons (ada-search-ignore-string-comment
- "\\<declare\\|begin\\>" nil orgpoint)))
- (save-excursion
- (goto-char (car match-cons))
- (+ (current-indentation) ada-indent)))
- ;;
- ;; complete statement following colon
- ;;
- ((save-excursion
- (ada-search-ignore-string-comment ";" nil orgpoint))
- (if (ada-in-decl-p)
- cur-indent ; variable-declaration
- (- cur-indent ada-label-indent))) ; label
- ;;
- ;; broken statement
- ;;
((save-excursion
- (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint))
- (if (ada-in-decl-p)
- (+ cur-indent ada-broken-indent)
- (+ cur-indent ada-broken-indent (- ada-label-indent))))
- ;;
+ (set 'match-cons (ada-search-ignore-string-comment "\\<declare\\|begin\\>" nil orgpoint)))
+ (goto-char (car match-cons))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-indent))
+
+ ;; variable declaration
+ ((ada-in-decl-p)
+ (if (save-excursion
+ (ada-search-ignore-string-comment ";" nil orgpoint))
+ (list cur-indent 0)
+ (list cur-indent 'ada-broken-indent)))
+
;; nothing follows colon
- ;;
(t
- (if (ada-in-decl-p)
- (+ cur-indent ada-broken-indent) ; variable-declaration
- (- cur-indent ada-label-indent)))))) ; label
-
+ (list cur-indent '(- ada-label-indent))))))
(defun ada-get-indent-loop (orgpoint)
- ;; Returns the indentation (column #) for the new line after ORGPOINT.
- ;; Assumes point to be at the beginning of a loop statement
- ;; or (unfortunately) also a for ... use statement.
+ "Returns the two-element list for indentation.
+Assumes point to be at the beginning of a loop statement
+or a for ... use statement."
(let ((match-cons nil)
(pos (point))
+
+ ;; If looking at a named block, skip the label
(label (save-excursion
(beginning-of-line)
(if (looking-at ada-named-block-re)
(- ada-label-indent)
0))))
-
+
(cond
;;
;; statement complete
;;
((save-excursion
- (ada-search-ignore-string-comment ";" nil orgpoint))
- (+ (current-indentation) label))
+ (ada-search-ignore-string-comment ";" nil orgpoint nil 'search-forward))
+ (list (+ (save-excursion (back-to-indentation) (point)) label) 0))
;;
;; simple loop
;;
((looking-at "loop\\>")
- (+ (ada-get-indent-block-start orgpoint) label))
+ (set 'pos (ada-get-indent-block-start orgpoint))
+ (if (equal label 0)
+ pos
+ (list (+ (car pos) label) (cdr pos))))
;;
;; 'for'- loop (or also a for ... use statement)
((save-excursion
(and
(goto-char (match-end 0))
- (ada-search-ignore-string-comment "[^ /n/t]" nil orgpoint)
- (not (backward-char 1))
- (not (zerop (skip-chars-forward "_a-zA-Z0-9'")))
- (ada-search-ignore-string-comment "[^ /n/t]" nil orgpoint)
- (not (backward-char 1))
+ (ada-goto-next-non-ws orgpoint)
+ (forward-word 1)
+ (if (= (char-after) ?') (forward-word 1) t)
+ (ada-goto-next-non-ws orgpoint)
(looking-at "\\<use\\>")
;;
;; check if there is a 'record' before point
;;
(progn
- (setq match-cons (ada-search-ignore-string-comment
- "\\<record\\>" nil orgpoint))
+ (set 'match-cons (ada-search-ignore-string-comment
+ "record" nil orgpoint nil 'word-search-forward))
t)))
(if match-cons
(goto-char (car match-cons)))
- (+ (current-indentation) ada-indent))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-indent))
;;
;; for..loop
;;
((save-excursion
- (setq match-cons (ada-search-ignore-string-comment
- "\\<loop\\>" nil orgpoint)))
+ (set 'match-cons (ada-search-ignore-string-comment
+ "loop" nil orgpoint nil 'word-search-forward)))
(goto-char (car match-cons))
;;
;; indent according to 'loop', if it's first in the line;
;; otherwise to 'for'
;;
- (if (not (save-excursion
- (back-to-indentation)
- (looking-at "\\<loop\\>")))
- (goto-char pos))
- (+ (current-indentation) ada-indent label))
+ (unless (save-excursion
+ (back-to-indentation)
+ (looking-at "\\<loop\\>"))
+ (goto-char pos))
+ (list (+ (save-excursion (back-to-indentation) (point)) label) 'ada-indent))
;;
;; for-statement is broken
;;
(t
- (+ (current-indentation) ada-broken-indent label))))
+ (list (+ (save-excursion (back-to-indentation) (point)) label) 'ada-broken-indent))))
;;
;; 'while'-loop
;; while..loop ?
;;
(if (save-excursion
- (setq match-cons (ada-search-ignore-string-comment
- "\\<loop\\>" nil orgpoint)))
+ (set 'match-cons (ada-search-ignore-string-comment
+ "loop" nil orgpoint nil 'word-search-forward)))
(progn
(goto-char (car match-cons))
;; indent according to 'loop', if it's first in the line;
;; otherwise to 'while'.
;;
- (if (not (save-excursion
- (back-to-indentation)
- (looking-at "\\<loop\\>")))
- (goto-char pos))
- (+ (current-indentation) ada-indent label))
+ (unless (save-excursion
+ (back-to-indentation)
+ (looking-at "\\<loop\\>"))
+ (goto-char pos))
+ (list (+ (save-excursion (back-to-indentation) (point)) label) 'ada-indent))
- (+ (current-indentation) ada-broken-indent label))))))
+ (list (+ (save-excursion (back-to-indentation) (point)) label)
+ 'ada-broken-indent))))))
(defun ada-get-indent-type (orgpoint)
;;
((save-excursion
(and
- (setq match-dat (ada-search-ignore-string-comment "\\<end\\>"
- nil
- orgpoint))
+ (set 'match-dat (ada-search-ignore-string-comment
+ "end" nil orgpoint nil 'word-search-forward))
(ada-goto-next-non-ws)
(looking-at "\\<record\\>")
(forward-word 1)
(ada-goto-next-non-ws)
- (looking-at ";")))
+ (= (char-after) ?\;)))
(goto-char (car match-dat))
- (current-indentation))
+ (list (save-excursion (back-to-indentation) (point)) 0))
;;
;; record type
;;
((save-excursion
- (setq match-dat (ada-search-ignore-string-comment "\\<record\\>"
- nil
- orgpoint)))
+ (set 'match-dat (ada-search-ignore-string-comment
+ "record" nil orgpoint nil 'word-search-forward)))
(goto-char (car match-dat))
- (+ (current-indentation) ada-indent))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-indent))
;;
;; complete type declaration
;;
((save-excursion
- (ada-search-ignore-string-comment ";" nil orgpoint))
- (current-indentation))
+ (ada-search-ignore-string-comment ";" nil orgpoint nil 'search-forward))
+ (list (save-excursion (back-to-indentation) (point)) 0))
;;
;; "type ... is", but not "type ... is ...", which is broken
;;
((save-excursion
- (and
- (ada-search-ignore-string-comment "\\<is\\>" nil orgpoint)
- (not (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint))))
- (+ (current-indentation) ada-indent))
+ (and
+ (ada-search-ignore-string-comment "is" nil orgpoint nil 'word-search-forward)
+ (not (ada-goto-next-non-ws orgpoint))))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent))
;;
;; broken statement
;;
(t
- (+ (current-indentation) ada-broken-indent)))))
+ (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent)))))
\f
;;; ---- support-functions for indentation
;; by searching for 'ada-end-stmt-re' and then moving to the
;; following non-ws that is not a comment. LIMIT is actually not
;; used by the indentation functions.
+ ;; As a special case, if we are looking back at a closing parenthesis,
+ ;; we just skip the parenthesis
(let ((match-dat nil)
(orgpoint (point)))
- (setq match-dat (ada-search-prev-end-stmt limit))
+ (set 'match-dat (ada-search-prev-end-stmt limit))
(if match-dat
+
;;
;; found a previous end-statement => check if anything follows
;;
- (progn
- (if (not
- (save-excursion
- (goto-char (cdr match-dat))
- (ada-search-ignore-string-comment
- "[^ \t\n]" nil orgpoint)))
+ (unless (looking-at "declare")
+ (progn
+ (unless (save-excursion
+ (goto-char (cdr match-dat))
+ (ada-goto-next-non-ws orgpoint))
;;
;; nothing follows => it's the end-statement directly in
;; front of point => search again
;;
- (setq match-dat (ada-search-prev-end-stmt limit)))
- ;;
- ;; if found the correct end-statement => goto next non-ws
- ;;
- (if match-dat
- (goto-char (cdr match-dat)))
- (ada-goto-next-non-ws))
+ (set 'match-dat (ada-search-prev-end-stmt limit)))
+ ;;
+ ;; if found the correct end-statement => goto next non-ws
+ ;;
+ (if match-dat
+ (goto-char (cdr match-dat)))
+ (ada-goto-next-non-ws)
+ ))
;;
;; no previous end-statement => we are at the beginning of the
;;
;; skip to the very first statement, if there is one
;;
- (if (setq match-dat
- (ada-search-ignore-string-comment
- "[^ \t\n]" nil orgpoint))
- (goto-char (car match-dat))
+ (unless (ada-goto-next-non-ws orgpoint)
(goto-char orgpoint))))
-
(point)))
;; certain keywords if they follow 'end', which means they are no
;; end-statement there.
(let ((match-dat nil)
- (pos nil)
- (found nil))
+ (found nil)
+ parse)
+
;;
;; search until found or beginning-of-buffer
;;
(while
(and
(not found)
- (setq match-dat (ada-search-ignore-string-comment ada-end-stmt-re
- t
- limit)))
+ (set 'match-dat (ada-search-ignore-string-comment
+ ada-end-stmt-re t limit)))
(goto-char (car match-dat))
- (if (not (ada-in-open-paren-p))
- ;;
- ;; check if there is an 'end' in front of the match
- ;;
- (if (not (and
- (looking-at
- "\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>")
- (save-excursion
- (ada-goto-previous-word)
- (looking-at "\\<\\(end\\|or\\|and\\)\\>"))))
- (save-excursion
- (goto-char (cdr match-dat))
- (ada-goto-next-word)
- (if (not (looking-at "\\<\\(separate\\|new\\)\\>"))
- (setq found t)))
-
- (forward-word -1)))) ; end of loop
+ (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)
+ "\\>\\|(")))
+ (set 'found t))))
+ ))
(if found
match-dat
(defun ada-goto-next-non-ws (&optional limit)
- ;; Skips whitespaces, newlines and comments to next non-ws
- ;; character. Signals an error if there is no more such character
- ;; and limit is nil.
- (let ((match-cons nil))
- (setq match-cons (ada-search-ignore-string-comment
- "[^ \t\n]" nil limit t))
- (if match-cons
- (goto-char (car match-cons))
- (if (not limit)
- (error "no more non-ws")
- nil))))
+ "Skips whitespaces, newlines and comments to next non-ws
+character. Signals an error if there is no more such character
+and limit is nil.
+Do not call this function from within a string."
+ (unless limit
+ (set 'limit (point-max)))
+ (while (and (<= (point) limit)
+ (progn (forward-comment 10000)
+ (if (and (not (eobp))
+ (save-excursion (forward-char 1)
+ (ada-in-string-p)))
+ (progn (forward-sexp 1) t)))))
+ (if (< (point) limit)
+ (point)
+ nil)
+ )
(defun ada-goto-stmt-end (&optional limit)
;; If BACKWARD is non-nil, jump to the beginning of the previous word.
;; Returns the new position of point or nil if not found.
(let ((match-cons nil)
- (orgpoint (point)))
- (if (not backward)
- (skip-chars-forward "_a-zA-Z0-9\\."))
- (if (setq match-cons
- (ada-search-ignore-string-comment "\\w" backward nil t))
+ (orgpoint (point))
+ (old-syntax (char-to-string (char-syntax ?_))))
+ (modify-syntax-entry ?_ "w")
+ (unless backward
+ (skip-syntax-forward "w"));; ??? Used to have . too
+ (if (set 'match-cons
+ (if backward
+ (ada-search-ignore-string-comment "\\w" t nil t)
+ (ada-search-ignore-string-comment "\\w" nil nil t)))
;;
;; move to the beginning of the word found
;;
(progn
(goto-char (car match-cons))
- (skip-chars-backward "_a-zA-Z0-9")
+ (skip-syntax-backward "w")
(point))
;;
;; if not found, restore old position of point
;;
- (progn
- (goto-char orgpoint)
- 'nil))))
+ (goto-char orgpoint)
+ 'nil)
+ (modify-syntax-entry ?_ old-syntax))
+ )
-(defun ada-goto-previous-word ()
+(defsubst ada-goto-previous-word ()
;; Moves point to the beginning of the previous word of Ada code.
;; Returns the new position of point or nil if not found.
(ada-goto-next-word t))
;; Signals an error if matching block start is not KEYWORD.
;; Moves point to the matching block start.
(ada-goto-matching-start 0)
- (if (not (looking-at (concat "\\<" keyword "\\>")))
- (error "matching start is not '%s'" keyword)))
+ (unless (looking-at (concat "\\<" keyword "\\>"))
+ (error "matching start is not '%s'" keyword)))
(defun ada-check-defun-name (defun-name)
(if (save-excursion
(ada-goto-previous-word)
(looking-at (concat "\\<" defun-name "\\> *:")))
- t ; do nothing
+ t ; do nothing
;;
;; 'accept' or 'package' ?
;;
- (if (not (looking-at "\\<\\(accept\\|package\\|task\\|protected\\)\\>"))
- (ada-goto-matching-decl-start))
+ (unless (looking-at "\\<\\(accept\\|package\\|task\\|protected\\)\\>")
+ (ada-goto-matching-decl-start))
;;
;; 'begin' of 'procedure'/'function'/'task' or 'declare'
;;
;;
;; should be looking-at the correct name
;;
- (if (not (looking-at (concat "\\<" defun-name "\\>")))
- (error "matching defun has different name: %s"
- (buffer-substring (point)
- (progn (forward-sexp 1) (point))))))))
-
+ (unless (looking-at (concat "\\<" defun-name "\\>"))
+ (error "matching defun has different name: %s"
+ (buffer-substring (point)
+ (progn (forward-sexp 1) (point))))))))
(defun ada-goto-matching-decl-start (&optional noerror nogeneric)
;; Moves point to the matching declaration start of the current 'begin'.
;; If NOERROR is non-nil, it only returns nil if no match was found.
(let ((nest-count 1)
- (pos nil)
(first t)
- (flag nil))
+ (flag nil)
+ (count-generic nil)
+ )
+
+ (if (or
+ (looking-at "\\<\\(package\\|procedure\\|function\\)\\>")
+ (save-excursion
+ (ada-search-ignore-string-comment "\\<\\(package\\|procedure\\|function\\|generic\\)\\>" t)
+ (looking-at "generic")))
+ (set 'count-generic t))
+
;;
;; search backward for interesting keywords
;;
(while (and
(not (zerop nest-count))
- (ada-search-ignore-string-comment
- (concat "\\<\\("
- "is\\|separate\\|end\\|declare\\|new\\|begin\\|generic"
- "\\)\\>") t))
+ (ada-search-ignore-string-comment ada-matching-decl-start-re t))
;;
;; calculate nest-depth
;;
;;
((looking-at "end")
(ada-goto-matching-start 1 noerror)
- (if (looking-at "begin")
- (setq nest-count (1+ nest-count))))
+
+ ;; In some case, two begin..end block can follow each other closely,
+ ;; which we have to detect, as in
+ ;; procedure P is
+ ;; procedure Q is
+ ;; begin
+ ;; end;
+ ;; begin -- here we should go to procedure, not begin
+ ;; end
+
+ (let ((loop-again 0))
+ (if (looking-at "begin")
+ (set 'loop-again 1))
+
+ (save-excursion
+ (while (not (= loop-again 0))
+
+ ;; If begin was just there as the beginning of a block (with no
+ ;; declare) then do nothing, otherwise just register that we
+ ;; have to find the statement that required the begin
+
+ (ada-search-ignore-string-comment
+ "declare\\|begin\\|end\\|procedure\\|function\\|task\\|package"
+ t)
+
+ (if (looking-at "end")
+ (set 'loop-again (1+ loop-again))
+
+ (set 'loop-again (1- loop-again))
+ (unless (looking-at "begin")
+ (set 'nest-count (1+ nest-count))))
+ ))
+ ))
+ ;;
+ ((looking-at "generic")
+ (if count-generic
+ (progn
+ (set 'first nil)
+ (set 'nest-count (1- nest-count)))))
;;
- ((looking-at "declare\\|generic")
- (setq nest-count (1- nest-count))
- (setq first nil))
+ ((looking-at "declare\\|generic\\|if")
+ (set 'nest-count (1- nest-count))
+ (set 'first nil))
;;
((looking-at "is")
;; check if it is only a type definition, but not a protected
;; type definition, which should be handled like a procedure.
- (if (or (looking-at "is +<>")
+ (if (or (looking-at "is[ \t]+<>")
(save-excursion
- (ada-goto-previous-word)
- (skip-chars-backward "a-zA-Z0-9_.'")
- (if (save-excursion
- (backward-char 1)
- (looking-at ")"))
+ (forward-comment -10000)
+ (forward-char -1)
+
+ ;; Detect if we have a closing parenthesis (Could be
+ ;; either the end of subprogram parameters or (<>)
+ ;; in a type definition
+ (if (= (char-after) ?\))
(progn
(forward-char 1)
(backward-sexp 1)
- (skip-chars-backward "a-zA-Z0-9_.'")
+ (forward-comment -10000)
))
+ (skip-chars-backward "a-zA-Z0-9_.'")
(ada-goto-previous-word)
- (and
- (looking-at "\\<type\\>")
+ (and
+ (looking-at "\\<\\(sub\\)?type\\>")
(save-match-data
(ada-goto-previous-word)
(not (looking-at "\\<protected\\>"))))
- )); end of `or'
+ )) ; end of `or'
(goto-char (match-beginning 0))
(progn
- (setq nest-count (1- nest-count))
- (setq first nil))))
+ (set 'nest-count (1- nest-count))
+ (set 'first nil))))
;;
((looking-at "new")
;;
((and first
(looking-at "begin"))
- (setq nest-count 0)
- (setq flag t))
+ (set 'nest-count 0)
+ (set 'flag t))
;;
(t
- (setq nest-count (1+ nest-count))
- (setq first nil)))
+ (set 'nest-count (1+ nest-count))
+ (set 'first nil)))
- ) ;; end of loop
+ );; end of loop
;; check if declaration-start is really found
- (if (not
- (and
- (zerop nest-count)
- (not flag)
- (if (looking-at "is")
- (ada-search-ignore-string-comment ada-subprog-start-re t)
- (looking-at "declare\\|generic"))))
- (if noerror nil
- (error "no matching proc/func/task/declare/package/protected"))
- t)))
-
+ (if (and
+ (zerop nest-count)
+ (not flag)
+ (if (looking-at "is")
+ (ada-search-ignore-string-comment ada-subprog-start-re t)
+ (looking-at "declare\\|generic")))
+ t
+ (if noerror nil
+ (error "no matching proc/func/task/declare/package/protected")))
+ ))
(defun ada-goto-matching-start (&optional nest-level noerror gotothen)
;; Moves point to the beginning of a block-start. Which block
;;
(while (and
(not found)
- (ada-search-ignore-string-comment
- (concat "\\<\\("
- "end\\|loop\\|select\\|begin\\|case\\|do\\|"
- "if\\|task\\|package\\|record\\|protected\\)\\>")
- t))
+ (ada-search-ignore-string-comment ada-matching-start-re t))
+
+ (unless (and (looking-at "\\<record\\>")
+ (save-excursion
+ (forward-word -1)
+ (looking-at "\\<null\\>")))
+ (progn
+ ;;
+ ;; calculate nest-depth
+ ;;
+ (cond
+ ;; found block end => increase nest depth
+ ((looking-at "end")
+ (set 'nest-count (1+ nest-count)))
+
+ ;; found loop/select/record/case/if => check if it starts or
+ ;; ends a block
+ ((looking-at "loop\\|select\\|record\\|case\\|if")
+ (set 'pos (point))
+ (save-excursion
+ ;;
+ ;; check if keyword follows 'end'
+ ;;
+ (ada-goto-previous-word)
+ (if (looking-at "\\<end\\>[ \t]*[^;]")
+ ;; it ends a block => increase nest depth
+ (progn
+ (set 'nest-count (1+ nest-count))
+ (set 'pos (point)))
+ ;; it starts a block => decrease nest depth
+ (set 'nest-count (1- nest-count))))
+ (goto-char pos))
+
+ ;; found package start => check if it really is a block
+ ((looking-at "package")
+ (save-excursion
+ ;; ignore if this is just a renames statement
+ (let ((current (point))
+ (pos (ada-search-ignore-string-comment
+ "\\<\\(is\\|renames\\|;\\)\\>" nil)))
+ (if pos
+ (goto-char (car pos))
+ (error (concat
+ "No matching 'is' or 'renames' for 'package' at line "
+ (number-to-string (count-lines (point-min) (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\\)\\>"))
+ (set 'nest-count (1- nest-count)))))))
+ ;; found task start => check if it has a body
+ ((looking-at "task")
+ (save-excursion
+ (forward-word 1)
+ (ada-goto-next-non-ws)
+ (cond
+ ((looking-at "\\<body\\>"))
+ ((looking-at "\\<type\\>")
+ ;; In that case, do nothing if there is a "is"
+ (forward-word 2);; skip "type"
+ (ada-goto-next-non-ws);; skip type name
+
+ ;; Do nothing if we are simply looking at a simple
+ ;; "task type name;" statement with no block
+ (unless (looking-at ";")
+ (progn
+ ;; Skip the parameters
+ (if (looking-at "(")
+ (ada-search-ignore-string-comment ")" nil))
+ (let ((tmp (ada-search-ignore-string-comment
+ "\\<\\(is\\|;\\)\\>" nil)))
+ (if tmp
+ (progn
+ (goto-char (car tmp))
+ (if (looking-at "is")
+ (set 'nest-count (1- nest-count)))))))))
+ (t
+ ;; Check if that task declaration had a block attached to
+ ;; it (i.e do nothing if we have just "task name;")
+ (unless (progn (forward-word 1)
+ (looking-at "[ \t]*;"))
+ (set 'nest-count (1- nest-count)))))))
+ ;; all the other block starts
+ (t
+ (set 'nest-count (1- nest-count)))) ; end of 'cond'
- ;;
- ;; calculate nest-depth
- ;;
- (cond
- ;; found block end => increase nest depth
- ((looking-at "end")
- (setq nest-count (1+ nest-count)))
- ;; found loop/select/record/case/if => check if it starts or
- ;; ends a block
- ((looking-at "loop\\|select\\|record\\|case\\|if")
- (setq pos (point))
- (save-excursion
+ ;; match is found, if nest-depth is zero
;;
- ;; check if keyword follows 'end'
- ;;
- (ada-goto-previous-word)
- (if (looking-at "\\<end\\> *[^;]")
- ;; it ends a block => increase nest depth
- (progn
- (setq nest-count (1+ nest-count))
- (setq pos (point)))
- ;; it starts a block => decrease nest depth
- (setq nest-count (1- nest-count))))
- (goto-char pos))
- ;; found package start => check if it really is a block
- ((looking-at "package")
- (save-excursion
- (ada-search-ignore-string-comment "\\<is\\>")
- (ada-goto-next-non-ws)
- ;; ignore it if it is only a declaration with 'new'
- (if (not (looking-at "\\<new\\>"))
- (setq nest-count (1- nest-count)))))
- ;; found task start => check if it has a body
- ((looking-at "task")
- (save-excursion
- (forward-word 1)
- (ada-goto-next-non-ws)
- ;; ignore it if it has no body
- (if (not (looking-at "\\<body\\>"))
- (setq nest-count (1- nest-count)))))
- ;; all the other block starts
- (t
- (setq nest-count (1- nest-count)))) ; end of 'cond'
-
- ;; match is found, if nest-depth is zero
- ;;
- (setq found (zerop nest-count))) ; end of loop
+ (set 'found (zerop nest-count))))) ; end of loop
(if found
;;
gotothen
(looking-at "if")
(save-excursion
- (ada-search-ignore-string-comment "\\<then\\>" nil nil)
+ (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")
- (if (not (ada-search-ignore-string-comment "\\<accept\\>" t nil))
- (error "missing 'accept' in front of 'do'"))))
+ (unless (ada-search-ignore-string-comment "accept" t nil nil 'word-search-backward)
+ (error "missing 'accept' in front of 'do'"))))
(point))
(if noerror
(while (and
(not found)
(ada-search-ignore-string-comment
- (concat "\\<\\(end\\|loop\\|select\\|begin\\|case\\|"
- "if\\|task\\|package\\|record\\|do\\)\\>")))
+ (eval-when-compile
+ (concat "\\<"
+ (regexp-opt '("end" "loop" "select" "begin" "case"
+ "if" "task" "package" "record" "do") t)
+ "\\>")) nil))
;;
;; calculate nest-depth
(cond
;; found block end => decrease nest depth
((looking-at "\\<end\\>")
- (setq nest-count (1- nest-count))
+ (set 'nest-count (1- nest-count))
;; skip the following keyword
(if (progn
(skip-chars-forward "end")
(forward-word 1)))
;; found package start => check if it really starts a block
((looking-at "\\<package\\>")
- (ada-search-ignore-string-comment "\\<is\\>")
+ (ada-search-ignore-string-comment "is" nil nil nil 'word-search-forward)
(ada-goto-next-non-ws)
;; ignore and skip it if it is only a 'new' package
- (if (not (looking-at "\\<new\\>"))
- (setq nest-count (1+ nest-count))
- (skip-chars-forward "new")))
+ (if (looking-at "\\<new\\>")
+ (goto-char (match-end 0))
+ (set 'nest-count (1+ nest-count))))
;; all the other block starts
(t
- (setq nest-count (1+ nest-count))
- (forward-word 1))) ; end of 'cond'
+ (set 'nest-count (1+ nest-count))
+ (forward-word 1))) ; end of 'cond'
;; match is found, if nest-depth is zero
;;
- (setq found (zerop nest-count))) ; end of loop
+ (set 'found (zerop nest-count))) ; end of loop
- (if (not found)
- (if noerror
- nil
- (error "no matching end"))
- t)))
-
-
-(defun ada-forward-sexp-ignore-comment ()
- ;; Skips one sexp forward, ignoring comments.
- (while (looking-at "[ \t\n]*--")
- (skip-chars-forward "[ \t\n]")
- (end-of-line))
- (forward-sexp 1))
+ (if found
+ t
+ (if noerror
+ nil
+ (error "no matching end")))
+ ))
(defun ada-search-ignore-string-comment
- (search-re &optional backward limit paramlists)
+ (search-re &optional backward limit paramlists search-func )
;; Regexp-Search for SEARCH-RE, ignoring comments, strings and
;; parameter lists, if PARAMLISTS is nil. Returns a cons cell of
;; begin and end of match data or nil, if not found.
- (let ((found nil)
- (begin nil)
- (end nil)
- (pos nil)
- (search-func
- (if backward 're-search-backward
- 're-search-forward)))
+ ;; The search is done using search-func, so that we can choose using
+ ;; regular expression search, basic search, ...
+ ;; Point is moved at the beginning of the search-re
+ (let (found
+ begin
+ end
+ parse-result
+ (previous-syntax-table (syntax-table)))
+
+ (unless search-func
+ (set 'search-func (if backward 're-search-backward 're-search-forward)))
;;
;; search until found or end-of-buffer
+ ;; We have to test that we do not look further than limit
;;
+ (set-syntax-table ada-mode-symbol-syntax-table)
(while (and (not found)
+ (or (not limit)
+ (or (and backward (<= limit (point)))
+ (>= limit (point))))
(funcall search-func search-re limit 1))
- (setq begin (match-beginning 0))
- (setq end (match-end 0))
+ (set 'begin (match-beginning 0))
+ (set 'end (match-end 0))
+
+ (set 'parse-result (parse-partial-sexp
+ (save-excursion (beginning-of-line) (point))
+ (point)))
(cond
;;
- ;; found in comment => skip it
+ ;; If inside a string, skip it (and the following comments)
;;
- ((ada-in-comment-p)
- (if backward
- (progn
- (re-search-backward "--" nil 1)
- (goto-char (match-beginning 0)))
- (forward-line 1)
- ;; Used to have (beginning-of-line) here,
- ;; but that caused trouble at end of buffer with no newline.
- ))
+ ((ada-in-string-p parse-result)
+ (if ada-xemacs
+ (search-backward "\"" nil t)
+ (goto-char (nth 8 parse-result)))
+ (unless backward (forward-sexp 1)))
;;
- ;; found in string => skip it
+ ;; If inside a comment, skip it (and the following comments)
+ ;; There is a special code for comments at the end of the file
;;
- ((ada-in-string-p)
- (if backward
- (progn
- (re-search-backward "\"" nil 1) ; "\"\\|#" don't treat #
- (goto-char (match-beginning 0))))
- (re-search-forward "\"" nil 1))
+ ((ada-in-comment-p parse-result)
+ (if ada-xemacs
+ (progn
+ (forward-line 1)
+ (beginning-of-line)
+ (forward-comment -1))
+ (goto-char (nth 8 parse-result)))
+ (unless backward
+ ;; at the end of the file, it is not possible to skip a comment
+ ;; so we just go at the end of the line
+ (if (forward-comment 1)
+ (progn
+ (forward-comment 1000)
+ (beginning-of-line))
+ (end-of-line))))
;;
- ;; found character constant => ignore it
+ ;; directly in front of a comment => skip it, if searching forward
;;
- ((save-excursion
- (setq pos (- (point) (if backward 1 2)))
- (and (char-after pos)
- (= (char-after pos) ?')
- (= (char-after (+ pos 2)) ?')))
- ())
+ ((and (= (char-after begin) ?-) (= (char-after (1+ begin)) ?-))
+ (unless backward (progn (forward-char -1) (forward-comment 1000))))
+
;;
;; found a parameter-list but should ignore it => skip it
;;
- ((and (not paramlists)
- (ada-in-paramlist-p))
+ ((and (not paramlists) (ada-in-paramlist-p))
(if backward
- (ada-search-ignore-string-comment "(" t nil t)))
- ;;
- ;; directly in front of a comment => skip it, if searching forward
- ;;
- ((save-excursion
- (goto-char begin)
- (looking-at "--"))
- (if (not backward)
- (progn
- (forward-line 1)
- (beginning-of-line))))
+ (search-backward "(" nil t)
+ (search-forward ")" nil t)))
;;
;; found what we were looking for
;;
(t
- (setq found t)))) ; end of loop
-
- (if found
- (cons begin end)
- nil)))
-
-
-(defun ada-search-but-not (search-re not-search-re &optional backward limit)
- ;; Searches SEARCH-RE, ignoring parts of NOT-SEARCH-RE, strings,
- ;; comments and parameter-lists.
- (let ((begin nil)
- (end nil)
- (begin-not nil)
- (begin-end nil)
- (end-not nil)
- (ret-cons nil)
- (found nil))
-
- ;;
- ;; search until found or end-of-buffer
- ;;
- (while (and
- (not found)
- (save-excursion
- (setq ret-cons
- (ada-search-ignore-string-comment search-re
- backward limit))
- (if (consp ret-cons)
- (progn
- (setq begin (car ret-cons))
- (setq end (cdr ret-cons))
- t)
- nil)))
-
- (if (or
- ;;
- ;; if no NO-SEARCH-RE was found
- ;;
- (not
- (save-excursion
- (setq ret-cons
- (ada-search-ignore-string-comment not-search-re
- backward nil))
- (if (consp ret-cons)
- (progn
- (setq begin-not (car ret-cons))
- (setq end-not (cdr ret-cons))
- t)
- nil)))
- ;;
- ;; or this NO-SEARCH-RE is not a part of the SEARCH-RE
- ;; found before.
- ;;
- (or
- (<= end-not begin)
- (>= begin-not end)))
-
- (setq found t)
+ (set 'found t)))) ; end of loop
- ;;
- ;; not found the correct match => skip this match
- ;;
- (goto-char (if backward
- begin
- end)))) ; end of loop
+ (set-syntax-table previous-syntax-table)
(if found
- (progn
- (goto-char begin)
- (cons begin end))
+ (cons begin end)
nil)))
-
-(defun ada-goto-prev-nonblank-line ( &optional ignore-comment)
- ;; Moves point to the beginning of previous non-blank line,
- ;; ignoring comments if IGNORE-COMMENT is non-nil.
- ;; It returns t if a matching line was found.
- (let ((notfound t)
- (newpoint nil))
-
- (save-excursion
- ;;
- ;; backward one line, if there is one
- ;;
- (if (zerop (forward-line -1))
- ;;
- ;; there is some kind of previous line
- ;;
- (progn
- (beginning-of-line)
- (setq newpoint (point))
-
- ;;
- ;; search until found or beginning-of-buffer
- ;;
- (while (and (setq notfound
- (or (looking-at "[ \t]*$")
- (and (looking-at "[ \t]*--")
- ignore-comment)))
- (not (ada-in-limit-line-p)))
- (forward-line -1)
- ;;(beginning-of-line)
- (setq newpoint (point))) ; end of loop
-
- )) ; end of if
-
- ) ; end of save-excursion
-
- (if notfound nil
- (progn
- (goto-char newpoint)
- t))))
-
-
-(defun ada-goto-next-nonblank-line ( &optional ignore-comment)
- ;; Moves point to next non-blank line,
- ;; ignoring comments if IGNORE-COMMENT is non-nil.
- ;; It returns t if a matching line was found.
- (let ((notfound t)
- (newpoint nil))
-
- (save-excursion
- ;;
- ;; forward one line
- ;;
- (if (zerop (forward-line 1))
- ;;
- ;; there is some kind of previous line
- ;;
- (progn
- (beginning-of-line)
- (setq newpoint (point))
-
- ;;
- ;; search until found or end-of-buffer
- ;;
- (while (and (setq notfound
- (or (looking-at "[ \t]*$")
- (and (looking-at "[ \t]*--")
- ignore-comment)))
- (not (ada-in-limit-line-p)))
- (forward-line 1)
- (beginning-of-line)
- (setq newpoint (point))) ; end of loop
-
- )) ; end of if
-
- ) ; end of save-excursion
-
- (if notfound nil
- (progn
- (goto-char newpoint)
- t))))
-
-
;; ---- boolean functions for indentation
(defun ada-in-decl-p ()
(defun ada-looking-at-semi-private ()
- ;; Returns t if looking-at an 'private' following a semicolon.
+ "Returns t if looking-at an 'private' following a semicolon.
+Returns nil if the private is part of the package name, as in
+'private package A is...' (this can only happen at top level)"
(save-excursion
(and (looking-at "\\<private\\>")
- (progn
- (forward-word 1)
- (ada-goto-stmt-start)
- (looking-at "\\<private\\>")))))
-
-
-;;; make a faster??? ada-in-limit-line-p not using count-lines
-(defun ada-in-limit-line-p ()
- ;; return t if point is in first or last accessible line.
- (or (save-excursion (beginning-of-line) (= (point-min) (point)))
- (save-excursion (end-of-line) (= (point-max) (point)))))
-
-
-(defun ada-in-comment-p ()
- ;; Returns t if inside a comment.
- (nth 4 (parse-partial-sexp
- (save-excursion (beginning-of-line) (point))
- (point))))
-
-
-(defun ada-in-string-p ()
- ;; Returns t if point is inside a string
- ;; (Taken from pascal-mode.el, modified by MH).
- (save-excursion
- (and
- (nth 3 (parse-partial-sexp
- (save-excursion
- (beginning-of-line)
- (point)) (point)))
- ;; check if 'string quote' is only a character constant
- (progn
- (re-search-backward "\"" nil t) ; `#' is not taken as a string delimiter
- (not (= (char-after (1- (point))) ?'))))))
-
-
-(defun ada-in-string-or-comment-p ()
- ;; Returns t if point is inside a string, a comment, or a character constant.
- (let ((parse-result (parse-partial-sexp
- (save-excursion (beginning-of-line) (point)) (point))))
- (or ;; in-comment-p
- (nth 4 parse-result)
- ;; in-string-p
- (and
- (nth 3 parse-result)
- ;; check if 'string quote' is only a character constant
- (progn
- (re-search-backward "\"" nil t) ; `#' not regarded a string delimiter
- (not (= (char-after (1- (point))) ?'))))
- ;; in-char-const-p
- (ada-in-char-const-p))))
-
+ (not (looking-at "\\<private[ \t]*\\(package\\|generic\\)"))
+ (progn (forward-comment -1000)
+ (= (char-before) ?\;)))))
+
+(defsubst ada-in-comment-p (&optional parse-result)
+ "Returns t if inside a comment."
+ (nth 4 (or parse-result
+ (parse-partial-sexp
+ (save-excursion (beginning-of-line) (point)) (point)))))
+
+(defsubst ada-in-string-p (&optional parse-result)
+ "Returns t if point is inside a string.
+if parse-result is non-nil, use is instead of calling parse-partial-sexp"
+ (nth 3 (or parse-result
+ (parse-partial-sexp
+ (save-excursion (beginning-of-line) (point)) (point)))))
+
+(defsubst ada-in-string-or-comment-p (&optional parse-result)
+ "Returns t if inside a comment or string"
+ (set 'parse-result (or parse-result
+ (parse-partial-sexp
+ (save-excursion (beginning-of-line) (point)) (point))))
+ (or (ada-in-string-p parse-result) (ada-in-comment-p parse-result)))
(defun ada-in-paramlist-p ()
;; Returns t if point is inside a parameter-list
(and
(re-search-backward "(\\|)" nil t)
;; inside parentheses ?
- (looking-at "(")
+ (= (char-after) ?\()
(backward-word 2)
- ;; right keyword before parenthesis ?
- (looking-at (concat "\\<\\("
- "procedure\\|function\\|body\\|package\\|"
- "task\\|entry\\|accept\\)\\>"))
- (re-search-forward ")\\|:" nil t)
- ;; at least one ':' inside the parentheses ?
- (not (backward-char 1))
- (looking-at ":"))))
-
+
+ ;; We should ignore the case when the reserved keyword is in a
+ ;; comment (for instance, when we have:
+ ;; -- .... package
+ ;; Test (A)
+ ;; we should return nil
+
+ (not (ada-in-string-or-comment-p))
+
+ ;; right keyword two words before parenthesis ?
+ ;; Type is in this list because of discriminants
+ (looking-at (eval-when-compile
+ (concat "\\<\\("
+ "procedure\\|function\\|body\\|"
+ "task\\|entry\\|accept\\|"
+ "access[ \t]+procedure\\|"
+ "access[ \t]+function\\|"
+ "pragma\\|"
+ "type\\)\\>"))))))
;; not really a boolean function ...
(defun ada-in-open-paren-p ()
- ;; If point is somewhere behind an open parenthesis not yet closed,
- ;; it returns the column # of the first non-ws behind this open
- ;; parenthesis, otherwise nil."
- (let ((start (if (<= (point) ada-search-paren-char-count-limit)
- (point-min)
- (save-excursion
- (goto-char (- (point) ada-search-paren-char-count-limit))
- (beginning-of-line)
- (point))))
- parse-result
- (col nil))
- (setq parse-result (parse-partial-sexp start (point)))
- (if (nth 1 parse-result)
- (save-excursion
- (goto-char (1+ (nth 1 parse-result)))
- (if (save-excursion
- (re-search-forward "[^ \t]" nil 1)
- (backward-char 1)
- (and
- (not (looking-at "\n"))
- (setq col (current-column))))
- col
- (current-column)))
- nil)))
-
+ "If point is somewhere behind an open parenthesis not yet closed,
+it returns the position of the first non-ws behind that open parenthesis,
+otherwise nil"
+ (save-excursion
+ (let ((parse (parse-partial-sexp
+ (point)
+ (or (car (ada-search-ignore-string-comment "\\<\\(;\\|is\\|then\\|loop\\|begin\\|else\\)\\>" t))
+ (point-min)))))
+
+ (if (nth 1 parse)
+ (progn
+ (goto-char (1+ (nth 1 parse)))
+ (skip-chars-forward " \t")
+ (point))))))
\f
;;;----------------------;;;
;;; Behaviour Of TAB Key ;;;
;;;----------------------;;;
-
(defun ada-tab ()
- "Do indenting or tabbing according to `ada-tab-policy'."
+ "Do indenting or tabbing according to `ada-tab-policy'.
+
+In Transient Mark mode, if the mark is active, operate on the contents
+of the region. Otherwise, operates only on the current line"
(interactive)
- (cond ((eq ada-tab-policy 'indent-and-tab) (error "not implemented"))
- ;; ada-indent-and-tab
- ((eq ada-tab-policy 'indent-rigidly) (ada-tab-hard))
- ((eq ada-tab-policy 'indent-auto) (ada-indent-current))
- ((eq ada-tab-policy 'gei) (ada-tab-gei))
- ((eq ada-tab-policy 'indent-af) (af-indent-line)) ; GEB
+ (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 (region-active-p))
+ (and (not ada-xemacs)
+ transient-mark-mode
+ mark-active))
+ (ada-indent-region (region-beginning) (region-end))
+ (ada-indent-current)))
((eq ada-tab-policy 'always-tab) (error "not implemented"))
))
-
(defun ada-untab (arg)
"Delete leading indenting according to `ada-tab-policy'."
(interactive "P")
(cond ((eq ada-tab-policy 'indent-rigidly) (ada-untab-hard))
- ((eq ada-tab-policy 'indent-af) (backward-delete-char-untabify ; GEB
- (prefix-numeric-value arg) ; GEB
- arg)) ; GEB
((eq ada-tab-policy 'indent-auto) (error "not implemented"))
((eq ada-tab-policy 'always-tab) (error "not implemented"))
))
-
(defun ada-indent-current-function ()
"Ada mode version of the indent-line-function."
(interactive "*")
(let ((starting-point (point-marker)))
- (ada-beginning-of-line)
+ (beginning-of-line)
(ada-tab)
(if (< (point) starting-point)
(goto-char starting-point))
(set-marker starting-point nil)
))
-
(defun ada-tab-hard ()
"Indent current line to next tab stop."
(interactive)
(if (save-excursion (= (point) (progn (beginning-of-line) (point))))
(forward-char ada-indent)))
-
(defun ada-untab-hard ()
"indent current line to previous tab stop."
(interactive)
(let ((bol (save-excursion (progn (beginning-of-line) (point))))
- (eol (save-excursion (progn (end-of-line) (point)))))
+ (eol (save-excursion (progn (end-of-line) (point)))))
(indent-rigidly bol eol (- 0 ada-indent))))
;;;---------------;;;
(defun ada-remove-trailing-spaces ()
- "remove trailing spaces in the whole buffer."
+ "remove trailing spaces in the whole buffer."
(interactive)
(save-match-data
(save-excursion
(replace-match "" nil nil))))))
-(defun ada-untabify-buffer ()
-;; change all tabs to spaces
- (save-excursion
- (untabify (point-min) (point-max))
- nil))
-
-
-(defun ada-uncomment-region (beg end)
- "delete `comment-start' at the beginning of a line in the region."
- (interactive "r")
- (comment-region beg end -1))
-
-
;; define a function to support find-file.el if loaded
(defun ada-ff-other-window ()
"Find other file in other window using `ff-find-other-file'."
;;;-------------------------------;;;
;;; Moving To Procedures/Packages ;;;
;;;-------------------------------;;;
-
(defun ada-next-procedure ()
"Moves point to next procedure."
(interactive)
\f
;;;-----------------------
-;;; define keymap for Ada
+;;; define keymap and menus for Ada
;;;-----------------------
-(if (not ada-mode-map)
- (progn
- (setq ada-mode-map (make-sparse-keymap))
-
- ;; Indentation and Formatting
- (define-key ada-mode-map "\C-j" 'ada-indent-newline-indent)
- (define-key ada-mode-map "\t" 'ada-tab)
- (define-key ada-mode-map "\C-c\C-l" 'ada-indent-region)
- (if (ada-xemacs)
- (define-key ada-mode-map '(shift tab) 'ada-untab)
- (define-key ada-mode-map [S-tab] 'ada-untab))
- (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist)
- (define-key ada-mode-map "\C-c\C-p" 'ada-call-pretty-printer)
-;;; We don't want to make meta-characters case-specific.
-;;; (define-key ada-mode-map "\M-Q" 'ada-fill-comment-paragraph-justify)
- (define-key ada-mode-map "\M-\C-q" 'ada-fill-comment-paragraph-postfix)
-
- ;; Movement
-;;; It isn't good to redefine these. What should be done instead? -- rms.
-;;; (define-key ada-mode-map "\M-e" 'ada-next-package)
-;;; (define-key ada-mode-map "\M-a" 'ada-previous-package)
- (define-key ada-mode-map "\M-\C-e" 'ada-next-procedure)
- (define-key ada-mode-map "\M-\C-a" 'ada-previous-procedure)
- (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start)
- (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end)
-
- ;; Compilation
- (define-key ada-mode-map "\C-c\C-c" 'compile)
- (define-key ada-mode-map "\C-c\C-v" 'ada-check-syntax)
- (define-key ada-mode-map "\C-c\C-m" 'ada-make-local)
-
- ;; Casing
- (define-key ada-mode-map "\C-c\C-r" 'ada-adjust-case-region)
- (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer)
-
- (define-key ada-mode-map "\177" 'backward-delete-char-untabify)
-
- ;; Use predefined function of emacs19 for comments (RE)
- (define-key ada-mode-map "\C-c;" 'comment-region)
- (define-key ada-mode-map "\C-c:" 'ada-uncomment-region)
-
- ;; Change basic functionality
-
- ;; `substitute-key-definition' is not defined equally in Emacs
- ;; and XEmacs, you cannot put in an optional 4th parameter in
- ;; XEmacs. I don't think it's necessary, so I leave it out for
- ;; Emacs as well. If you encounter any problems with the
- ;; following three functions, please tell me. RE
- (mapcar (function (lambda (pair)
- (substitute-key-definition (car pair) (cdr pair)
- ada-mode-map)))
- '((beginning-of-line . ada-beginning-of-line)
- (end-of-line . ada-end-of-line)
- (forward-to-indentation . ada-forward-to-indentation)
- ))
- ;; else Emacs
- ;;(mapcar (lambda (pair)
- ;; (substitute-key-definition (car pair) (cdr pair)
- ;; ada-mode-map global-map))
+(defun ada-create-keymap ()
+ "Create the keymap associated with the Ada mode"
+
+ ;; Indentation and Formatting
+ (define-key ada-mode-map "\C-j" 'ada-indent-newline-indent-conditional)
+ (define-key ada-mode-map "\C-m" 'ada-indent-newline-indent-conditional)
+ (define-key ada-mode-map "\t" 'ada-tab)
+ (define-key ada-mode-map "\C-c\t" 'ada-justified-indent-current)
+ (define-key ada-mode-map "\C-c\C-l" 'ada-indent-region)
+ (if ada-xemacs
+ (define-key ada-mode-map '(shift tab) 'ada-untab)
+ (define-key ada-mode-map [S-tab] 'ada-untab))
+ (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist)
+ ;; We don't want to make meta-characters case-specific.
+
+ ;; Movement
+ (define-key ada-mode-map "\M-\C-e" 'ada-next-procedure)
+ (define-key ada-mode-map "\M-\C-a" 'ada-previous-procedure)
+ (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start)
+ (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end)
+
+ ;; Compilation
+ (unless (lookup-key ada-mode-map "\C-c\C-c")
+ (define-key ada-mode-map "\C-c\C-c" 'compile))
+
+ ;; Casing
+ (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer)
+ (define-key ada-mode-map "\C-c\C-t" 'ada-case-read-exceptions)
+ (define-key ada-mode-map "\C-c\C-y" 'ada-create-case-exception)
+
+ (define-key ada-mode-map "\177" 'backward-delete-char-untabify)
+
+ ;; Make body
+ (define-key ada-mode-map "\C-c\C-n" 'ada-make-subprogram-body)
+
+ ;; Use predefined function of emacs19 for comments (RE)
+ (define-key ada-mode-map "\C-c;" 'comment-region)
+ (define-key ada-mode-map "\C-c:" 'ada-uncomment-region)
- ))
+ )
-\f
-;;;-------------------
-;;; define menu 'Ada'
-;;;-------------------
-
-(require 'easymenu)
-
-(defun ada-add-ada-menu ()
- "Adds the menu 'Ada' to the menu bar in Ada mode."
- (easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode."
- '("Ada"
- ["Next Package" ada-next-package t]
- ["Previous Package" ada-previous-package t]
- ["Next Procedure" ada-next-procedure t]
- ["Previous Procedure" ada-previous-procedure t]
- ["Goto Start" ada-move-to-start t]
- ["Goto End" ada-move-to-end t]
- ["------------------" nil nil]
- ["Indent Current Line (TAB)"
- ada-indent-current-function t]
- ["Indent Lines in Region" ada-indent-region t]
- ["Format Parameter List" ada-format-paramlist t]
- ["Pretty Print Buffer" ada-call-pretty-printer t]
- ["------------" nil nil]
- ["Fill Comment Paragraph"
- ada-fill-comment-paragraph t]
- ["Justify Comment Paragraph"
- ada-fill-comment-paragraph-justify t]
- ["Postfix Comment Paragraph"
- ada-fill-comment-paragraph-postfix t]
- ["------------" nil nil]
- ["Adjust Case Region" ada-adjust-case-region t]
- ["Adjust Case Buffer" ada-adjust-case-buffer t]
- ["----------" nil nil]
- ["Comment Region" comment-region t]
- ["Uncomment Region" ada-uncomment-region t]
- ["----------------" nil nil]
- ["Global Make" compile (fboundp 'compile)]
- ["Local Make" ada-make-local t]
- ["Check Syntax" ada-check-syntax t]
- ["Next Error" next-error (fboundp 'next-error)]
- ["---------------" nil nil]
- ["Index" imenu (fboundp 'imenu)]
- ["--------------" nil nil]
- ["Other File Other Window" ada-ff-other-window
- (fboundp 'ff-find-other-file)]
- ["Other File" ff-find-other-file
- (fboundp 'ff-find-other-file)]))
- (if (ada-xemacs) (progn
- (easy-menu-add ada-mode-menu)
- (setq mode-popup-menu (cons "Ada mode" ada-mode-menu)))))
+(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")
+ (autoload 'imenu "imenu")
+ (easy-menu-define
+ ada-mode-menu ada-mode-map "Menu keymap for Ada mode"
+ '("Ada"
+ ("Help"
+ ["Ada Mode" (info "ada-mode") t])
+ ["Customize" (customize-group 'ada) (>= emacs-major-version 20)]
+ ("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]
+ )
+ ["Index" imenu t]
+ ))
+ (if ada-xemacs
+ (progn
+ (easy-menu-add ada-mode-menu ada-mode-map)
+ (define-key ada-mode-map [menu-bar] ada-mode-menu)
+ (set 'mode-popup-menu (cons "Ada mode" ada-mode-menu))
+ )
+ )
+ )
\f
-;;;-------------------------------
-;;; Define Some Support Functions
-;;;-------------------------------
-(defun ada-beginning-of-line (&optional arg)
- (interactive "P")
- (cond
- ((eq ada-tab-policy 'indent-af) (af-beginning-of-line arg))
- (t (beginning-of-line arg))
- ))
-(defun ada-end-of-line (&optional arg)
- (interactive "P")
- (cond
- ((eq ada-tab-policy 'indent-af) (af-end-of-line arg))
- (t (end-of-line arg))
- ))
+;;
+;; The two following calls are provided to enhance the standard
+;; comment-region function, which only allows uncommenting if the
+;; comment is at the beginning of a line. If the line have been reindented,
+;; we are unable to use comment-region, which makes no sense.
+;;
+(defadvice comment-region (before ada-uncomment-anywhere)
+ (if (and arg
+ (< arg 0)
+ (string= mode-name "Ada"))
+ (save-excursion
+ (let ((cs (concat "^[ \t]*" (regexp-quote comment-start))))
+ (goto-char beg)
+ (while (re-search-forward cs end t)
+ (replace-match comment-start))
+ ))))
-(defun ada-current-column ()
- (cond
- ((eq ada-tab-policy 'indent-af) (af-current-column))
- (t (current-column))
- ))
+;;
+;; Handling of comments
+;;
+
+(defun ada-uncomment-region (beg end &optional arg)
+ "delete `comment-start' at the beginning of a line in the region."
+ (interactive "r\nP")
+ (ad-activate 'comment-region)
+ (comment-region beg end (- (or arg 1)))
+ (ad-deactivate 'comment-region))
+
+(defun ada-fill-comment-paragraph-justify ()
+ "Fills current comment paragraph and justifies each line as well."
+ (interactive)
+ (ada-fill-comment-paragraph 'full))
+
+(defun ada-fill-comment-paragraph-postfix ()
+ "Fills current comment paragraph and justifies each line as well.
+Adds `ada-fill-comment-postfix' at the end of each line"
+ (interactive)
+ (ada-fill-comment-paragraph 'full t))
-(defun ada-forward-to-indentation (&optional arg)
+(defun ada-fill-comment-paragraph (&optional justify postfix)
+ "Fills the current comment paragraph.
+If JUSTIFY is non-nil, each line is justified as well.
+If POSTFIX and JUSTIFY are non-nil, `ada-fill-comment-postfix' is appended
+to each filled and justified line.
+The paragraph is indented on the first line."
(interactive "P")
- (cond
- ((eq ada-tab-policy 'indent-af) (af-forward-to-indentation arg))
- (t (forward-to-indentation arg))
- ))
+
+ ;; check if inside comment or just in front a comment
+ (if (and (not (ada-in-comment-p))
+ (not (looking-at "[ \t]*--")))
+ (error "not inside comment"))
+
+ (let* ((indent)
+ (from)
+ (to)
+ (opos (point-marker))
+
+ ;; Sets this variable to nil, otherwise it prevents
+ ;; fill-region-as-paragraph to work on Emacs <= 20.2
+ (parse-sexp-lookup-properties nil)
+
+ fill-prefix
+ (fill-column (current-fill-column)))
+
+ ;; Find end of paragraph
+ (back-to-indentation)
+ (while (and (not (eobp)) (looking-at "--[ \t]*[^ \t\n]"))
+ (forward-line 1)
+ (back-to-indentation))
+ (beginning-of-line)
+ (set 'to (point-marker))
+ (goto-char opos)
+
+ ;; Find beginning of paragraph
+ (back-to-indentation)
+ (while (and (not (bobp)) (looking-at "--[ \t]*[^ \t\n]"))
+ (forward-line -1)
+ (back-to-indentation))
+ (forward-line 1)
+ (beginning-of-line)
+ (set 'from (point-marker))
+
+ ;; Calculate the indentation we will need for the paragraph
+ (back-to-indentation)
+ (set 'indent (current-column))
+ ;; unindent the first line of the paragraph
+ (delete-region from (point))
+
+ ;; Remove the old postfixes
+ (goto-char from)
+ (while (re-search-forward (concat ada-fill-comment-postfix "\n") to t)
+ (replace-match "\n"))
+
+ (goto-char (1- to))
+ (set 'to (point-marker))
+
+ ;; Indent and justify the paragraph
+ (set 'fill-prefix ada-fill-comment-prefix)
+ (set-left-margin from to indent)
+ (if postfix
+ (set 'fill-column (- fill-column (length ada-fill-comment-postfix))))
+
+ (fill-region-as-paragraph from to justify)
+
+ ;; Add the postfixes if required
+ (if postfix
+ (save-restriction
+ (goto-char from)
+ (narrow-to-region from to)
+ (while (not (eobp))
+ (end-of-line)
+ (insert-char ? (- fill-column (current-column)))
+ (insert ada-fill-comment-postfix)
+ (forward-line))
+ ))
+
+ ;; In Emacs <= 20.2 and XEmacs <=20.4, there is a bug, and a newline is
+ ;; inserted at the end. Delete it
+ (if (or ada-xemacs
+ (<= emacs-major-version 19)
+ (and (= emacs-major-version 20)
+ (<= emacs-minor-version 2)))
+ (progn
+ (goto-char to)
+ (end-of-line)
+ (delete-char 1)))
+
+ (goto-char opos)))
;;;---------------------------------------------------
;;; support for find-file.el
;;;---------------------------------------------------
-
-;;;###autoload
+;;; Note : this function is overwritten when we work with GNAT: we then
+;;; use gnatkrunch
(defun ada-make-filename-from-adaname (adaname)
- "Determine the filename of a package/procedure from its own Ada name."
- ;; this is done simply by calling `gnatkr', when we work with GNAT. It
- ;; must be a more complex function in other compiler environments.
- (interactive "s")
- (let (krunch-buf)
- (setq krunch-buf (generate-new-buffer "*gkrunch*"))
- (save-excursion
- (set-buffer krunch-buf)
- ;; send adaname to external process `gnatkr'.
- (call-process "gnatkr" nil krunch-buf nil
- adaname ada-krunch-args)
- ;; fetch output of that process
- (setq adaname (buffer-substring
- (point-min)
- (progn
- (goto-char (point-min))
- (end-of-line)
- (point))))
- (kill-buffer krunch-buf)))
- (setq adaname adaname) ;; can I avoid this statement?
+ "Determine the filename of a package/procedure from its own Ada name.
+This is a generic function, independant from any compiler."
+ (while (string-match "\\." adaname)
+ (set 'adaname (replace-match "-" t t adaname)))
+ adaname
)
+(defun ada-other-file-name ()
+ "Return the name of the other file (the body if current-buffer is the spec,
+or the spec otherwise."
+ (let ((ff-always-try-to-create nil)
+ (buffer (current-buffer))
+ name)
+ (ff-find-other-file nil t);; same window, ignore 'with' lines
+ (if (equal buffer (current-buffer))
+
+ ;; other file not found
+ ""
+
+ ;; other file found
+ (set 'name (buffer-file-name))
+ (switch-to-buffer buffer)
+ name)))
;;; functions for placing the cursor on the corresponding subprogram
(defun ada-which-function-are-we-in ()
"Determine whether we are on a function definition/declaration.
-If that is the case remember the name of that function."
-
- (setq ff-function-name nil)
+If that is the case remember the name of that function.
+This function is used in support of the find-file.el package"
+ (set 'ff-function-name nil)
(save-excursion
- (if (re-search-backward ada-procedure-start-regexp nil t)
- (setq ff-function-name (buffer-substring (match-beginning 0)
- (match-end 0)))
- ; we didn't find a procedure start, perhaps there is a package
- (if (re-search-backward ada-package-start-regexp nil t)
- (setq ff-function-name (buffer-substring (match-beginning 0)
- (match-end 0)))
- ))))
+ (end-of-line);; make sure we get the complete name
+ (if (or (re-search-backward ada-procedure-start-regexp nil t)
+ (re-search-backward ada-package-start-regexp nil t))
+ (set 'ff-function-name (match-string 0)))
+ ))
+(defun ada-set-point-accordingly ()
+ "Move to the function declaration that was set by `ff-which-function-are-we-in'"
+ (if ff-function-name
+ (progn
+ (goto-char (point-min))
+ (unless (ada-search-ignore-string-comment (concat ff-function-name "\\b") nil)
+ (goto-char (point-min))))))
;;;---------------------------------------------------
;;; support for font-lock
;;;---------------------------------------------------
-
;; Strings are a real pain in Ada because a single quote character is
;; overloaded as a string quote and type/instance delimiter. By default, a
;; single quote is given punctuation syntax in `ada-mode-syntax-table'.
(defconst ada-font-lock-syntactic-keywords
;; Mark single quotes as having string quote syntax in 'c' instances.
- '(("\\(\'\\).\\(\'\\)" (1 (7 . ?\')) (2 (7 . ?\')))))
-
-(defconst ada-font-lock-keywords-1
- (list
- ;;
- ;; handle "type T is access function return S;"
- ;;
- (list "\\<\\(function[ \t]+return\\)\\>" '(1 font-lock-keyword-face) )
- ;;
- ;; accept, entry, function, package (body), protected (body|type),
- ;; pragma, procedure, task (body) plus name.
- (list (concat
- "\\<\\("
- "accept\\|"
- "entry\\|"
- "function\\|"
- "package[ \t]+body\\|"
- "package\\|"
- "pragma\\|"
- "procedure\\|"
- "protected[ \t]+body\\|"
- "protected[ \t]+type\\|"
- "protected\\|"
-;; "p\\(\\(ackage\\|rotected\\)\\(\\|[ \t]+\\(body\\|type\\)\\)\
-;;\\|r\\(agma\\|ocedure\\)\\)\\|"
- "task[ \t]+body\\|"
- "task[ \t]+type\\|"
- "task"
-;; "task\\(\\|[ \t]+body\\)"
- "\\)\\>[ \t]*"
- "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
- '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t)))
- "Subdued level highlighting for Ada mode.")
-
-(defconst ada-font-lock-keywords-2
- (append ada-font-lock-keywords-1
- (list
- ;;
- ;; Main keywords, except those treated specially below.
- (concat "\\<\\("
-; ("abort" "abs" "abstract" "accept" "access" "aliased" "all"
-; "and" "array" "at" "begin" "case" "declare" "delay" "delta"
-; "digits" "do" "else" "elsif" "entry" "exception" "exit" "for"
-; "generic" "if" "in" "is" "limited" "loop" "mod" "not"
-; "null" "or" "others" "private" "protected"
-; "range" "record" "rem" "renames" "requeue" "return" "reverse"
-; "select" "separate" "tagged" "task" "terminate" "then" "until"
-; "while" "xor")
- "a\\(b\\(ort\\|s\\(\\|tract\\)\\)\\|cce\\(pt\\|ss\\)\\|"
- "l\\(iased\\|l\\)\\|nd\\|rray\\|t\\)\\|begin\\|case\\|"
- "d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|"
- "e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|for\\|"
- "generic\\|i[fns]\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ot\\|ull\\)\\|"
- "o\\(r\\|thers\\|ut\\)\\|pr\\(ivate\\|otected\\)\\|"
- "r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|"
- "se\\(lect\\|parate\\)\\|"
- "t\\(agged\\|erminate\\|hen\\)\\|until\\|" ; task removed
- "wh\\(ile\\|en\\)\\|xor" ; "when" added
- "\\)\\>")
- ;;
- ;; Anything following end and not already fontified is a body name.
- '("\\<\\(end\\)\\>\\([ \t]+\\)?\\([a-zA-Z0-9_\\.]+\\)?"
- (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t))
- ;;
- ;; Variable name plus optional keywords followed by a type name. Slow.
-; (list (concat "\\<\\(\\sw+\\)\\>[ \t]*:?[ \t]*"
-; "\\(access\\|constant\\|in\\|in[ \t]+out\\|out\\)?[ \t]*"
-; "\\(\\sw+\\)?")
-; '(1 font-lock-variable-name-face)
-; '(2 font-lock-keyword-face nil t) '(3 font-lock-type-face nil t))
- ;;
- ;; Optional keywords followed by a type name.
- (list (concat ; ":[ \t]*"
- "\\<\\(access\\|constant\\|in[ \t]+out\\|in\\|out\\)\\>"
- "[ \t]*"
- "\\(\\sw+\\)?")
- '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t))
- ;;
- ;; Keywords followed by a type or function name.
- (list (concat "\\<\\("
- "new\\|of\\|subtype\\|type"
- "\\)\\>[ \t]*\\(\\sw+\\)?[ \t]*\\((\\)?")
- '(1 font-lock-keyword-face)
- '(2 (if (match-beginning 4)
- font-lock-function-name-face
- font-lock-type-face) nil t))
- ;;
- ;; Keywords followed by a (comma separated list of) reference.
- (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)\\>" ; "when" removed
- ; "[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") ; RE
- "[ \t]*\\([a-zA-Z0-9_\\.\\|, ]+\\)\\W")
- '(1 font-lock-keyword-face) '(2 font-lock-constant-face nil t))
- ;;
- ;; Goto tags.
- '("<<\\(\\sw+\\)>>" 1 font-lock-constant-face)
+ ;; As a special case, ''' will not be hilighted, but if we do not
+ ;; set this special case, then the rest of the buffer is hilighted as
+ ;; a string
+ ;; This sets the properties of the characters, so that ada-in-string-p
+ ;; correctly handles '"' too...
+ '(("\\('\\)[^'\n]\\('\\)" (1 (7 . ?')) (2 (7 . ?')))
+ ("^[ \t]*\\(#\\(if\\|else\\|elsif\\|end\\)\\)" (1 (11 . ?\n)))
))
- "Gaudy level highlighting for Ada mode.")
-(defvar ada-font-lock-keywords ada-font-lock-keywords-1
- "Default expressions to highlight in Ada mode.")
+(defvar ada-font-lock-keywords
+ (eval-when-compile
+ (list
+ ;;
+ ;; handle "type T is access function return S;"
+ (list "\\<\\(function[ \t]+return\\)\\>" '(1 font-lock-keyword-face) )
+ ;; preprocessor line
+ (list "^[ \t]*\\(#.*\n\\)" '(1 font-lock-type-face t))
-;; set font-lock properties for XEmacs
-(if (ada-xemacs)
- (put 'ada-mode 'font-lock-defaults
- '(ada-font-lock-keywords
- nil t ((?\_ . "w")(?\. . "w")) beginning-of-line)))
+ ;;
+ ;; accept, entry, function, package (body), protected (body|type),
+ ;; pragma, procedure, task (body) plus name.
+ (list (concat
+ "\\<\\("
+ "accept\\|"
+ "entry\\|"
+ "function\\|"
+ "package[ \t]+body\\|"
+ "package\\|"
+ "pragma\\|"
+ "procedure\\|"
+ "protected[ \t]+body\\|"
+ "protected[ \t]+type\\|"
+ "protected\\|"
+ "task[ \t]+body\\|"
+ "task[ \t]+type\\|"
+ "task"
+ "\\)\\>[ \t]*"
+ "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
+ '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t))
+ ;;
+ ;; Optional keywords followed by a type name.
+ (list (concat ; ":[ \t]*"
+ "\\<\\(access[ \t]+all\\|access\\|constant\\|in[ \t]+out\\|in\\|out\\)\\>"
+ "[ \t]*"
+ "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
+ '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t))
-;;;
-;;; support for outline
-;;;
+ ;;
+ ;; Main keywords, except those treated specially below.
+ (concat "\\<"
+ (regexp-opt
+ '("abort" "abs" "abstract" "accept" "access" "aliased" "all"
+ "and" "array" "at" "begin" "case" "declare" "delay" "delta"
+ "digits" "do" "else" "elsif" "entry" "exception" "exit" "for"
+ "generic" "if" "in" "is" "limited" "loop" "mod" "not"
+ "null" "or" "others" "private" "protected" "raise"
+ "range" "record" "rem" "renames" "requeue" "return" "reverse"
+ "select" "separate" "tagged" "task" "terminate" "then" "until"
+ "when" "while" "xor") t)
+ "\\>")
+ ;;
+ ;; Anything following end and not already fontified is a body name.
+ '("\\<\\(end\\)\\>\\([ \t]+\\)?\\(\\(\\sw\\|[_.]\\)+\\)?"
+ (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t))
+ ;;
+ ;; Keywords followed by a type or function name.
+ (list (concat "\\<\\("
+ "new\\|of\\|subtype\\|type"
+ "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?[ \t]*\\((\\)?")
+ '(1 font-lock-keyword-face)
+ '(2 (if (match-beginning 4)
+ font-lock-function-name-face
+ font-lock-type-face) nil t))
+ ;;
+ ;; Keywords followed by a (comma separated list of) reference.
+ (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)\\>" ; "when" removed
+ "[ \t\n]*\\(\\(\\sw\\|[_.|, \t\n]\\)+\\)\\W")
+ '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t))
+ ;;
+ ;; Goto tags.
+ '("<<\\(\\sw+\\)>>" 1 font-lock-reference-face)
+ ))
+ "Default expressions to highlight in Ada mode.")
+
+;;
+;; outline-minor-mode support
-;; used by outline-minor-mode
(defun ada-outline-level ()
- ;; This 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
- (skip-chars-forward "\t ")
+ (back-to-indentation)
(current-column))))
-;;;
-;;; generate body
-;;;
-(defun ada-gen-comment-until-proc ()
- ;; comment until spec of a procedure or a function.
- (forward-line 1)
- (set-mark-command (point))
- (if (re-search-forward ada-procedure-start-regexp nil t)
- (progn (goto-char (match-beginning 1))
- (comment-region (mark) (point)))
- (error "No more functions/procedures")))
-
+;;
+;; Body generation
+;;
(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.
+ ;; last search for ada-procedure-start-regexp.
(goto-char (car match))
- (let (proc-found func-found procname functype)
+ (let (func-found procname functype)
(cond
- ((or (setq proc-found (looking-at "^[ \t]*procedure"))
- (setq func-found (looking-at "^[ \t]*function")))
+ ((or (looking-at "^[ \t]*procedure")
+ (set 'func-found (looking-at "^[ \t]*function")))
;; treat it as a proc/func
- (forward-word 2)
+ (forward-word 2)
(forward-word -1)
- (setq procname (buffer-substring (point) (cdr match))) ; store proc name
-
- ;; goto end of procname
- (goto-char (cdr match))
-
- ;; skip over parameterlist
- (forward-sexp)
- ;; if function, skip over 'return' and result type.
- (if func-found
- (progn
- (forward-word 1)
- (skip-chars-forward " \t\n")
- (setq functype (buffer-substring (point)
- (progn
- (skip-chars-forward
- "a-zA-Z0-9_\.")
- (point))))))
- ;; look for next non WS
- (cond
- ((looking-at "[ \t]*;")
- (delete-region (match-beginning 0) (match-end 0)) ;; delete the ';'
- (ada-indent-newline-indent)
- (insert " is")
- (ada-indent-newline-indent)
- (if func-found
- (progn
- (insert "Result : ")
- (insert functype)
- (insert ";")
- (ada-indent-newline-indent)))
- (insert "begin -- ")
- (insert procname)
- (ada-indent-newline-indent)
- (insert "null;")
- (ada-indent-newline-indent)
+ (set 'procname (buffer-substring (point) (cdr match))) ; store proc name
+
+ ;; goto end of procname
+ (goto-char (cdr match))
+
+ ;; skip over parameterlist
+ (unless (looking-at "[ \t\n]*\\(;\\|return\\)")
+ (forward-sexp))
+
+ ;; if function, skip over 'return' and result type.
(if func-found
- (progn
- (insert "return Result;")
- (ada-indent-newline-indent)))
- (insert "end ")
- (insert procname)
- (insert ";")
- (ada-indent-newline-indent)
- )
- ;; else
- ((looking-at "[ \t\n]*is")
- ;; do nothing
- )
- ((looking-at "[ \t\n]*rename")
- ;; do nothing
- )
+ (progn
+ (forward-word 1)
+ (skip-chars-forward " \t\n")
+ (set 'functype (buffer-substring (point)
+ (progn
+ (skip-chars-forward
+ "a-zA-Z0-9_\.")
+ (point))))))
+ ;; look for next non WS
+ (cond
+ ((looking-at "[ \t]*;")
+ (delete-region (match-beginning 0) (match-end 0));; delete the ';'
+ (ada-indent-newline-indent)
+ (insert "is")
+ (ada-indent-newline-indent)
+ (if func-found
+ (progn
+ (insert "Result : " functype ";")
+ (ada-indent-newline-indent)))
+ (insert "begin")
+ (ada-indent-newline-indent)
+ (if func-found
+ (insert "return Result;")
+ (insert "null;"))
+ (ada-indent-newline-indent)
+ (insert "end " procname ";")
+ (ada-indent-newline-indent)
+ )
+ ;; else
+ ((looking-at "[ \t\n]*is")
+ ;; do nothing
+ )
+ ((looking-at "[ \t\n]*rename")
+ ;; do nothing
+ )
+ (t
+ (message "unknown syntax"))))
(t
- (message "unknown syntax")))
- ))))
-
+ (if (looking-at "^[ \t]*task")
+ (progn
+ (message "Task conversion is not yet implemented")
+ (forward-word 2)
+ (if (looking-at "[ \t]*;")
+ (forward-line)
+ (ada-move-to-end))
+ ))))))
(defun ada-make-body ()
"Create an Ada package body in the current buffer.
(insert-buffer (car (cdr (buffer-list))))
(ada-mode)
- (let (found)
- (if (setq found
- (ada-search-ignore-string-comment ada-package-start-regexp))
- (progn (goto-char (cdr found))
- (insert " body")
- ;; (forward-line -1)
- ;;(comment-region (point-min) (point))
- )
+ (let (found ada-procedure-or-package-start-regexp)
+ (if (set 'found
+ (ada-search-ignore-string-comment ada-package-start-regexp nil))
+ (progn (goto-char (cdr found))
+ (insert " body")
+ )
(error "No package"))
-
- ;; (comment-until-proc)
- ;; does not work correctly
- ;; must be done by hand
-
- (while (setq found
- (ada-search-ignore-string-comment ada-procedure-start-regexp))
- (ada-gen-treat-proc found))))
+ (set 'ada-procedure-or-package-start-regexp
+ (concat ada-procedure-start-regexp
+ "\\|"
+ ada-package-start-regexp))
-;;; provide ourself
+ (while (set 'found
+ (ada-search-ignore-string-comment
+ ada-procedure-or-package-start-regexp nil))
+ (progn
+ (goto-char (car found))
+ (if (looking-at ada-package-start-regexp)
+ (progn (goto-char (cdr found))
+ (insert " body"))
+ (ada-gen-treat-proc found))))))
+
+(defun ada-make-subprogram-body ()
+ "make one dummy subprogram body from spec surrounding point"
+ (interactive)
+ (let* ((found (re-search-backward ada-procedure-start-regexp nil t))
+ (spec (match-beginning 0)))
+ (if found
+ (progn
+ (goto-char spec)
+ (if (and (re-search-forward "(\\|;" nil t)
+ (= (char-before) ?\())
+ (progn
+ (ada-search-ignore-string-comment ")" nil)
+ (ada-search-ignore-string-comment ";" nil)))
+ (set 'spec (buffer-substring spec (point)))
+
+ ;; If find-file.el was available, use its functions
+ (if (functionp 'ff-get-file)
+ (find-file (ff-get-file
+ ff-search-directories
+ (ada-make-filename-from-adaname
+ (file-name-nondirectory
+ (file-name-sans-extension (buffer-name))))
+ ada-body-suffixes))
+ ;; Else emulate it very simply
+ (find-file (concat (ada-make-filename-from-adaname
+ (file-name-nondirectory
+ (file-name-sans-extension (buffer-name))))
+ ".adb")))
+
+ (save-restriction
+ (widen)
+ (goto-char (point-max))
+ (forward-comment -10000)
+ (re-search-backward "\\<end\\>" nil t)
+ ;; Move to the beginning of the elaboration part, if any
+ (re-search-backward "^begin" nil t)
+ (newline)
+ (forward-char -1)
+ (insert spec)
+ (re-search-backward ada-procedure-start-regexp nil t)
+ (ada-gen-treat-proc (cons (match-beginning 0) (match-end 0)))
+ ))
+ (error "Not in subprogram spec"))))
+
+;; Create the keymap once and for all. If we do that in ada-mode,
+;; the keys changed in the user's .emacs have to be modified
+;; every time
+(ada-create-keymap)
+(ada-create-menu)
+
+;; Create the syntax tables, but do not activate them
+(ada-create-syntax-table)
+
+;; Add the default extensions (and set up speedbar)
+(ada-add-extensions ".ads" ".adb")
+;; This two files are generated by GNAT when running with -gnatD
+(if (equal ada-which-compiler 'gnat)
+ (ada-add-extensions ".ads.dg" ".adb.dg"))
+
+;; Read the special cases for exceptions
+(ada-case-read-exceptions)
+
+;; include 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.
+ (condition-case nil (require 'ada-prj) (error nil))
+ (require 'ada-xref)
+ ))
+(condition-case nil (require 'ada-stmt) (error nil))
+;;; provide ourselves
(provide 'ada-mode)
;;; ada-mode.el ends here
+
projects / emacs.git / commitdiff